ghc-lib 0.20200601 → 0.20200704
raw patch · 209 files changed
+12790/−13454 lines, 209 filesdep ~ghc-lib-parser
Dependency ranges changed: ghc-lib-parser
Files
- compiler/GHC.hs +32/−25
- compiler/GHC/Builtin/Names/TH.hs +21/−9
- compiler/GHC/Builtin/Utils.hs +1/−1
- compiler/GHC/ByteCode/Asm.hs +1/−1
- compiler/GHC/ByteCode/InfoTable.hs +5/−2
- compiler/GHC/ByteCode/Linker.hs +1/−1
- compiler/GHC/Cmm/CallConv.hs +10/−6
- compiler/GHC/Cmm/DebugBlock.hs +2/−2
- compiler/GHC/Cmm/Info.hs +44/−43
- compiler/GHC/Cmm/Info/Build.hs +1/−1
- compiler/GHC/Cmm/LayoutStack.hs +1/−1
- compiler/GHC/Cmm/Monad.hs +1/−1
- compiler/GHC/Cmm/Parser.y +28/−19
- compiler/GHC/Cmm/Pipeline.hs +1/−1
- compiler/GHC/Cmm/Ppr/Expr.hs +1/−1
- compiler/GHC/Cmm/ProcPoint.hs +5/−3
- compiler/GHC/CmmToAsm.hs +3/−3
- compiler/GHC/CmmToAsm/BlockLayout.hs +1/−1
- compiler/GHC/CmmToAsm/CFG.hs +3/−3
- compiler/GHC/CmmToAsm/CPrim.hs +10/−0
- compiler/GHC/CmmToAsm/Dwarf.hs +1/−1
- compiler/GHC/CmmToAsm/Dwarf/Constants.hs +1/−1
- compiler/GHC/CmmToAsm/Monad.hs +2/−3
- compiler/GHC/CmmToAsm/PPC/CodeGen.hs +1/−0
- compiler/GHC/CmmToAsm/PPC/Ppr.hs +1/−1
- compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs +3/−0
- compiler/GHC/CmmToAsm/SPARC/CodeGen.hs +1/−0
- compiler/GHC/CmmToAsm/SPARC/CodeGen/Base.hs +1/−1
- compiler/GHC/CmmToAsm/SPARC/Ppr.hs +1/−1
- compiler/GHC/CmmToAsm/SPARC/Regs.hs +1/−1
- compiler/GHC/CmmToAsm/X86/CodeGen.hs +103/−57
- compiler/GHC/CmmToAsm/X86/Instr.hs +4/−0
- compiler/GHC/CmmToAsm/X86/Ppr.hs +9/−8
- compiler/GHC/CmmToC.hs +1/−0
- compiler/GHC/CmmToLlvm.hs +9/−5
- compiler/GHC/CmmToLlvm/Base.hs +90/−102
- compiler/GHC/CmmToLlvm/CodeGen.hs +43/−19
- compiler/GHC/CmmToLlvm/Data.hs +5/−6
- compiler/GHC/CmmToLlvm/Ppr.hs +10/−8
- compiler/GHC/CmmToLlvm/Regs.hs +2/−0
- compiler/GHC/Core/Lint.hs +0/−2985
- compiler/GHC/Core/Opt/CSE.hs +2/−2
- compiler/GHC/Core/Opt/CprAnal.hs +3/−3
- compiler/GHC/Core/Opt/DmdAnal.hs +171/−122
- compiler/GHC/Core/Opt/Driver.hs +32/−28
- compiler/GHC/Core/Opt/Exitify.hs +3/−1
- compiler/GHC/Core/Opt/FloatIn.hs +2/−3
- compiler/GHC/Core/Opt/SetLevels.hs +33/−6
- compiler/GHC/Core/Opt/Simplify.hs +440/−182
- compiler/GHC/Core/Opt/Simplify/Env.hs +10/−5
- compiler/GHC/Core/Opt/Simplify/Monad.hs +8/−5
- compiler/GHC/Core/Opt/Simplify/Utils.hs +99/−63
- compiler/GHC/Core/Opt/SpecConstr.hs +12/−11
- compiler/GHC/Core/Opt/Specialise.hs +15/−11
- compiler/GHC/Core/Opt/StaticArgs.hs +3/−2
- compiler/GHC/Core/Opt/WorkWrap.hs +37/−24
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs +85/−40
- compiler/GHC/Core/Ppr/TyThing.hs +1/−1
- compiler/GHC/Core/Rules.hs +32/−24
- compiler/GHC/Core/Tidy.hs +4/−2
- compiler/GHC/CoreToByteCode.hs +15/−15
- compiler/GHC/CoreToStg.hs +6/−3
- compiler/GHC/CoreToStg/Prep.hs +120/−145
- compiler/GHC/Data/Bitmap.hs +1/−1
- compiler/GHC/Driver/Backpack.hs +29/−26
- compiler/GHC/Driver/CodeOutput.hs +6/−8
- compiler/GHC/Driver/Finder.hs +28/−23
- compiler/GHC/Driver/Main.hs +44/−42
- compiler/GHC/Driver/Make.hs +130/−93
- compiler/GHC/Driver/MakeFile.hs +5/−7
- compiler/GHC/Driver/Pipeline.hs +27/−26
- compiler/GHC/HsToCore.hs +6/−6
- compiler/GHC/HsToCore/Arrows.hs +33/−32
- compiler/GHC/HsToCore/Binds.hs +30/−20
- compiler/GHC/HsToCore/Coverage.hs +6/−4
- compiler/GHC/HsToCore/Docs.hs +26/−24
- compiler/GHC/HsToCore/Expr.hs +46/−35
- compiler/GHC/HsToCore/Foreign/Call.hs +21/−19
- compiler/GHC/HsToCore/Foreign/Decl.hs +35/−13
- compiler/GHC/HsToCore/GuardedRHSs.hs +5/−1
- compiler/GHC/HsToCore/ListComp.hs +24/−24
- compiler/GHC/HsToCore/Match.hs +35/−15
- compiler/GHC/HsToCore/Match/Constructor.hs +30/−11
- compiler/GHC/HsToCore/Match/Literal.hs +63/−27
- compiler/GHC/HsToCore/Monad.hs +15/−14
- compiler/GHC/HsToCore/PmCheck.hs +5/−5
- compiler/GHC/HsToCore/PmCheck/Oracle.hs +9/−16
- compiler/GHC/HsToCore/PmCheck/Ppr.hs +2/−2
- compiler/GHC/HsToCore/Quote.hs +175/−135
- compiler/GHC/HsToCore/Usage.hs +25/−7
- compiler/GHC/HsToCore/Utils.hs +38/−24
- compiler/GHC/Iface/Binary.hs +11/−7
- compiler/GHC/Iface/Env.hs +4/−4
- compiler/GHC/Iface/Ext/Ast.hs +29/−11
- compiler/GHC/Iface/Ext/Binary.hs +1/−1
- compiler/GHC/Iface/Ext/Types.hs +4/−3
- compiler/GHC/Iface/Ext/Utils.hs +7/−5
- compiler/GHC/Iface/Load.hs +37/−30
- compiler/GHC/Iface/Make.hs +40/−34
- compiler/GHC/Iface/Recomp.hs +15/−13
- compiler/GHC/Iface/Recomp/Flags.hs +2/−2
- compiler/GHC/Iface/Rename.hs +26/−23
- compiler/GHC/Iface/Tidy.hs +2/−2
- compiler/GHC/Iface/Tidy/StaticPtrTable.hs +2/−2
- compiler/GHC/Iface/UpdateCafInfos.hs +0/−148
- compiler/GHC/Iface/UpdateIdInfos.hs +157/−0
- compiler/GHC/IfaceToCore.hs +83/−57
- compiler/GHC/Llvm.hs +4/−2
- compiler/GHC/Llvm/MetaData.hs +11/−17
- compiler/GHC/Llvm/Ppr.hs +253/−148
- compiler/GHC/Llvm/Types.hs +32/−106
- compiler/GHC/Plugins.hs +1/−1
- compiler/GHC/Rename/Env.hs +147/−64
- compiler/GHC/Rename/Expr.hs +81/−53
- compiler/GHC/Rename/HsType.hs +249/−149
- compiler/GHC/Rename/Module.hs +247/−114
- compiler/GHC/Rename/Names.hs +20/−16
- compiler/GHC/Rename/Splice.hs +3/−3
- compiler/GHC/Rename/Unbound.hs +13/−3
- compiler/GHC/Rename/Utils.hs +5/−5
- compiler/GHC/Runtime/Debugger.hs +3/−3
- compiler/GHC/Runtime/Eval.hs +15/−19
- compiler/GHC/Runtime/Heap/Inspect.hs +56/−76
- compiler/GHC/Runtime/Linker.hs +32/−18
- compiler/GHC/Runtime/Loader.hs +1/−1
- compiler/GHC/Settings/IO.hs +0/−17
- compiler/GHC/Stg/CSE.hs +5/−1
- compiler/GHC/Stg/Lift/Monad.hs +8/−7
- compiler/GHC/Stg/Unarise.hs +9/−9
- compiler/GHC/StgToCmm.hs +25/−2
- compiler/GHC/StgToCmm/Bind.hs +7/−7
- compiler/GHC/StgToCmm/Closure.hs +52/−107
- compiler/GHC/StgToCmm/DataCon.hs +3/−3
- compiler/GHC/StgToCmm/Env.hs +1/−1
- compiler/GHC/StgToCmm/Expr.hs +4/−3
- compiler/GHC/StgToCmm/ExtCode.hs +4/−4
- compiler/GHC/StgToCmm/Foreign.hs +32/−3
- compiler/GHC/StgToCmm/Heap.hs +1/−1
- compiler/GHC/StgToCmm/Layout.hs +3/−3
- compiler/GHC/StgToCmm/Monad.hs +1/−4
- compiler/GHC/StgToCmm/Prim.hs +11/−8
- compiler/GHC/StgToCmm/Prof.hs +9/−9
- compiler/GHC/StgToCmm/Ticky.hs +7/−8
- compiler/GHC/StgToCmm/Utils.hs +17/−14
- compiler/GHC/SysTools.hs +9/−10
- compiler/GHC/SysTools/ExtraObj.hs +5/−3
- compiler/GHC/SysTools/Process.hs +9/−5
- compiler/GHC/Tc/Deriv.hs +8/−9
- compiler/GHC/Tc/Deriv/Functor.hs +1/−1
- compiler/GHC/Tc/Deriv/Generate.hs +579/−273
- compiler/GHC/Tc/Deriv/Generics.hs +4/−3
- compiler/GHC/Tc/Deriv/Infer.hs +2/−2
- compiler/GHC/Tc/Deriv/Utils.hs +9/−4
- compiler/GHC/Tc/Errors.hs +270/−287
- compiler/GHC/Tc/Errors/Hole.hs +18/−18
- compiler/GHC/Tc/Gen/Arrow.hs +25/−23
- compiler/GHC/Tc/Gen/Bind.hs +132/−90
- compiler/GHC/Tc/Gen/Default.hs +2/−2
- compiler/GHC/Tc/Gen/Expr.hs +335/−209
- compiler/GHC/Tc/Gen/Expr.hs-boot +22/−11
- compiler/GHC/Tc/Gen/Foreign.hs +27/−46
- compiler/GHC/Tc/Gen/HsType.hs +3809/−3501
- compiler/GHC/Tc/Gen/Match.hs +138/−131
- compiler/GHC/Tc/Gen/Match.hs-boot +3/−3
- compiler/GHC/Tc/Gen/Pat.hs +176/−126
- compiler/GHC/Tc/Gen/Rule.hs +8/−8
- compiler/GHC/Tc/Gen/Sig.hs +24/−14
- compiler/GHC/Tc/Gen/Splice.hs +35/−33
- compiler/GHC/Tc/Gen/Splice.hs-boot +9/−9
- compiler/GHC/Tc/Instance/Class.hs +13/−15
- compiler/GHC/Tc/Instance/Family.hs +5/−31
- compiler/GHC/Tc/Instance/Typeable.hs +9/−7
- compiler/GHC/Tc/Module.hs +24/−14
- compiler/GHC/Tc/Solver.hs +172/−50
- compiler/GHC/Tc/Solver/Canonical.hs +77/−51
- compiler/GHC/Tc/Solver/Flatten.hs +11/−8
- compiler/GHC/Tc/Solver/Interact.hs +1/−1
- compiler/GHC/Tc/Solver/Monad.hs +5/−5
- compiler/GHC/Tc/TyCl.hs +356/−292
- compiler/GHC/Tc/TyCl/Build.hs +8/−7
- compiler/GHC/Tc/TyCl/Class.hs +4/−3
- compiler/GHC/Tc/TyCl/Instance.hs +53/−35
- compiler/GHC/Tc/TyCl/PatSyn.hs +23/−23
- compiler/GHC/Tc/TyCl/Utils.hs +10/−6
- compiler/GHC/Tc/Utils/Backpack.hs +21/−16
- compiler/GHC/Tc/Utils/Env.hs +50/−18
- compiler/GHC/Tc/Utils/Instantiate.hs +67/−118
- compiler/GHC/Tc/Utils/Monad.hs +68/−22
- compiler/GHC/Tc/Utils/TcMType.hs +53/−54
- compiler/GHC/Tc/Utils/Unify.hs +389/−448
- compiler/GHC/Tc/Utils/Unify.hs-boot +5/−2
- compiler/GHC/Tc/Utils/Zonk.hs +82/−69
- compiler/GHC/Tc/Validity.hs +18/−11
- compiler/GHC/ThToHs.hs +71/−39
- compiler/GHC/Utils/Asm.hs +1/−1
- ghc-lib.cabal +7/−5
- ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl +2/−3
- ghc-lib/stage0/compiler/build/primop-docs.hs-incl +4/−5
- ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl +2/−3
- ghc-lib/stage0/compiler/build/primop-list.hs-incl +2/−3
- ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl +0/−3
- ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl +14/−15
- ghc-lib/stage0/compiler/build/primop-strictness.hs-incl +0/−3
- ghc-lib/stage0/compiler/build/primop-tag.hs-incl +1208/−1209
- ghc-lib/stage0/lib/ghcversion.h +5/−2
- ghc-lib/stage0/lib/settings +1/−1
- libraries/ghc-boot/GHC/Settings/Platform.hs +2/−0
- libraries/ghci/GHCi/InfoTable.hsc +1/−1
- libraries/ghci/GHCi/Run.hs +2/−2
compiler/GHC.hs view
@@ -197,7 +197,7 @@ -- ** Data constructors DataCon, dataConType, dataConTyCon, dataConFieldLabels,- dataConIsInfix, isVanillaDataCon, dataConUserType,+ dataConIsInfix, isVanillaDataCon, dataConWrapperType, dataConSrcBangs, StrictnessMark(..), isMarkedStrict, @@ -545,7 +545,7 @@ checkBrokenTablesNextToCode' dflags | not (isARM arch) = return False | WayDyn `S.notMember` ways dflags = return False- | not (tablesNextToCode dflags) = return False+ | not tablesNextToCode = return False | otherwise = do linkerInfo <- liftIO $ getLinkerInfo dflags case linkerInfo of@@ -553,6 +553,7 @@ _ -> return False where platform = targetPlatform dflags arch = platformArch platform+ tablesNextToCode = platformTablesNextToCode platform -- %************************************************************************@@ -594,20 +595,22 @@ -- flags. If you are not doing linking or doing static linking, you -- can ignore the list of packages returned. ---setSessionDynFlags :: GhcMonad m => DynFlags -> m [UnitId]+setSessionDynFlags :: GhcMonad m => DynFlags -> m () setSessionDynFlags dflags = do dflags' <- checkNewDynFlags dflags- (dflags''', preload) <- liftIO $ initPackages dflags'+ dflags''' <- liftIO $ initUnits dflags' -- Interpreter interp <- if gopt Opt_ExternalInterpreter dflags then do let prog = pgm_i dflags ++ flavour+ profiled = ways dflags `hasWay` WayProf+ dynamic = ways dflags `hasWay` WayDyn flavour- | WayProf `S.member` ways dflags = "-prof"- | WayDyn `S.member` ways dflags = "-dyn"- | otherwise = ""+ | profiled = "-prof" -- FIXME: can't we have both?+ | dynamic = "-dyn"+ | otherwise = "" msg = text "Starting " <> text prog tr <- if verbosity dflags >= 3 then return (logInfo dflags $ withPprStyle defaultDumpStyle msg)@@ -616,8 +619,8 @@ conf = IServConfig { iservConfProgram = prog , iservConfOpts = getOpts dflags opt_i- , iservConfProfiled = gopt Opt_SccProfilingOn dflags- , iservConfDynamic = WayDyn `S.member` ways dflags+ , iservConfProfiled = profiled+ , iservConfDynamic = dynamic , iservConfHook = createIservProcessHook (hooks dflags) , iservConfTrace = tr }@@ -637,12 +640,14 @@ -- already one set up } invalidateModSummaryCache- return preload -- | 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 [UnitId]+--+-- Returns a boolean indicating if preload units have changed and need to be+-- reloaded.+setProgramDynFlags :: GhcMonad m => DynFlags -> m Bool setProgramDynFlags dflags = setProgramDynFlags_ True dflags -- | Set the action taken when the compiler produces a message. This@@ -654,17 +659,17 @@ void $ setProgramDynFlags_ False $ dflags' { log_action = action } -setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m [UnitId]+setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m Bool setProgramDynFlags_ invalidate_needed dflags = do dflags' <- checkNewDynFlags dflags dflags_prev <- getProgramDynFlags- (dflags'', preload) <-- if (packageFlagsChanged dflags_prev dflags')- then liftIO $ initPackages dflags'- else return (dflags', [])+ let changed = packageFlagsChanged dflags_prev dflags'+ dflags'' <- if changed+ then liftIO $ initUnits dflags'+ else return dflags' modifySession $ \h -> h{ hsc_dflags = dflags'' } when invalidate_needed $ invalidateModSummaryCache- return preload+ return changed -- When changing the DynFlags, we want the changes to apply to future@@ -699,7 +704,7 @@ -- | Set the 'DynFlags' used to evaluate interactive expressions. -- Note: this cannot be used for changes to packages. Use -- 'setSessionDynFlags', or 'setProgramDynFlags' and then copy the--- 'pkgState' into the interactive @DynFlags@.+-- 'unitState' into the interactive @DynFlags@. setInteractiveDynFlags :: GhcMonad m => DynFlags -> m () setInteractiveDynFlags dflags = do dflags' <- checkNewDynFlags dflags@@ -936,7 +941,7 @@ mg <- liftM hsc_mod_graph getSession let mods_by_name = [ ms | ms <- mgModSummaries mg , ms_mod_name ms == mod- , not (isBootSummary ms) ]+ , isBootSummary ms == NotBoot ] case mods_by_name of [] -> do dflags <- getDynFlags liftIO $ throwIO $ mkApiErr dflags (text "Module not part of module graph")@@ -1007,7 +1012,7 @@ -- -- A module must be loaded before dependent modules can be typechecked. This -- always includes generating a 'ModIface' and, depending on the--- 'DynFlags.hscTarget', may also include code generation.+-- @DynFlags@\'s 'GHC.Driver.Session.hscTarget', may also include code generation. -- -- This function will always cause recompilation and will always overwrite -- previous compilation results (potentially files on disk).@@ -1142,7 +1147,7 @@ getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary getModuleGraph = liftM hsc_mod_graph getSession --- | Return @True@ <==> module is loaded.+-- | Return @True@ \<==> module is loaded. isLoaded :: GhcMonad m => ModuleName -> m Bool isLoaded m = withSession $ \hsc_env -> return $! isJust (lookupHpt (hsc_HPT hsc_env) m)@@ -1355,7 +1360,7 @@ -> m [Module] packageDbModules only_exposed = do dflags <- getSessionDynFlags- let pkgs = eltsUFM (unitInfoMap (pkgState dflags))+ let pkgs = eltsUFM (unitInfoMap (unitState dflags)) return $ [ mkModule pid modname | p <- pkgs@@ -1489,7 +1494,7 @@ findModule mod_name maybe_pkg = withSession $ \hsc_env -> do let dflags = hsc_dflags hsc_env- this_pkg = thisPackage dflags+ this_pkg = homeUnit dflags -- case maybe_pkg of Just pkg | fsToUnit pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do@@ -1677,9 +1682,11 @@ where -- Loading environments (by name or by location) + platformArchOs = platformMini (targetPlatform dflags)+ namedEnvPath :: String -> MaybeT IO FilePath namedEnvPath name = do- appdir <- versionedAppDir dflags+ appdir <- versionedAppDir (programName dflags) platformArchOs return $ appdir </> "environments" </> name probeEnvName :: String -> MaybeT IO FilePath@@ -1716,7 +1723,7 @@ -- e.g. .ghc.environment.x86_64-linux-7.6.3 localEnvFileName :: FilePath- localEnvFileName = ".ghc.environment" <.> versionedFilePath dflags+ localEnvFileName = ".ghc.environment" <.> versionedFilePath platformArchOs -- Search for an env file, starting in the current dir and looking upwards. -- Fail if we get to the users home dir or the filesystem root. That is,
compiler/GHC/Builtin/Names/TH.hs view
@@ -30,6 +30,7 @@ returnQName, bindQName, sequenceQName, newNameName, liftName, liftTypedName, mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName, mkNameSName,+ mkModNameName, liftStringName, unTypeName, unTypeQName,@@ -98,7 +99,7 @@ -- Type forallTName, forallVisTName, varTName, conTName, infixTName, appTName, appKindTName, equalityTName, tupleTName, unboxedTupleTName,- unboxedSumTName, arrowTName, listTName, sigTName, litTName,+ unboxedSumTName, arrowTName, mulArrowTName, listTName, sigTName, litTName, promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName, wildCardTName, implicitParamTName, -- TyLit@@ -160,6 +161,7 @@ ruleBndrTyConName, tySynEqnTyConName, roleTyConName, tExpTyConName, injAnnTyConName, kindTyConName, overlapTyConName, derivClauseTyConName, derivStrategyTyConName,+ modNameTyConName, -- Quasiquoting quoteDecName, quoteTypeName, quoteExpName, quotePatName]@@ -170,7 +172,7 @@ qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote") mkTHModule :: FastString -> Module-mkTHModule m = mkModule thUnitId (mkModuleNameFS m)+mkTHModule m = mkModule thUnit (mkModuleNameFS m) libFun, libTc, thFun, thTc, thCls, thCon, qqFun :: FastString -> Unique -> Name libFun = mk_known_key_name varName thLib@@ -191,7 +193,8 @@ qTyConName, nameTyConName, fieldExpTyConName, patTyConName, fieldPatTyConName, expTyConName, decTyConName, typeTyConName, matchTyConName, clauseTyConName, funDepTyConName, predTyConName,- tExpTyConName, injAnnTyConName, overlapTyConName, decsTyConName :: Name+ tExpTyConName, injAnnTyConName, overlapTyConName, decsTyConName,+ modNameTyConName :: Name qTyConName = thTc (fsLit "Q") qTyConKey nameTyConName = thTc (fsLit "Name") nameTyConKey fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey@@ -208,11 +211,12 @@ tExpTyConName = thTc (fsLit "TExp") tExpTyConKey injAnnTyConName = thTc (fsLit "InjectivityAnn") injAnnTyConKey overlapTyConName = thTc (fsLit "Overlap") overlapTyConKey+modNameTyConName = thTc (fsLit "ModName") modNameTyConKey returnQName, bindQName, sequenceQName, newNameName, liftName, mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeQName,- unsafeTExpCoerceName, liftTypedName :: Name+ unsafeTExpCoerceName, liftTypedName, mkModNameName :: Name returnQName = thFun (fsLit "returnQ") returnQIdKey bindQName = thFun (fsLit "bindQ") bindQIdKey sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey@@ -225,6 +229,7 @@ mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey mkNameSName = thFun (fsLit "mkNameS") mkNameSIdKey+mkModNameName = thFun (fsLit "mkModName") mkModNameIdKey unTypeName = thFun (fsLit "unType") unTypeIdKey unTypeQName = thFun (fsLit "unTypeQ") unTypeQIdKey unsafeTExpCoerceName = thFun (fsLit "unsafeTExpCoerce") unsafeTExpCoerceIdKey@@ -438,8 +443,8 @@ -- data Type = ... forallTName, forallVisTName, varTName, conTName, infixTName, tupleTName,- unboxedTupleTName, unboxedSumTName, arrowTName, listTName, appTName,- appKindTName, sigTName, equalityTName, litTName, promotedTName,+ unboxedTupleTName, unboxedSumTName, arrowTName, mulArrowTName, listTName,+ appTName, appKindTName, sigTName, equalityTName, litTName, promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName, wildCardTName, implicitParamTName :: Name forallTName = libFun (fsLit "forallT") forallTIdKey@@ -450,6 +455,7 @@ unboxedTupleTName = libFun (fsLit "unboxedTupleT") unboxedTupleTIdKey unboxedSumTName = libFun (fsLit "unboxedSumT") unboxedSumTIdKey arrowTName = libFun (fsLit "arrowT") arrowTIdKey+mulArrowTName = libFun (fsLit "mulArrowT") mulArrowTIdKey listTName = libFun (fsLit "listT") listTIdKey appTName = libFun (fsLit "appT") appTIdKey appKindTName = libFun (fsLit "appKindT") appKindTIdKey@@ -648,8 +654,8 @@ funDepTyConKey, predTyConKey, predQTyConKey, decsQTyConKey, ruleBndrTyConKey, tySynEqnTyConKey, roleTyConKey, tExpTyConKey, injAnnTyConKey, kindTyConKey,- overlapTyConKey, derivClauseTyConKey, derivStrategyTyConKey, decsTyConKey- :: Unique+ overlapTyConKey, derivClauseTyConKey, derivStrategyTyConKey, decsTyConKey,+ modNameTyConKey :: Unique expTyConKey = mkPreludeTyConUnique 200 matchTyConKey = mkPreludeTyConUnique 201 clauseTyConKey = mkPreludeTyConUnique 202@@ -683,6 +689,7 @@ derivClauseTyConKey = mkPreludeTyConUnique 234 derivStrategyTyConKey = mkPreludeTyConUnique 235 decsTyConKey = mkPreludeTyConUnique 236+modNameTyConKey = mkPreludeTyConUnique 238 {- ********************************************************************* * *@@ -736,7 +743,7 @@ returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey, mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey, mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeQIdKey,- unsafeTExpCoerceIdKey, liftTypedIdKey :: Unique+ unsafeTExpCoerceIdKey, liftTypedIdKey, mkModNameIdKey :: Unique returnQIdKey = mkPreludeMiscIdUnique 200 bindQIdKey = mkPreludeMiscIdUnique 201 sequenceQIdKey = mkPreludeMiscIdUnique 202@@ -752,6 +759,7 @@ unTypeQIdKey = mkPreludeMiscIdUnique 212 unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 213 liftTypedIdKey = mkPreludeMiscIdUnique 214+mkModNameIdKey = mkPreludeMiscIdUnique 215 -- data Lit = ...@@ -1045,6 +1053,10 @@ -- data FunDep = ... funDepIdKey :: Unique funDepIdKey = mkPreludeMiscIdUnique 445++-- mulArrow+mulArrowTIdKey :: Unique+mulArrowTIdKey = mkPreludeMiscIdUnique 446 -- data TySynEqn = ... tySynEqnIdKey :: Unique
compiler/GHC/Builtin/Utils.hs view
@@ -111,7 +111,7 @@ -- | 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)+-- Note [Known-key names] in "GHC.Builtin.Names") knownKeyNames :: [Name] knownKeyNames | debugIsOn
compiler/GHC/ByteCode/Asm.hs view
@@ -453,7 +453,7 @@ literal (LitChar c) = int (ord c) literal (LitString bs) = lit [BCONPtrStr bs] -- LitString requires a zero-terminator when emitted- literal (LitNumber nt i _) = case nt of+ literal (LitNumber nt i) = case nt of LitNumInt -> int (fromIntegral i) LitNumWord -> int (fromIntegral i) LitNumInt64 -> int64 (fromIntegral i)
compiler/GHC/ByteCode/InfoTable.hs view
@@ -11,6 +11,7 @@ import GHC.Prelude +import GHC.Platform import GHC.ByteCode.Types import GHC.Runtime.Interpreter import GHC.Driver.Session@@ -19,6 +20,7 @@ import GHC.Types.Name.Env import GHC.Core.DataCon ( DataCon, dataConRepArgTys, dataConIdentity ) import GHC.Core.TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )+import GHC.Core.Multiplicity ( scaledThing ) import GHC.Types.RepType import GHC.StgToCmm.Layout ( mkVirtConstrSizes ) import GHC.StgToCmm.Closure ( tagForCon, NonVoid (..) )@@ -58,7 +60,7 @@ mk_itbl dcon conNo = do let rep_args = [ NonVoid prim_rep | arg <- dataConRepArgTys dcon- , prim_rep <- typePrimRep arg ]+ , prim_rep <- typePrimRep (scaledThing arg) ] (tot_wds, ptr_wds) = mkVirtConstrSizes dflags rep_args@@ -71,7 +73,8 @@ descr = dataConIdentity dcon - tables_next_to_code = tablesNextToCode dflags+ platform = targetPlatform dflags+ tables_next_to_code = platformTablesNextToCode platform r <- iservCmd hsc_env (MkConInfoTable tables_next_to_code ptrs' nptrs_really conNo (tagForCon dflags dcon) descr)
compiler/GHC/ByteCode/Linker.hs view
@@ -169,7 +169,7 @@ occPart = encodeZ (occNameFS (nameOccName n)) label = concat- [ if pkgKey == mainUnitId then "" else packagePart ++ "_"+ [ if pkgKey == mainUnit then "" else packagePart ++ "_" , modulePart , '_':occPart , '_':suffix
compiler/GHC/Cmm/CallConv.hs view
@@ -206,9 +206,13 @@ | passFloatArgsInXmm (targetPlatform dflags) = map ($VGcPtr) (realVanillaRegs dflags) ++ realLongRegs dflags ++- map XmmReg (realXmmRegNos dflags)- | otherwise = map ($VGcPtr) (realVanillaRegs dflags) ++- realFloatRegs dflags ++- realDoubleRegs dflags ++- realLongRegs dflags ++- map XmmReg (realXmmRegNos dflags)+ realDoubleRegs dflags -- we only need to save the low Double part of XMM registers.+ -- Moreover, the NCG can't load/store full XMM+ -- registers for now...++ | otherwise+ = map ($VGcPtr) (realVanillaRegs dflags) +++ realFloatRegs dflags +++ realDoubleRegs dflags +++ realLongRegs dflags+ -- we don't save XMM registers if they are not used for parameter passing
compiler/GHC/Cmm/DebugBlock.hs view
@@ -395,7 +395,7 @@ (by the Dwarf module) and emitted in the final object. See also:- Note [Unwinding information in the NCG] in AsmCodeGen,+ Note [Unwinding information in the NCG] in "GHC.CmmToAsm", Note [Unwind pseudo-instruction in Cmm], Note [Debugging DWARF unwinding info]. @@ -460,7 +460,7 @@ Keep in mind that the current release of GDB has an instruction pointer handling heuristic that works well for C-like languages, but doesn't always work for-Haskell. See Note [Info Offset] in Dwarf.Types for more details.+Haskell. See Note [Info Offset] in "GHC.CmmToAsm.Dwarf.Types" for more details. Note [Unwind pseudo-instruction in Cmm] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Cmm/Info.hs view
@@ -124,7 +124,7 @@ -- in the non-tables-next-to-code case, procs can have at most a -- single info table associated with the entry label of the proc. --- | not (tablesNextToCode dflags)+ | not (platformTablesNextToCode (targetPlatform dflags)) = case topInfoTable proc of -- must be at most one -- no info table Nothing ->@@ -134,8 +134,8 @@ (top_decls, (std_info, extra_bits)) <- mkInfoTableContents dflags info Nothing let- rel_std_info = map (makeRelativeRefTo dflags info_lbl) std_info- rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits+ rel_std_info = map (makeRelativeRefTo platform info_lbl) std_info+ rel_extra_bits = map (makeRelativeRefTo platform info_lbl) extra_bits -- -- Separately emit info table (with the function entry -- point as first entry) and the entry code@@ -159,13 +159,14 @@ [CmmProc (mapFromList raw_infos) entry_lbl live blocks]) where+ platform = targetPlatform dflags do_one_info (lbl,itbl) = do (top_decls, (std_info, extra_bits)) <- mkInfoTableContents dflags itbl Nothing let info_lbl = cit_lbl itbl- rel_std_info = map (makeRelativeRefTo dflags info_lbl) std_info- rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits+ rel_std_info = map (makeRelativeRefTo platform info_lbl) std_info+ rel_extra_bits = map (makeRelativeRefTo platform info_lbl) extra_bits -- return (top_decls, (lbl, CmmStaticsRaw info_lbl $ map CmmStaticLit $ reverse rel_extra_bits ++ rel_std_info))@@ -195,7 +196,7 @@ | StackRep frame <- smrep = do { (prof_lits, prof_data) <- mkProfLits platform prof- ; let (srt_label, srt_bitmap) = mkSRTLit dflags info_lbl srt+ ; let (srt_label, srt_bitmap) = mkSRTLit platform info_lbl srt ; (liveness_lit, liveness_data) <- mkLivenessBits dflags frame ; let std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit@@ -208,7 +209,7 @@ | HeapRep _ ptrs nonptrs closure_type <- smrep = do { let layout = packIntsCLit platform ptrs nonptrs ; (prof_lits, prof_data) <- mkProfLits platform prof- ; let (srt_label, srt_bitmap) = mkSRTLit dflags info_lbl srt+ ; let (srt_label, srt_bitmap) = mkSRTLit platform info_lbl srt ; (mb_srt_field, mb_layout, extra_bits, ct_data) <- mk_pieces closure_type srt_label ; let std_info = mkStdInfoTable dflags prof_lits@@ -246,7 +247,7 @@ ; let fun_type | null liveness_data = aRG_GEN | otherwise = aRG_GEN_BIG extra_bits = [ packIntsCLit platform fun_type arity ]- ++ (if inlineSRT dflags then [] else [ srt_lit ])+ ++ (if inlineSRT platform then [] else [ srt_lit ]) ++ [ liveness_lit, slow_entry ] ; return (Nothing, Nothing, extra_bits, liveness_data) } where@@ -265,25 +266,25 @@ (toStgHalfWord platform (fromIntegral b)) -mkSRTLit :: DynFlags+mkSRTLit :: Platform -> CLabel -> Maybe CLabel -> ([CmmLit], -- srt_label, if any CmmLit) -- srt_bitmap-mkSRTLit dflags info_lbl (Just lbl)- | inlineSRT dflags- = ([], CmmLabelDiffOff lbl info_lbl 0 (halfWordWidth (targetPlatform dflags)))-mkSRTLit dflags _ Nothing = ([], CmmInt 0 (halfWordWidth (targetPlatform dflags)))-mkSRTLit dflags _ (Just lbl) = ([CmmLabel lbl], CmmInt 1 (halfWordWidth (targetPlatform dflags)))+mkSRTLit platform info_lbl (Just lbl)+ | inlineSRT platform+ = ([], CmmLabelDiffOff lbl info_lbl 0 (halfWordWidth platform))+mkSRTLit platform _ Nothing = ([], CmmInt 0 (halfWordWidth platform))+mkSRTLit platform _ (Just lbl) = ([CmmLabel lbl], CmmInt 1 (halfWordWidth platform)) -- | Is the SRT offset field inline in the info table on this platform? -- -- See the section "Referring to an SRT from the info table" in--- Note [SRTs] in GHC.Cmm.Info.Build-inlineSRT :: DynFlags -> Bool-inlineSRT dflags = platformArch (targetPlatform dflags) == ArchX86_64- && tablesNextToCode dflags+-- Note [SRTs] in "GHC.Cmm.Info.Build"+inlineSRT :: Platform -> Bool+inlineSRT platform = platformArch platform == ArchX86_64+ && platformTablesNextToCode platform ------------------------------------------------------------------------- --@@ -311,16 +312,14 @@ -- Note that this is done even when the -fPIC flag is not specified, -- as we want to keep binary compatibility between PIC and non-PIC. -makeRelativeRefTo :: DynFlags -> CLabel -> CmmLit -> CmmLit--makeRelativeRefTo dflags info_lbl (CmmLabel lbl)- | tablesNextToCode dflags- = CmmLabelDiffOff lbl info_lbl 0 (wordWidth (targetPlatform dflags))-makeRelativeRefTo dflags info_lbl (CmmLabelOff lbl off)- | tablesNextToCode dflags- = CmmLabelDiffOff lbl info_lbl off (wordWidth (targetPlatform dflags))-makeRelativeRefTo _ _ lit = lit-+makeRelativeRefTo :: Platform -> CLabel -> CmmLit -> CmmLit+makeRelativeRefTo platform info_lbl lit+ = if platformTablesNextToCode platform+ then case lit of+ CmmLabel lbl -> CmmLabelDiffOff lbl info_lbl 0 (wordWidth platform)+ CmmLabelOff lbl off -> CmmLabelDiffOff lbl info_lbl off (wordWidth platform)+ _ -> lit+ else lit ------------------------------------------------------------------------- --@@ -406,7 +405,7 @@ where platform = targetPlatform dflags prof_info- | gopt Opt_SccProfilingOn dflags = [type_descr, closure_descr]+ | sccProfilingEnabled dflags = [type_descr, closure_descr] | otherwise = [] tag = CmmInt (fromIntegral cl_type) (halfWordWidth platform)@@ -457,12 +456,13 @@ closureInfoPtr dflags e = CmmLoad (wordAligned dflags e) (bWord (targetPlatform dflags)) -entryCode :: DynFlags -> CmmExpr -> CmmExpr--- Takes an info pointer (the first word of a closure)--- and returns its entry code-entryCode dflags e- | tablesNextToCode dflags = e- | otherwise = CmmLoad e (bWord (targetPlatform dflags))+-- | Takes an info pointer (the first word of a closure) and returns its entry+-- code+entryCode :: Platform -> CmmExpr -> CmmExpr+entryCode platform e =+ if platformTablesNextToCode platform+ then e+ else CmmLoad e (bWord platform) getConstrTag :: DynFlags -> CmmExpr -> CmmExpr -- Takes a closure pointer, and return the *zero-indexed*@@ -489,8 +489,8 @@ -- and returns a pointer to the first word of the standard-form -- info table, excluding the entry-code word (if present) infoTable dflags info_ptr- | tablesNextToCode dflags = cmmOffsetB platform info_ptr (- stdInfoTableSizeB dflags)- | otherwise = cmmOffsetW platform info_ptr 1 -- Past the entry code pointer+ | platformTablesNextToCode platform = cmmOffsetB platform info_ptr (- stdInfoTableSizeB dflags)+ | otherwise = cmmOffsetW platform info_ptr 1 -- Past the entry code pointer where platform = targetPlatform dflags infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr@@ -527,7 +527,7 @@ -- and returns a pointer to the first word of the StgFunInfoExtra struct -- in the info table. funInfoTable dflags info_ptr- | tablesNextToCode dflags+ | platformTablesNextToCode platform = cmmOffsetB platform info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags) | otherwise = cmmOffsetW platform info_ptr (1 + stdInfoTableSizeW dflags)@@ -543,12 +543,13 @@ platform = targetPlatform dflags fun_info = funInfoTable dflags iptr rep = cmmBits (widthFromBytes rep_bytes)+ tablesNextToCode = platformTablesNextToCode platform (rep_bytes, offset)- | tablesNextToCode dflags = ( pc_REP_StgFunInfoExtraRev_arity pc- , oFFSET_StgFunInfoExtraRev_arity dflags )- | otherwise = ( pc_REP_StgFunInfoExtraFwd_arity pc- , oFFSET_StgFunInfoExtraFwd_arity dflags )+ | tablesNextToCode = ( pc_REP_StgFunInfoExtraRev_arity pc+ , oFFSET_StgFunInfoExtraRev_arity dflags )+ | otherwise = ( pc_REP_StgFunInfoExtraFwd_arity pc+ , oFFSET_StgFunInfoExtraFwd_arity dflags ) pc = platformConstants dflags @@ -564,7 +565,7 @@ -- It must vary in sync with mkStdInfoTable stdInfoTableSizeW dflags = fixedInfoTableSizeW- + if gopt Opt_SccProfilingOn dflags+ + if sccProfilingEnabled dflags then profInfoTableSizeW else 0
compiler/GHC/Cmm/Info/Build.hs view
@@ -1027,7 +1027,7 @@ -- "Referring to an SRT from the info table" of Note [SRTs]). However, -- 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.+ -- Consequently we build a singleton SRT in this case. not (labelDynamic config this_mod lbl) -- MachO relocations can't express offsets between compilation units at
compiler/GHC/Cmm/LayoutStack.hs view
@@ -1164,7 +1164,7 @@ -- received an exception during the call, then the stack might be -- different. Hence we continue by jumping to the top stack frame, -- not by jumping to succ.- jump = CmmCall { cml_target = entryCode dflags $+ jump = CmmCall { cml_target = entryCode platform $ CmmLoad spExpr (bWord platform) , cml_cont = Just succ , cml_args_regs = regs
compiler/GHC/Cmm/Monad.hs view
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- A Parser monad with access to the 'DynFlags'. ----- The 'P' monad only has access to the subset of of 'DynFlags'+-- The 'P' monad only has access to the subset of 'DynFlags' -- required for parsing Haskell. -- The parser for C-- requires access to a lot more of the 'DynFlags',
compiler/GHC/Cmm/Parser.y view
@@ -377,7 +377,7 @@ | cmmdata { $1 } | decl { $1 } | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'- {% liftP . withThisPackage $ \pkg ->+ {% liftP . withHomeUnitId $ \pkg -> do lits <- sequence $6; staticClosure pkg $3 $5 (map getLit lits) } @@ -398,8 +398,8 @@ data_label :: { CmmParse CLabel } : NAME ':'- {% liftP . withThisPackage $ \pkg ->- return (mkCmmDataLabel pkg $1) }+ {% liftP . withHomeUnitId $ \pkg ->+ return (mkCmmDataLabel pkg (NeedExternDecl False) $1) } statics :: { [CmmParse [CmmStatic]] } : {- empty -} { [] }@@ -455,14 +455,14 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } : NAME- {% liftP . withThisPackage $ \pkg ->+ {% liftP . withHomeUnitId $ \pkg -> do newFunctionName $1 pkg return (mkCmmCodeLabel pkg $1, Nothing, []) } | 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' -- ptrs, nptrs, closure type, description, type- {% liftP . withThisPackage $ \pkg ->+ {% liftP . withHomeUnitId $ \pkg -> do dflags <- getDynFlags let prof = profilingInfo dflags $11 $13 rep = mkRTSRep (fromIntegral $9) $@@ -478,7 +478,7 @@ | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')' -- ptrs, nptrs, closure type, description, type, fun type- {% liftP . withThisPackage $ \pkg ->+ {% liftP . withHomeUnitId $ \pkg -> do dflags <- getDynFlags let prof = profilingInfo dflags $11 $13 ty = Fun 0 (ArgSpec (fromIntegral $15))@@ -496,7 +496,7 @@ | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' -- ptrs, nptrs, tag, closure type, description, type- {% liftP . withThisPackage $ \pkg ->+ {% liftP . withHomeUnitId $ \pkg -> do dflags <- getDynFlags let prof = profilingInfo dflags $13 $15 ty = Constr (fromIntegral $9) -- Tag@@ -515,7 +515,7 @@ | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')' -- selector, closure type, description, type- {% liftP . withThisPackage $ \pkg ->+ {% liftP . withHomeUnitId $ \pkg -> do dflags <- getDynFlags let prof = profilingInfo dflags $9 $11 ty = ThunkSelector (fromIntegral $5)@@ -529,7 +529,7 @@ | 'INFO_TABLE_RET' '(' NAME ',' INT ')' -- closure type (no live regs)- {% liftP . withThisPackage $ \pkg ->+ {% liftP . withHomeUnitId $ \pkg -> do let prof = NoProfilingInfo rep = mkRTSRep (fromIntegral $5) $ mkStackRep [] return (mkCmmRetLabel pkg $3,@@ -540,7 +540,7 @@ | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')' -- closure type, live regs- {% liftP . withThisPackage $ \pkg ->+ {% liftP . withHomeUnitId $ \pkg -> do dflags <- getDynFlags let platform = targetPlatform dflags live <- sequence $7@@ -583,9 +583,9 @@ | 'CLOSURE' NAME { ($2, mkForeignLabel $2 Nothing ForeignLabelInExternalPackage IsData) } - -- A label imported with an explicit packageId.+ -- A label imported with an explicit UnitId. | STRING NAME- { ($2, mkCmmCodeLabel (fsToUnit (mkFastString $1)) $2) }+ { ($2, mkCmmCodeLabel (UnitId (mkFastString $1)) $2) } names :: { [FastString] }@@ -909,17 +909,18 @@ exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr) exprMacros dflags = listToUFM [- ( fsLit "ENTRY_CODE", \ [x] -> entryCode dflags x ),+ ( fsLit "ENTRY_CODE", \ [x] -> entryCode platform x ), ( fsLit "INFO_PTR", \ [x] -> closureInfoPtr dflags x ), ( fsLit "STD_INFO", \ [x] -> infoTable dflags x ), ( fsLit "FUN_INFO", \ [x] -> funInfoTable dflags x ),- ( fsLit "GET_ENTRY", \ [x] -> entryCode dflags (closureInfoPtr dflags x) ),+ ( fsLit "GET_ENTRY", \ [x] -> entryCode platform (closureInfoPtr dflags x) ), ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr dflags x) ), ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr dflags x) ), ( fsLit "INFO_TYPE", \ [x] -> infoTableClosureType dflags x ), ( fsLit "INFO_PTRS", \ [x] -> infoTablePtrs dflags x ), ( fsLit "INFO_NPTRS", \ [x] -> infoTableNonPtrs dflags x ) ]+ where platform = targetPlatform dflags -- we understand a subset of C-- primitives: machOps = listToUFM $@@ -1022,8 +1023,13 @@ ( "cmpxchg8", (MO_Cmpxchg W8,)), ( "cmpxchg16", (MO_Cmpxchg W16,)), ( "cmpxchg32", (MO_Cmpxchg W32,)),- ( "cmpxchg64", (MO_Cmpxchg W64,))+ ( "cmpxchg64", (MO_Cmpxchg W64,)), + ( "xchg8", (MO_Xchg W8,)),+ ( "xchg16", (MO_Xchg W16,)),+ ( "xchg32", (MO_Xchg W32,)),+ ( "xchg64", (MO_Xchg W64,))+ -- ToDo: the rest, maybe -- edit: which rest? -- also: how do we tell CMM Lint how to type check callish macops?@@ -1109,6 +1115,9 @@ ( fsLit "LOAD_THREAD_STATE", \[] -> emitLoadThreadState ), ( fsLit "SAVE_THREAD_STATE", \[] -> emitSaveThreadState ), + ( fsLit "SAVE_REGS", \[] -> emitSaveRegs ),+ ( fsLit "RESTORE_REGS", \[] -> emitRestoreRegs ),+ ( fsLit "LDV_ENTER", \[e] -> ldvEnter e ), ( fsLit "LDV_RECORD_CREATE", \[e] -> ldvRecordCreate e ), @@ -1159,15 +1168,15 @@ withUpdFrameOff frame body profilingInfo dflags desc_str ty_str- = if not (gopt Opt_SccProfilingOn dflags)+ = if not (sccProfilingEnabled dflags) then NoProfilingInfo else ProfilingInfo (BS8.pack desc_str) (BS8.pack ty_str) -staticClosure :: Unit -> FastString -> FastString -> [CmmLit] -> CmmParse ()+staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse () staticClosure pkg cl_label info payload = do dflags <- getDynFlags let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []- code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits+ code $ emitDataLits (mkCmmDataLabel pkg (NeedExternDecl True) cl_label) lits foreignCall :: String@@ -1208,7 +1217,7 @@ mkReturnSimple :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph mkReturnSimple dflags actuals updfr_off = mkReturn dflags e actuals updfr_off- where e = entryCode dflags (CmmLoad (CmmStackSlot Old updfr_off)+ where e = entryCode platform (CmmLoad (CmmStackSlot Old updfr_off) (gcWord platform)) platform = targetPlatform dflags
compiler/GHC/Cmm/Pipeline.hs view
@@ -172,7 +172,7 @@ -- label to put on info tables for basic blocks that are not -- the entry point. splitting_proc_points = hscTarget dflags /= HscAsm- || not (tablesNextToCode dflags)+ || not (platformTablesNextToCode platform) || -- Note [inconsistent-pic-reg] usingInconsistentPicReg usingInconsistentPicReg
compiler/GHC/Cmm/Ppr/Expr.hs view
@@ -253,7 +253,7 @@ pprArea Old = text "old" pprArea (Young id) = hcat [ text "young<", ppr id, text ">" ] --- needs to be kept in syn with CmmExpr.hs.GlobalReg+-- needs to be kept in syn with 'GHC.Cmm.Expr.GlobalReg' -- pprGlobalReg :: GlobalReg -> SDoc pprGlobalReg gr
compiler/GHC/Cmm/ProcPoint.hs view
@@ -315,10 +315,12 @@ -- when jumping to a PP that has an info table, if -- tablesNextToCode is off we must jump to the entry -- label instead.+ platform = targetPlatform dflags+ tablesNextToCode = platformTablesNextToCode platform jump_label (Just info_lbl) _- | tablesNextToCode dflags = info_lbl- | otherwise = toEntryLbl info_lbl- jump_label Nothing block_lbl = block_lbl+ | tablesNextToCode = info_lbl+ | otherwise = toEntryLbl info_lbl+ jump_label Nothing block_lbl = block_lbl add_if_pp id rst = case mapLookup id procLabels of Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst
compiler/GHC/CmmToAsm.hs view
@@ -289,7 +289,7 @@ , ngs_dwarfFiles :: !DwarfFiles , ngs_unwinds :: !(LabelMap [UnwindPoint]) -- ^ see Note [Unwinding information in the NCG]- -- and Note [What is this unwinding business?] in Debug.+ -- and Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock". } {-@@ -314,7 +314,7 @@ procedure, containing a list of unwinding points (e.g. a label and an associated unwinding table). -See also Note [What is this unwinding business?] in Debug.+See also Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock". -} nativeCodeGen' :: (Outputable statics, Outputable instr,Outputable jumpDest,@@ -432,7 +432,7 @@ dbgMap us cmms ngs 0 -- Link native code information into debug blocks- -- See Note [What is this unwinding business?] in Debug.+ -- See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock". let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs unless (null ldbgs) $ dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos" FormatText
compiler/GHC/CmmToAsm/BlockLayout.hs view
@@ -545,7 +545,7 @@ -- buildNext builds up chains from edges one at a time. -- We keep a map from the ends of chains to the chains.- -- This we we can easily check if an block should be appended to an+ -- This way we can easily check if an block should be appended to an -- existing chain! -- We store them using STRefs so we don't have to rebuild the spine of both -- maps every time we update a chain.
compiler/GHC/CmmToAsm/CFG.hs view
@@ -107,7 +107,7 @@ type EdgeInfoMap edgeInfo = LabelMap (LabelMap edgeInfo) -- | A control flow graph where edges have been annotated with a weight.--- Implemented as IntMap (IntMap <edgeData>)+-- Implemented as IntMap (IntMap \<edgeData>) -- We must uphold the invariant that for each edge A -> B we must have: -- A entry B in the outer map. -- A entry B in the map we get when looking up A.@@ -148,7 +148,7 @@ -- | Can we trace back a edge to a specific Cmm Node -- or has it been introduced during assembly codegen. We use this to maintain -- some information which would otherwise be lost during the--- Cmm <-> asm transition.+-- Cmm \<-> asm transition. -- See also Note [Inverting Conditional Branches] data TransitionSource = CmmSource { trans_cmmNode :: (CmmNode O C)@@ -251,7 +251,7 @@ See Note [What is shortcutting] in the control flow optimization code (GHC.Cmm.ContFlowOpt) for a slightly more in depth explanation on shortcutting. -In the native backend we shortcut jumps at the assembly level. (AsmCodeGen.hs)+In the native backend we shortcut jumps at the assembly level. ("GHC.CmmToAsm") This means we remove blocks containing only one jump from the code and instead redirecting all jumps targeting this block to the deleted blocks jump target.
compiler/GHC/CmmToAsm/CPrim.hs view
@@ -4,6 +4,7 @@ , atomicWriteLabel , atomicRMWLabel , cmpxchgLabel+ , xchgLabel , popCntLabel , pdepLabel , pextLabel@@ -104,6 +105,15 @@ pprFunName AMO_Nand = "nand" pprFunName AMO_Or = "or" pprFunName AMO_Xor = "xor"++xchgLabel :: Width -> String+xchgLabel w = "hs_xchg" ++ pprWidth w+ where+ pprWidth W8 = "8"+ pprWidth W16 = "16"+ pprWidth W32 = "32"+ pprWidth W64 = "64"+ pprWidth w = pprPanic "xchgLabel: Unsupported word width " (ppr w) cmpxchgLabel :: Width -> String cmpxchgLabel w = "hs_cmpxchg" ++ pprWidth w
compiler/GHC/CmmToAsm/Dwarf.hs view
@@ -246,7 +246,7 @@ -- | If the current procedure has an info table, then we also say that -- its first block has one to ensure that it gets the necessary -1 -- offset applied to its start address.- -- See Note [Info Offset] in Dwarf.Types.+ -- See Note [Info Offset] in "GHC.CmmToAsm.Dwarf.Types". setHasInfo :: [(DebugBlock, [UnwindPoint])] -> [(DebugBlock, [UnwindPoint])] setHasInfo [] = []
compiler/GHC/CmmToAsm/Dwarf/Constants.hs view
@@ -1,5 +1,5 @@ -- | Constants describing the DWARF format. Most of this simply--- mirrors /usr/include/dwarf.h.+-- mirrors \/usr\/include\/dwarf.h. module GHC.CmmToAsm.Dwarf.Constants where
compiler/GHC/CmmToAsm/Monad.hs view
@@ -93,11 +93,11 @@ extractUnwindPoints :: [instr] -> [UnwindPoint], -- ^ given the instruction sequence of a block, produce a list of -- the block's 'UnwindPoint's- -- See Note [What is this unwinding business?] in Debug+ -- See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock" -- and Note [Unwinding information in the NCG] in this module. invertCondBranches :: Maybe CFG -> LabelMap RawCmmStatics -> [NatBasicBlock instr] -> [NatBasicBlock instr]- -- ^ Turn the sequence of `jcc l1; jmp l2` into `jncc l2; <block_l1>`+ -- ^ Turn the sequence of @jcc l1; jmp l2@ into @jncc l2; \<block_l1>@ -- when possible. } @@ -149,7 +149,6 @@ initConfig :: DynFlags -> NCGConfig initConfig dflags = NCGConfig { ncgPlatform = targetPlatform dflags- , ncgUnitId = thisPackage dflags , ncgProcAlignment = cmmProcAlignment dflags , ncgDebugLevel = debugLevel dflags , ncgExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags
compiler/GHC/CmmToAsm/PPC/CodeGen.hs view
@@ -2024,6 +2024,7 @@ MO_Ctz _ -> unsupported MO_AtomicRMW {} -> unsupported MO_Cmpxchg w -> (fsLit $ cmpxchgLabel w, False)+ MO_Xchg w -> (fsLit $ xchgLabel w, False) MO_AtomicRead _ -> unsupported MO_AtomicWrite _ -> unsupported
compiler/GHC/CmmToAsm/PPC/Ppr.hs view
@@ -144,7 +144,7 @@ pprDatas :: Platform -> RawCmmStatics -> SDoc--- See note [emit-time elimination of static indirections] in CLabel.+-- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". pprDatas _platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) | lbl == mkIndStaticInfoLabel , let labelInd (CmmLabelOff l _) = Just l
compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs view
@@ -5,6 +5,7 @@ -- Handling of join points -- ~~~~~~~~~~~~~~~~~~~~~~~ --+-- @ -- B1: B2: -- ... ... -- RELOAD SLOT(0), %r1 RELOAD SLOT(0), %r1@@ -14,9 +15,11 @@ -- B3: ... C ... -- RELOAD SLOT(0), %r1 -- ...+-- @ -- -- The Plan -- ~~~~~~~~+-- -- As long as %r1 hasn't been written to in A, B or C then we don't need -- the reload in B3. --
compiler/GHC/CmmToAsm/SPARC/CodeGen.hs view
@@ -677,6 +677,7 @@ MO_Ctz w -> fsLit $ ctzLabel w MO_AtomicRMW w amop -> fsLit $ atomicRMWLabel w amop MO_Cmpxchg w -> fsLit $ cmpxchgLabel w+ MO_Xchg w -> fsLit $ xchgLabel w MO_AtomicRead w -> fsLit $ atomicReadLabel w MO_AtomicWrite w -> fsLit $ atomicWriteLabel w
compiler/GHC/CmmToAsm/SPARC/CodeGen/Base.hs view
@@ -45,7 +45,7 @@ = CondCode Bool Cond InstrBlock --- | a.k.a "Register64"+-- | a.k.a \"Register64\" -- Reg is the lower 32-bit temporary which contains the result. -- Use getHiVRegFromLo to find the other VRegUnique. --
compiler/GHC/CmmToAsm/SPARC/Ppr.hs view
@@ -103,7 +103,7 @@ pprDatas :: Platform -> RawCmmStatics -> SDoc--- See note [emit-time elimination of static indirections] in CLabel.+-- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". pprDatas _platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) | lbl == mkIndStaticInfoLabel , let labelInd (CmmLabelOff l _) = Just l
compiler/GHC/CmmToAsm/SPARC/Regs.hs view
@@ -218,7 +218,7 @@ _ -> panic "MachRegs.argRegs(sparc): don't know about >6 arguments!" --- | All all the regs that could possibly be returned by argRegs+-- | All the regs that could possibly be returned by argRegs -- allArgRegs :: [Reg] allArgRegs
compiler/GHC/CmmToAsm/X86/CodeGen.hs view
@@ -222,7 +222,7 @@ return (BasicBlock id top : other_blocks, statics) -- | Convert 'DELTA' instructions into 'UNWIND' instructions to capture changes--- in the @sp@ register. See Note [What is this unwinding business?] in Debug+-- in the @sp@ register. See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock" -- for details. addSpUnwindings :: Instr -> NatM (OrdList Instr) addSpUnwindings instr@(DELTA d) = do@@ -1241,72 +1241,90 @@ --------------------------------------------------------------------------------++-- | Convert a 'CmmExpr' representing a memory address into an 'Amode'.+--+-- An 'Amode' is a datatype representing a valid address form for the target+-- (e.g. "Base + Index + disp" or immediate) and the code to compute it. getAmode :: CmmExpr -> NatM Amode-getAmode e = do is32Bit <- is32BitPlatform- getAmode' is32Bit e+getAmode e = do+ platform <- getPlatform+ let is32Bit = target32Bit platform -getAmode' :: Bool -> CmmExpr -> NatM Amode-getAmode' _ (CmmRegOff r n) = do platform <- getPlatform- getAmode $ mangleIndexTree platform r n+ case e of+ CmmRegOff r n+ -> getAmode $ mangleIndexTree platform r n -getAmode' is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg),- CmmLit displacement])- | not is32Bit- = return $ Amode (ripRel (litToImm displacement)) nilOL+ CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), CmmLit displacement]+ | not is32Bit+ -> return $ Amode (ripRel (litToImm displacement)) nilOL + -- This is all just ridiculous, since it carefully undoes+ -- what mangleIndexTree has just done.+ CmmMachOp (MO_Sub _rep) [x, CmmLit lit@(CmmInt i _)]+ | is32BitLit is32Bit lit+ -- ASSERT(rep == II32)???+ -> do+ (x_reg, x_code) <- getSomeReg x+ let off = ImmInt (-(fromInteger i))+ return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code) --- This is all just ridiculous, since it carefully undoes--- what mangleIndexTree has just done.-getAmode' is32Bit (CmmMachOp (MO_Sub _rep) [x, CmmLit lit@(CmmInt i _)])- | is32BitLit is32Bit lit- -- ASSERT(rep == II32)???- = do (x_reg, x_code) <- getSomeReg x- let off = ImmInt (-(fromInteger i))- return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)+ CmmMachOp (MO_Add _rep) [x, CmmLit lit]+ | is32BitLit is32Bit lit+ -- ASSERT(rep == II32)???+ -> do+ (x_reg, x_code) <- getSomeReg x+ let off = litToImm lit+ return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code) -getAmode' is32Bit (CmmMachOp (MO_Add _rep) [x, CmmLit lit])- | is32BitLit is32Bit lit- -- ASSERT(rep == II32)???- = do (x_reg, x_code) <- getSomeReg x- let off = litToImm lit- return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)+ -- Turn (lit1 << n + lit2) into (lit2 + lit1 << n) so it will be+ -- recognised by the next rule.+ CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _), b@(CmmLit _)]+ -> getAmode (CmmMachOp (MO_Add rep) [b,a]) --- Turn (lit1 << n + lit2) into (lit2 + lit1 << n) so it will be--- recognised by the next rule.-getAmode' is32Bit (CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _),- b@(CmmLit _)])- = getAmode' is32Bit (CmmMachOp (MO_Add rep) [b,a])+ -- Matches: (x + offset) + (y << shift)+ CmmMachOp (MO_Add _) [CmmRegOff x offset, CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)]]+ | shift == 0 || shift == 1 || shift == 2 || shift == 3+ -> x86_complex_amode (CmmReg x) y shift (fromIntegral offset) --- Matches: (x + offset) + (y << shift)-getAmode' _ (CmmMachOp (MO_Add _) [CmmRegOff x offset,- CmmMachOp (MO_Shl _)- [y, CmmLit (CmmInt shift _)]])- | shift == 0 || shift == 1 || shift == 2 || shift == 3- = x86_complex_amode (CmmReg x) y shift (fromIntegral offset)+ CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)]]+ | shift == 0 || shift == 1 || shift == 2 || shift == 3+ -> x86_complex_amode x y shift 0 -getAmode' _ (CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Shl _)- [y, CmmLit (CmmInt shift _)]])- | shift == 0 || shift == 1 || shift == 2 || shift == 3- = x86_complex_amode x y shift 0+ CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Add _) [CmmMachOp (MO_Shl _)+ [y, CmmLit (CmmInt shift _)], CmmLit (CmmInt offset _)]]+ | shift == 0 || shift == 1 || shift == 2 || shift == 3+ && is32BitInteger offset+ -> x86_complex_amode x y shift offset -getAmode' _ (CmmMachOp (MO_Add _)- [x, CmmMachOp (MO_Add _)- [CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)],- CmmLit (CmmInt offset _)]])- | shift == 0 || shift == 1 || shift == 2 || shift == 3- && is32BitInteger offset- = x86_complex_amode x y shift offset+ CmmMachOp (MO_Add _) [x,y]+ | not (isLit y) -- we already handle valid literals above.+ -> x86_complex_amode x y 0 0 -getAmode' _ (CmmMachOp (MO_Add _) [x,y])- = x86_complex_amode x y 0 0+ CmmLit lit+ | is32BitLit is32Bit lit+ -> return (Amode (ImmAddr (litToImm lit) 0) nilOL) -getAmode' is32Bit (CmmLit lit) | is32BitLit is32Bit lit- = return (Amode (ImmAddr (litToImm lit) 0) nilOL)+ -- Literal with offsets too big (> 32 bits) fails during the linking phase+ -- (#15570). We already handled valid literals above so we don't have to+ -- test anything here.+ CmmLit (CmmLabelOff l off)+ -> getAmode (CmmMachOp (MO_Add W64) [ CmmLit (CmmLabel l)+ , CmmLit (CmmInt (fromIntegral off) W64)+ ])+ CmmLit (CmmLabelDiffOff l1 l2 off w)+ -> getAmode (CmmMachOp (MO_Add W64) [ CmmLit (CmmLabelDiffOff l1 l2 0 w)+ , CmmLit (CmmInt (fromIntegral off) W64)+ ]) -getAmode' _ expr = do- (reg,code) <- getSomeReg expr- return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code)+ -- in case we can't do something better, we just compute the expression+ -- and put the result in a register+ _ -> do+ (reg,code) <- getSomeReg e+ return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code) ++ -- | Like 'getAmode', but on 32-bit use simple register addressing -- (i.e. no index register). This stops us from running out of -- registers on x86 when using instructions such as cmpxchg, which can@@ -1510,11 +1528,17 @@ return (OpReg reg, code) is32BitLit :: Bool -> CmmLit -> Bool-is32BitLit is32Bit (CmmInt i W64)- | not is32Bit- = -- assume that labels are in the range 0-2^31-1: this assumes the+is32BitLit is32Bit lit+ | not is32Bit = case lit of+ CmmInt i W64 -> is32BitInteger i+ -- assume that labels are in the range 0-2^31-1: this assumes the -- small memory model (see gcc docs, -mcmodel=small).- is32BitInteger i+ CmmLabel _ -> True+ -- however we can't assume that label offsets are in this range+ -- (see #15570)+ CmmLabelOff _ off -> is32BitInteger (fromIntegral off)+ CmmLabelDiffOff _ _ off _ -> is32BitInteger (fromIntegral off)+ _ -> True is32BitLit _ _ = True @@ -2518,6 +2542,22 @@ where format = intFormat width +genCCall' config is32Bit (PrimTarget (MO_Xchg width)) [dst] [addr, value] _+ | (is32Bit && width == W64) = panic "gencCall: 64bit atomic exchange not supported on 32bit platforms"+ | otherwise = do+ let dst_r = getRegisterReg platform (CmmLocal dst)+ Amode amode addr_code <- getSimpleAmode is32Bit addr+ (newval, newval_code) <- getSomeReg value+ -- Copy the value into the target register, perform the exchange.+ let code = toOL+ [ MOV format (OpReg newval) (OpReg dst_r)+ , XCHG format (OpAddr amode) dst_r+ ]+ return $ addr_code `appOL` newval_code `appOL` code+ where+ format = intFormat width+ platform = ncgPlatform config+ genCCall' _ is32Bit target dest_regs args bid = do platform <- ncgPlatform <$> getConfig case (target, dest_regs) of@@ -3213,6 +3253,7 @@ MO_AtomicRead _ -> fsLit "atomicread" MO_AtomicWrite _ -> fsLit "atomicwrite" MO_Cmpxchg _ -> fsLit "cmpxchg"+ MO_Xchg _ -> should_be_inline MO_UF_Conv _ -> unsupported @@ -3232,6 +3273,11 @@ (MO_Prefetch_Data _ ) -> unsupported unsupported = panic ("outOfLineCmmOp: " ++ show mop ++ " not supported here")+ -- If we generate a call for the given primop+ -- something went wrong.+ should_be_inline = panic ("outOfLineCmmOp: " ++ show mop+ ++ " should be handled inline")+ -- ----------------------------------------------------------------------------- -- Generating a table-branch
compiler/GHC/CmmToAsm/X86/Instr.hs view
@@ -329,6 +329,7 @@ | LOCK Instr -- lock prefix | XADD Format Operand Operand -- src (r), dst (r/m) | CMPXCHG Format Operand Operand -- src (r), dst (r/m), eax implicit+ | XCHG Format Operand Reg -- src (r/m), dst (r/m) | MFENCE data PrefetchVariant = NTA | Lvl0 | Lvl1 | Lvl2@@ -431,6 +432,7 @@ LOCK i -> x86_regUsageOfInstr platform i XADD _ src dst -> usageMM src dst CMPXCHG _ src dst -> usageRMM src dst (OpReg eax)+ XCHG _ src dst -> usageMM src (OpReg dst) MFENCE -> noUsage _other -> panic "regUsage: unrecognised instr"@@ -460,6 +462,7 @@ usageMM :: Operand -> Operand -> RegUsage usageMM (OpReg src) (OpReg dst) = mkRU [src, dst] [src, dst] usageMM (OpReg src) (OpAddr ea) = mkRU (use_EA ea [src]) [src]+ usageMM (OpAddr ea) (OpReg dst) = mkRU (use_EA ea [dst]) [dst] usageMM _ _ = panic "X86.RegInfo.usageMM: no match" -- 3 operand form; first operand Read; second Modified; third Modified@@ -589,6 +592,7 @@ LOCK i -> LOCK (x86_patchRegsOfInstr i env) XADD fmt src dst -> patch2 (XADD fmt) src dst CMPXCHG fmt src dst -> patch2 (CMPXCHG fmt) src dst+ XCHG fmt src dst -> XCHG fmt (patchOp src) (env dst) MFENCE -> instr _other -> panic "patchRegs: unrecognised instr"
compiler/GHC/CmmToAsm/X86/Ppr.hs view
@@ -58,7 +58,7 @@ -- If we are using the .subsections_via_symbols directive -- (available on recent versions of Darwin), -- we have to make sure that there is some kind of reference--- from the entry code to a label on the _top_ of of the info table,+-- from the entry code to a label on the _top_ of the info table, -- so that the linker will not think it is unreferenced and dead-strip -- it. That's why the label is called a DeadStripPreventer (_dsp). --@@ -150,7 +150,7 @@ pprDatas :: NCGConfig -> (Alignment, RawCmmStatics) -> SDoc--- See note [emit-time elimination of static indirections] in CLabel.+-- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". pprDatas _config (_, CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) | lbl == mkIndStaticInfoLabel , let labelInd (CmmLabelOff l _) = Just l@@ -183,8 +183,8 @@ | not (externallyVisibleCLabel lbl) = empty | otherwise = text ".globl " <> ppr lbl -pprLabelType' :: DynFlags -> CLabel -> SDoc-pprLabelType' dflags lbl =+pprLabelType' :: Platform -> CLabel -> SDoc+pprLabelType' platform lbl = if isCFunctionLabel lbl || functionOkInfoTable then text "@function" else@@ -237,16 +237,14 @@ every code-like thing to give the needed information for to the tools but mess up with the relocation. https://phabricator.haskell.org/D4730 -}- functionOkInfoTable = tablesNextToCode dflags &&+ functionOkInfoTable = platformTablesNextToCode platform && isInfoTableLabel lbl && not (isConInfoTableLabel lbl) pprTypeDecl :: Platform -> CLabel -> SDoc pprTypeDecl platform lbl = if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl- then- sdocWithDynFlags $ \df ->- text ".type " <> ppr lbl <> ptext (sLit ", ") <> pprLabelType' df lbl+ then text ".type " <> ppr lbl <> ptext (sLit ", ") <> pprLabelType' platform lbl else empty pprLabel :: Platform -> CLabel -> SDoc@@ -823,6 +821,9 @@ SETCC cond op -> pprCondInstr (sLit "set") cond (pprOperand platform II8 op)++ XCHG format src val+ -> pprFormatOpReg (sLit "xchg") format src val JXX cond blockid -> pprCondInstr (sLit "j") cond (ppr lab)
compiler/GHC/CmmToC.hs view
@@ -835,6 +835,7 @@ (MO_Ctz w) -> ptext (sLit $ ctzLabel w) (MO_AtomicRMW w amop) -> ptext (sLit $ atomicRMWLabel w amop) (MO_Cmpxchg w) -> ptext (sLit $ cmpxchgLabel w)+ (MO_Xchg w) -> ptext (sLit $ xchgLabel w) (MO_AtomicRead w) -> ptext (sLit $ atomicReadLabel w) (MO_AtomicWrite w) -> ptext (sLit $ atomicWriteLabel w) (MO_UF_Conv w) -> ptext (sLit $ word2FloatLabel w)
compiler/GHC/CmmToLlvm.hs view
@@ -92,7 +92,8 @@ a <- Stream.consume cmm_stream llvmGroupLlvmGens -- Declare aliases for forward references- renderLlvm . pprLlvmData =<< generateExternDecls+ opts <- getLlvmOpts+ renderLlvm . pprLlvmData opts =<< generateExternDecls -- Postamble cmmUsedLlvmGens@@ -150,14 +151,15 @@ mapM_ regGlobal gs gss' <- mapM aliasify $ gs - renderLlvm $ pprLlvmData (concat gss', concat tss)+ opts <- getLlvmOpts+ renderLlvm $ pprLlvmData opts (concat gss', concat tss) -- | Complete LLVM code generation phase for a single top-level chunk of Cmm. cmmLlvmGen ::RawCmmDecl -> LlvmM () cmmLlvmGen cmm@CmmProc{} = do -- rewrite assignments to global regs- dflags <- getDynFlag id+ dflags <- getDynFlags let fixed_cmm = {-# SCC "llvm_fix_regs" #-} fixStgRegisters dflags cmm dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm"@@ -194,7 +196,8 @@ -- just a name on its own. Previously `null` was accepted as the -- name. Nothing -> [ MetaStr name ]- renderLlvm $ ppLlvmMetas metas+ opts <- getLlvmOpts+ renderLlvm $ ppLlvmMetas opts metas -- ----------------------------------------------------------------------------- -- | Marks variables as used where necessary@@ -217,6 +220,7 @@ sectName = Just $ fsLit "llvm.metadata" lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending sectName Nothing Constant lmUsed = LMGlobal lmUsedVar (Just usedArray)+ opts <- getLlvmOpts if null ivars then return ()- else renderLlvm $ pprLlvmData ([lmUsed], [])+ else renderLlvm $ pprLlvmData opts ([lmUsed], [])
compiler/GHC/CmmToLlvm/Base.hs view
@@ -21,9 +21,9 @@ LlvmM, runLlvm, liftStream, withClearVars, varLookup, varInsert, markStackReg, checkStackReg,- funLookup, funInsert, getLlvmVer, getDynFlags, getDynFlag, getLlvmPlatform,+ funLookup, funInsert, getLlvmVer, getDynFlags, dumpIfSetLlvm, renderLlvm, markUsedVar, getUsedVars,- ghcInternalFunctions, getPlatform,+ ghcInternalFunctions, getPlatform, getLlvmOpts, getMetaUniqueId, setUniqMeta, getUniqMeta,@@ -42,12 +42,14 @@ #include "ghcautoconf.h" import GHC.Prelude+import GHC.Utils.Panic import GHC.Llvm import GHC.CmmToLlvm.Regs import GHC.Cmm.CLabel-import GHC.Platform.Regs ( activeStgRegs )+import GHC.Cmm.Ppr.Expr ()+import GHC.Platform.Regs ( activeStgRegs, globalRegMaybe ) import GHC.Driver.Session import GHC.Data.FastString import GHC.Cmm hiding ( succ )@@ -65,7 +67,8 @@ import Data.Maybe (fromJust) import Control.Monad (ap) import Data.Char (isDigit)-import Data.List (sort, groupBy, intercalate)+import Data.List (sortBy, groupBy, intercalate)+import Data.Ord (comparing) import qualified Data.List.NonEmpty as NE -- ----------------------------------------------------------------------------@@ -114,10 +117,10 @@ widthToLlvmInt w = LMInt $ widthInBits w -- | GHC Call Convention for LLVM-llvmGhcCC :: DynFlags -> LlvmCallConvention-llvmGhcCC dflags- | platformUnregisterised (targetPlatform dflags) = CC_Ccc- | otherwise = CC_Ghc+llvmGhcCC :: Platform -> LlvmCallConvention+llvmGhcCC platform+ | platformUnregisterised platform = CC_Ccc+ | otherwise = CC_Ghc -- | Llvm Function type for Cmm function llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType@@ -133,9 +136,8 @@ llvmFunSig' live lbl link = do let toParams x | isPointer x = (x, [NoAlias, NoCapture]) | otherwise = (x, [])- dflags <- getDynFlags platform <- getPlatform- return $ LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs+ return $ LlvmFunctionDecl lbl link (llvmGhcCC platform) LMVoid FixedArgs (map (toParams . getVarType) (llvmFunArgs platform live)) (llvmFunAlign platform) @@ -148,18 +150,20 @@ llvmInfAlign platform = Just (platformWordSizeInBytes platform) -- | Section to use for a function-llvmFunSection :: DynFlags -> LMString -> LMSection-llvmFunSection dflags lbl- | gopt Opt_SplitSections dflags = Just (concatFS [fsLit ".text.", lbl])- | otherwise = Nothing+llvmFunSection :: LlvmOpts -> LMString -> LMSection+llvmFunSection opts lbl+ | llvmOptsSplitSections opts = Just (concatFS [fsLit ".text.", lbl])+ | otherwise = Nothing -- | A Function's arguments llvmFunArgs :: Platform -> LiveGlobalRegs -> [LlvmVar] llvmFunArgs platform live = map (lmGlobalRegArg platform) (filter isPassed allRegs) where allRegs = activeStgRegs platform- paddedLive = map (\(_,r) -> r) $ padLiveArgs platform live- isLive r = r `elem` alwaysLive || r `elem` paddedLive+ paddingRegs = padLiveArgs platform live+ isLive r = r `elem` alwaysLive+ || r `elem` live+ || r `elem` paddingRegs isPassed r = not (isFPR r) || isLive r @@ -171,91 +175,76 @@ isFPR (ZmmReg _) = True isFPR _ = False -sameFPRClass :: GlobalReg -> GlobalReg -> Bool-sameFPRClass (FloatReg _) (FloatReg _) = True-sameFPRClass (DoubleReg _) (DoubleReg _) = True-sameFPRClass (XmmReg _) (XmmReg _) = True-sameFPRClass (YmmReg _) (YmmReg _) = True-sameFPRClass (ZmmReg _) (ZmmReg _) = True-sameFPRClass _ _ = False--normalizeFPRNum :: GlobalReg -> GlobalReg-normalizeFPRNum (FloatReg _) = FloatReg 1-normalizeFPRNum (DoubleReg _) = DoubleReg 1-normalizeFPRNum (XmmReg _) = XmmReg 1-normalizeFPRNum (YmmReg _) = YmmReg 1-normalizeFPRNum (ZmmReg _) = ZmmReg 1-normalizeFPRNum _ = error "normalizeFPRNum expected only FPR regs"--getFPRCtor :: GlobalReg -> Int -> GlobalReg-getFPRCtor (FloatReg _) = FloatReg-getFPRCtor (DoubleReg _) = DoubleReg-getFPRCtor (XmmReg _) = XmmReg-getFPRCtor (YmmReg _) = YmmReg-getFPRCtor (ZmmReg _) = ZmmReg-getFPRCtor _ = error "getFPRCtor expected only FPR regs"--fprRegNum :: GlobalReg -> Int-fprRegNum (FloatReg i) = i-fprRegNum (DoubleReg i) = i-fprRegNum (XmmReg i) = i-fprRegNum (YmmReg i) = i-fprRegNum (ZmmReg i) = i-fprRegNum _ = error "fprRegNum expected only FPR regs"---- | Input: dynflags, and the list of live registers------ Output: An augmented list of live registers, where padding was--- added to the list of registers to ensure the calling convention is--- correctly used by LLVM.------ Each global reg in the returned list is tagged with a bool, which--- indicates whether the global reg was added as padding, or was an original--- live register.------ That is, True => padding, False => a real, live global register.+-- | Return a list of "padding" registers for LLVM function calls. ----- Also, the returned list is not sorted in any particular order.+-- When we generate LLVM function signatures, we can't just make any register+-- alive on function entry. Instead, we need to insert fake arguments of the+-- same register class until we are sure that one of them is mapped to the+-- register we want alive. E.g. to ensure that F5 is alive, we may need to+-- insert fake arguments mapped to F1, F2, F3 and F4. ---padLiveArgs :: Platform -> LiveGlobalRegs -> [(Bool, GlobalReg)]-padLiveArgs plat live =- if platformUnregisterised plat- then taggedLive -- not using GHC's register convention for platform.- else padding ++ taggedLive+-- Invariant: Cmm FPR regs with number "n" maps to real registers with number+-- "n" If the calling convention uses registers in a different order or if the+-- invariant doesn't hold, this code probably won't be correct.+padLiveArgs :: Platform -> LiveGlobalRegs -> LiveGlobalRegs+padLiveArgs platform live =+ if platformUnregisterised platform+ then [] -- not using GHC's register convention for platform.+ else padded where- taggedLive = map (\x -> (False, x)) live+ ----------------------------------+ -- handle floating-point registers (FPR) - fprLive = filter isFPR live- padding = concatMap calcPad $ groupBy sharesClass fprLive+ fprLive = filter isFPR live -- real live FPR registers - sharesClass :: GlobalReg -> GlobalReg -> Bool- sharesClass a b = sameFPRClass a b || overlappingClass- where- overlappingClass = regsOverlap plat (norm a) (norm b)- norm = CmmGlobal . normalizeFPRNum+ -- we group live registers sharing the same classes, i.e. that use the same+ -- set of real registers to be passed. E.g. FloatReg, DoubleReg and XmmReg+ -- all use the same real regs on X86-64 (XMM registers).+ --+ classes = groupBy sharesClass fprLive+ sharesClass a b = regsOverlap platform (norm a) (norm b) -- check if mapped to overlapping registers+ norm x = CmmGlobal ((fpr_ctor x) 1) -- get the first register of the family - calcPad :: [GlobalReg] -> [(Bool, GlobalReg)]- calcPad rs = getFPRPadding (getFPRCtor $ head rs) rs+ -- For each class, we just have to fill missing registers numbers. We use+ -- the constructor of the greatest register to build padding registers.+ --+ -- E.g. sortedRs = [ F2, XMM4, D5]+ -- output = [D1, D3]+ padded = concatMap padClass classes+ padClass rs = go sortedRs [1..]+ where+ sortedRs = sortBy (comparing fpr_num) rs+ maxr = last sortedRs+ ctor = fpr_ctor maxr -getFPRPadding :: (Int -> GlobalReg) -> LiveGlobalRegs -> [(Bool, GlobalReg)]-getFPRPadding paddingCtor live = padding- where- fprRegNums = sort $ map fprRegNum live- (_, padding) = foldl assignSlots (1, []) $ fprRegNums+ go [] _ = []+ go (c1:c2:_) _ -- detect bogus case (see #17920)+ | fpr_num c1 == fpr_num c2+ , Just real <- globalRegMaybe platform c1+ = sorryDoc "LLVM code generator" $+ text "Found two different Cmm registers (" <> ppr c1 <> text "," <> ppr c2 <>+ text ") both alive AND mapped to the same real register: " <> ppr real <>+ text ". This isn't currently supported by the LLVM backend."+ go (c:cs) (f:fs)+ | fpr_num c == f = go cs fs -- already covered by a real register+ | otherwise = ctor f : go (c:cs) fs -- add padding register+ go _ _ = undefined -- unreachable - assignSlots (i, acc) regNum- | i == regNum = -- don't need padding here- (i+1, acc)- | i < regNum = let -- add padding for slots i .. regNum-1- numNeeded = regNum-i- acc' = genPad i numNeeded ++ acc- in- (regNum+1, acc')- | otherwise = error "padLiveArgs -- i > regNum ??"+ fpr_ctor :: GlobalReg -> Int -> GlobalReg+ fpr_ctor (FloatReg _) = FloatReg+ fpr_ctor (DoubleReg _) = DoubleReg+ fpr_ctor (XmmReg _) = XmmReg+ fpr_ctor (YmmReg _) = YmmReg+ fpr_ctor (ZmmReg _) = ZmmReg+ fpr_ctor _ = error "fpr_ctor expected only FPR regs" - genPad start n =- take n $ flip map (iterate (+1) start) (\i ->- (True, paddingCtor i))+ fpr_num :: GlobalReg -> Int+ fpr_num (FloatReg i) = i+ fpr_num (DoubleReg i) = i+ fpr_num (XmmReg i) = i+ fpr_num (YmmReg i) = i+ fpr_num (ZmmReg i) = i+ fpr_num _ = error "fpr_num expected only FPR regs" -- | Llvm standard fun attributes@@ -311,6 +300,7 @@ data LlvmEnv = LlvmEnv { envVersion :: LlvmVersion -- ^ LLVM version+ , envOpts :: LlvmOpts -- ^ LLVM backend options , envDynFlags :: DynFlags -- ^ Dynamic flags , envOutput :: BufHandle -- ^ Output buffer , envMask :: !Char -- ^ Mask for creating unique values@@ -342,9 +332,14 @@ instance HasDynFlags LlvmM where getDynFlags = LlvmM $ \env -> return (envDynFlags env, env) +-- | Get target platform getPlatform :: LlvmM Platform-getPlatform = targetPlatform <$> getDynFlags+getPlatform = llvmOptsPlatform <$> getLlvmOpts +-- | Get LLVM options+getLlvmOpts :: LlvmM LlvmOpts+getLlvmOpts = LlvmM $ \env -> return (envOpts env, env)+ instance MonadUnique LlvmM where getUniqueSupplyM = do mask <- getEnv envMask@@ -370,6 +365,7 @@ , envUsedVars = [] , envAliases = emptyUniqSet , envVersion = ver+ , envOpts = initLlvmOpts dflags , envDynFlags = dflags , envOutput = out , envMask = 'n'@@ -426,14 +422,6 @@ getLlvmVer :: LlvmM LlvmVersion getLlvmVer = getEnv envVersion --- | Get the platform we are generating code for-getDynFlag :: (DynFlags -> a) -> LlvmM a-getDynFlag f = getEnv (f . envDynFlags)---- | Get the platform we are generating code for-getLlvmPlatform :: LlvmM Platform-getLlvmPlatform = getDynFlag targetPlatform- -- | Dumps the document if the corresponding flag has been set by the user dumpIfSetLlvm :: DumpFlag -> String -> DumpFormat -> Outp.SDoc -> LlvmM () dumpIfSetLlvm flag hdr fmt doc = do@@ -568,7 +556,7 @@ -- | Here we take a global variable definition, rename it with a -- @$def@ suffix, and generate the appropriate alias. aliasify :: LMGlobal -> LlvmM [LMGlobal]--- See note [emit-time elimination of static indirections] in CLabel.+-- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". -- Here we obtain the indirectee's precise type and introduce -- fresh aliases to both the precise typed label (lbl$def) and the i8* -- typed (regular) label of it with the matching new names.
compiler/GHC/CmmToLlvm/CodeGen.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, GADTs #-}+{-# LANGUAGE CPP, GADTs, MultiWayIf #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- ----------------------------------------------------------------------------@@ -38,6 +38,7 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Writer+import Control.Monad import qualified Data.Semigroup as Semigroup import Data.List ( nub )@@ -178,7 +179,7 @@ -- exceptions (where no code will be emitted instead). barrierUnless :: [Arch] -> LlvmM StmtData barrierUnless exs = do- platform <- getLlvmPlatform+ platform <- getPlatform if platformArch platform `elem` exs then return (nilOL, []) else barrier@@ -281,6 +282,16 @@ retVar' <- doExprW targetTy $ ExtractV retVar 0 statement $ Store retVar' dstVar +genCall (PrimTarget (MO_Xchg _width)) [dst] [addr, val] = runStmtsDecls $ do+ dstV <- getCmmRegW (CmmLocal dst) :: WriterT LlvmAccum LlvmM LlvmVar+ addrVar <- exprToVarW addr+ valVar <- exprToVarW val+ let ptrTy = pLift $ getVarType valVar+ ptrExpr = Cast LM_Inttoptr addrVar ptrTy+ ptrVar <- doExprW ptrTy ptrExpr+ resVar <- doExprW (getVarType valVar) (AtomicRMW LAO_Xchg ptrVar valVar SyncSeqCst)+ statement $ Store resVar dstV+ genCall (PrimTarget (MO_AtomicWrite _width)) [] [addr, val] = runStmtsDecls $ do addrVar <- exprToVarW addr valVar <- exprToVarW val@@ -415,7 +426,7 @@ ++ " 0 or 1, given " ++ show (length t) ++ "." -- extract Cmm call convention, and translate to LLVM call convention- platform <- lift $ getLlvmPlatform+ platform <- lift $ getPlatform let lmconv = case target of ForeignTarget _ (ForeignConvention conv _ _ _) -> case conv of@@ -856,6 +867,7 @@ MO_AtomicRMW _ _ -> unsupported MO_AtomicWrite _ -> unsupported MO_Cmpxchg _ -> unsupported+ MO_Xchg _ -> unsupported -- | Tail function calls genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData@@ -993,6 +1005,7 @@ let stmts = stmts1 `appOL` stmts2 dflags <- getDynFlags platform <- getPlatform+ opts <- getLlvmOpts case getVarType vaddr of -- sometimes we need to cast an int to a pointer before storing LMPointer ty@(LMPointer _) | getVarType vval == llvmWord platform -> do@@ -1015,7 +1028,7 @@ (PprCmm.pprExpr platform addr <+> text ( "Size of Ptr: " ++ show (llvmPtrBits platform) ++ ", Size of var: " ++ show (llvmWidthInBits platform other) ++- ", Var: " ++ showSDoc dflags (ppr vaddr)))+ ", Var: " ++ showSDoc dflags (ppVar opts vaddr))) -- | Unconditional branch@@ -1041,7 +1054,8 @@ return (stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2) else do dflags <- getDynFlags- panic $ "genCondBranch: Cond expr not bool! (" ++ showSDoc dflags (ppr vc) ++ ")"+ opts <- getLlvmOpts+ panic $ "genCondBranch: Cond expr not bool! (" ++ showSDoc dflags (ppVar opts vc) ++ ")" -- | Generate call to llvm.expect.x intrinsic. Assigning result to a new var.@@ -1663,6 +1677,7 @@ genLoad_slow atomic e ty meta = do platform <- getPlatform dflags <- getDynFlags+ opts <- getLlvmOpts runExprData $ do iptr <- exprToVarW e case getVarType iptr of@@ -1678,7 +1693,7 @@ (PprCmm.pprExpr platform e <+> text ( "Size of Ptr: " ++ show (llvmPtrBits platform) ++ ", Size of var: " ++ show (llvmWidthInBits platform other) ++- ", Var: " ++ showSDoc dflags (ppr iptr)))+ ", Var: " ++ showSDoc dflags (ppVar opts iptr))) where loadInstr ptr | atomic = ALoad SyncSeqCst False ptr | otherwise = Load ptr@@ -1834,7 +1849,7 @@ isLive r = r `elem` alwaysLive || r `elem` live platform <- getPlatform- stmtss <- flip mapM assignedRegs $ \reg ->+ stmtss <- forM assignedRegs $ \reg -> case reg of CmmLocal (LocalReg un _) -> do let (newv, stmts) = allocReg reg@@ -1861,9 +1876,7 @@ funEpilogue live = do platform <- getPlatform - -- the bool indicates whether the register is padding.- let alwaysNeeded = map (\r -> (False, r)) alwaysLive- livePadded = alwaysNeeded ++ padLiveArgs platform live+ let paddingRegs = padLiveArgs platform live -- Set to value or "undef" depending on whether the register is -- actually live@@ -1873,14 +1886,25 @@ loadUndef r = do let ty = (pLower . getVarType $ lmGlobalRegVar platform r) return (Just $ LMLitVar $ LMUndefLit ty, nilOL)- platform <- getDynFlag targetPlatform++ -- Note that floating-point registers in `activeStgRegs` must be sorted+ -- according to the calling convention.+ -- E.g. for X86:+ -- GOOD: F1,D1,XMM1,F2,D2,XMM2,...+ -- BAD : F1,F2,F3,D1,D2,D3,XMM1,XMM2,XMM3,...+ -- As Fn, Dn and XMMn use the same register (XMMn) to be passed, we don't+ -- want to pass F2 before D1 for example, otherwise we could get F2 -> XMM1+ -- and D1 -> XMM2. let allRegs = activeStgRegs platform- loads <- flip mapM allRegs $ \r -> case () of- _ | (False, r) `elem` livePadded- -> loadExpr r -- if r is not padding, load it- | not (isFPR r) || (True, r) `elem` livePadded- -> loadUndef r- | otherwise -> return (Nothing, nilOL)+ loads <- forM allRegs $ \r -> if+ -- load live registers+ | r `elem` alwaysLive -> loadExpr r+ | r `elem` live -> loadExpr r+ -- load all non Floating-Point Registers+ | not (isFPR r) -> loadUndef r+ -- load padding Floating-Point Registers+ | r `elem` paddingRegs -> loadUndef r+ | otherwise -> return (Nothing, nilOL) let (vars, stmts) = unzip loads return (catMaybes vars, concatOL stmts)@@ -1943,10 +1967,10 @@ -- | Error functions-panic :: String -> a+panic :: HasCallStack => String -> a panic s = Outputable.panic $ "GHC.CmmToLlvm.CodeGen." ++ s -pprPanic :: String -> SDoc -> a+pprPanic :: HasCallStack => String -> SDoc -> a pprPanic s d = Outputable.pprPanic ("GHC.CmmToLlvm.CodeGen." ++ s) d
compiler/GHC/CmmToLlvm/Data.hs view
@@ -17,7 +17,6 @@ import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Cmm-import GHC.Driver.Session import GHC.Platform import GHC.Data.FastString@@ -43,7 +42,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.+-- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". genLlvmData (_, CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) | lbl == mkIndStaticInfoLabel , let labelInd (CmmLabelOff l _) = Just l@@ -71,7 +70,7 @@ label <- strCLabel_llvm lbl static <- mapM genData xs lmsec <- llvmSection sec- platform <- getLlvmPlatform+ platform <- getPlatform let types = map getStatType static strucTy = LMStruct types@@ -113,9 +112,9 @@ -- | Format a Cmm Section into a LLVM section name llvmSection :: Section -> LlvmM LMSection llvmSection (Section t suffix) = do- dflags <- getDynFlags- let splitSect = gopt Opt_SplitSections dflags- platform = targetPlatform dflags+ opts <- getLlvmOpts+ let splitSect = llvmOptsSplitSections opts+ platform = llvmOptsPlatform opts if not splitSect then return Nothing else do
compiler/GHC/CmmToLlvm/Ppr.hs view
@@ -27,21 +27,22 @@ -- -- | Pretty print LLVM data code-pprLlvmData :: LlvmData -> SDoc-pprLlvmData (globals, types) =+pprLlvmData :: LlvmOpts -> LlvmData -> SDoc+pprLlvmData opts (globals, types) = let ppLlvmTys (LMAlias a) = ppLlvmAlias a ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f ppLlvmTys _other = empty types' = vcat $ map ppLlvmTys types- globals' = ppLlvmGlobals globals+ globals' = ppLlvmGlobals opts globals in types' $+$ globals' -- | Pretty print LLVM code pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar])-pprLlvmCmmDecl (CmmData _ lmdata)- = return (vcat $ map pprLlvmData lmdata, [])+pprLlvmCmmDecl (CmmData _ lmdata) = do+ opts <- getLlvmOpts+ return (vcat $ map (pprLlvmData opts) lmdata, []) pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks)) = do let lbl = case mb_info of@@ -55,10 +56,11 @@ funDec <- llvmFunSig live lbl link dflags <- getDynFlags+ opts <- getLlvmOpts platform <- getPlatform- let buildArg = fsLit . showSDoc dflags . ppPlainName+ let buildArg = fsLit . showSDoc dflags . ppPlainName opts funArgs = map buildArg (llvmFunArgs platform live)- funSect = llvmFunSection dflags (decName funDec)+ funSect = llvmFunSection opts (decName funDec) -- generate the info table prefix <- case mb_info of@@ -92,7 +94,7 @@ (Just $ LMBitc (LMStaticPointer defVar) i8Ptr) - return (ppLlvmGlobal alias $+$ ppLlvmFunction platform fun', [])+ return (ppLlvmGlobal opts alias $+$ ppLlvmFunction opts fun', []) -- | The section we are putting info tables and their entry code into, should
compiler/GHC/CmmToLlvm/Regs.hs view
@@ -47,6 +47,8 @@ VanillaReg 6 _ -> wordGlobal $ "R6" ++ suf VanillaReg 7 _ -> wordGlobal $ "R7" ++ suf VanillaReg 8 _ -> wordGlobal $ "R8" ++ suf+ VanillaReg 9 _ -> wordGlobal $ "R9" ++ suf+ VanillaReg 10 _ -> wordGlobal $ "R10" ++ suf SpLim -> wordGlobal $ "SpLim" ++ suf FloatReg 1 -> floatGlobal $"F1" ++ suf FloatReg 2 -> floatGlobal $"F2" ++ suf
− compiler/GHC/Core/Lint.hs
@@ -1,2985 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1993-1998---A ``lint'' pass to check for Core correctness.-See Note [Core Lint guarantee].--}--{-# LANGUAGE CPP #-}-{-# 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 "GhclibHsVersions.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.Opt.Arity ( typeArity )-import GHC.Types.Demand ( splitStrictSig, isDeadEndDiv )--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 <body>-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 <body> 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 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- $ withPprStyle defaultDumpStyle- (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- $ withPprStyle defaultDumpStyle- (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- $ withPprStyle defaultDumpStyle- (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)]- -> ([LintedId] -> LintM a) -> LintM a-lintRecBindings top_lvl pairs thing_inside- = lintIdBndrs top_lvl bndrs $ \ bndrs' ->- do { zipWithM_ lint_pair bndrs' rhss- ; thing_inside bndrs' }- 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 }--lintLetBody :: [LintedId] -> CoreExpr -> LintM LintedType-lintLetBody bndrs body- = do { body_ty <- addLoc (BodyOfLetRec bndrs) (lintCoreExpr body)- ; mapM_ (lintJoinBndrType body_ty) bndrs- ; return body_ty }--lintLetBind :: TopLevelFlag -> RecFlag -> LintedId- -> CoreExpr -> LintedType -> LintM ()--- Binder's type, and the RHS, have already been linted--- 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) | isDeadEndDiv 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 ()-- ; addLoc (RuleOf binder) $ 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- = lintJoinLams arity (Just bndr) rhs- | AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr)- = lintJoinLams arity Nothing rhs---- 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---- | Lint the RHS of a join point with expected join arity of @n@ (see Note--- [Join points] in GHC.Core).-lintJoinLams :: JoinArity -> Maybe Id -> CoreExpr -> LintM LintedType-lintJoinLams join_arity enforce rhs- = go join_arity rhs- where- go 0 rhs = lintCoreExpr rhs- go n (Lam var expr) = lintLambda var $ go (n-1) expr- -- N.B. join points can be cast. e.g. we consider ((\x -> ...) `cast` ...)- -- to be a join point at join arity 1.- go n _other | Just bndr <- enforce -- Join point with too few RHS lambdas- = failWithL $ mkBadJoinArityMsg bndr join_arity n rhs- | otherwise -- Future join point, not yet eta-expanded- = markAllJoinsBad $ lintCoreExpr rhs- -- Body of lambda is not a tail position--lintIdUnfolding :: Id -> Type -> Unfolding -> LintM ()-lintIdUnfolding bndr bndr_ty uf- | isStableUnfolding uf- , 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.--Note [Linting of runRW#]-~~~~~~~~~~~~~~~~~~~~~~~~-runRW# has some very peculiar behavior (see Note [runRW magic] in-GHC.CoreToStg.Prep) which CoreLint must accommodate.--As described in Note [Casts and lambdas] in-GHC.Core.Opt.Simplify.Utils, the simplifier pushes casts out of-lambdas. Concretely, the simplifier will transform-- runRW# @r @ty (\s -> expr `cast` co)--into-- runRW# @r @ty ((\s -> expr) `cast` co)--Consequently we need to handle the case that the continuation is a-cast of a lambda. See Note [Casts and lambdas] in-GHC.Core.Opt.Simplify.Utils.--In the event that the continuation is headed by a lambda (which-will bind the State# token) we can safely allow calls to join-points since CorePrep is going to apply the continuation to-RealWorld.--In the case that the continuation is not a lambda we lint the-continuation disallowing join points, to rule out things like,-- join j = ...- in runRW# @r @ty (- let x = jump j- in x- )---************************************************************************-* *-\subsection[lintCoreExpr]{lintCoreExpr}-* *-************************************************************************--}---- Linted things: substitution applied, and type is linted-type LintedType = Type-type LintedKind = Kind-type LintedCoercion = Coercion-type LintedTyCoVar = TyCoVar-type LintedId = Id---- | Lint an expression cast through the given coercion, returning the type--- resulting from the cast.-lintCastExpr :: CoreExpr -> LintedType -> Coercion -> LintM LintedType-lintCastExpr expr expr_ty co- = do { co' <- lintCoercion co- ; let (Pair from_ty to_ty, role) = coercionKindRole co'- ; checkValueType to_ty $- text "target of cast" <+> quotes (ppr co')- ; lintRole co' Representational role- ; ensureEqTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty)- ; return to_ty }--lintCoreExpr :: CoreExpr -> LintM LintedType--- The returned type has the substitution from the monad--- already applied to it:--- 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- lintCastExpr expr expr_ty co--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- ; lintLetBody [bndr'] 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 $ \ bndrs' ->- lintLetBody bndrs' body }- where- bndrs = map fst pairs--lintCoreExpr e@(App _ _)- | Var fun <- fun- , fun `hasKey` runRWKey- -- N.B. we may have an over-saturated application of the form:- -- runRW (\s -> \x -> ...) y- , arg_ty1 : arg_ty2 : arg3 : rest <- args- = do { fun_ty1 <- lintCoreArg (idType fun) arg_ty1- ; fun_ty2 <- lintCoreArg fun_ty1 arg_ty2- -- See Note [Linting of runRW#]- ; let lintRunRWCont :: CoreArg -> LintM LintedType- lintRunRWCont (Cast expr co) = do- ty <- lintRunRWCont expr- lintCastExpr expr ty co- lintRunRWCont expr@(Lam _ _) = do- lintJoinLams 1 (Just fun) expr- lintRunRWCont other = markAllJoinsBad $ lintCoreExpr other- -- TODO: Look through ticks?- ; arg3_ty <- lintRunRWCont arg3- ; app_ty <- lintValApp arg3 fun_ty2 arg3_ty- ; lintCoreArgs app_ty rest }-- | Var fun <- fun- , fun `hasKey` runRWKey- = failWithL (text "Invalid runRW# application")-- | otherwise- = do { fun_ty <- lintCoreFun fun (length args)- ; lintCoreArgs fun_ty args }- where- (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 ()---------------------lintJoinBndrType :: LintedType -- Type of the body- -> LintedId -- Possibly a join Id- -> LintM ()--- Checks that the return type of a join Id matches the body--- E.g. join j x = rhs in body--- The type of 'rhs' must be the same as the type of 'body'-lintJoinBndrType body_ty bndr- | Just arity <- isJoinId_maybe bndr- , let bndr_ty = idType bndr- , (bndrs, res) <- splitPiTys bndr_ty- = checkL (length bndrs >= arity- && body_ty `eqType` mkPiTys (drop arity bndrs) res) $- hang (text "Join point returns different type than body")- 2 (vcat [ text "Join bndr:" <+> ppr bndr <+> dcolon <+> ppr (idType bndr)- , text "Join arity:" <+> ppr arity- , text "Body type:" <+> ppr body_ty ])- | otherwise- = return ()--checkJoinOcc :: Id -> JoinArity -> LintM ()--- Check that if the occurrence is a JoinId, then so is the--- binding site, and it's a valid join Id-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.--* exprIsDeadEnd is true: we should be able to see why GHC believes the- scrutinee is diverging for sure.--It was already known that the second test was not entirely reliable.-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 arg fun_ty arg_ty@ lints an application of @fun arg@--- where @fun :: fun_ty@ and @arg :: arg_ty@, returning the type of the--- application.-lintValApp :: CoreExpr -> LintedType -> LintedType -> LintM LintedType-lintValApp arg fun_ty arg_ty- | Just (arg_ty', res_ty') <- splitFunTy_maybe fun_ty- = do { ensureEqTys arg_ty' arg_ty err1- ; return res_ty' }- | 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 (exprIsDeadEnd scrut)- -> pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var))- -- This can legitimately happen for type families- $ return ()- _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.Opt.Arity.etaExpandToJoinPointRule'), and in fact-the simplifier would have to in order to deal with the RHS. So we take a-conservative view and don't allow undersaturated rules for join points. See-Note [Rules and join points] in OccurAnal for further discussion.--}--{--************************************************************************-* *- 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- | cv `isInScope` subst- -> return (CoVarCo cv)- | otherwise- ->- -- lintCoBndr always extends the substitition- failWithL $- hang (text "The coercion variable" <+> pprBndr LetBind cv)- 2 (text "is out of scope")- }---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- | RuleOf Id -- Rules attached to a 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 (RuleOf b)- = (getSrcLoc b, text "In a rule attached to" <+> pp_binder b)--dumpLoc (UnfoldingOf b)- = (getSrcLoc b, text "In the unfolding of" <+> pp_binder b)--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 n rhs- = vcat [ text "Join point has too few lambdas",- text "Join var:" <+> ppr var,- text "Join arity:" <+> ppr ar,- text "Number of lambdas:" <+> ppr (ar - n),- 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 $ nest 2 $ vcat diffs- ]- -- Return actual new guts- return nguts---- | Run the given pass without annotations. This means that we both--- set the debugLevel setting to 0 in the environment as well as all--- annotations from incoming modules.-withoutAnnots :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts-withoutAnnots pass guts = do- -- Remove debug flag from environment.- dflags <- getDynFlags- let removeFlag env = env{ hsc_dflags = dflags{ debugLevel = 0} }- withoutFlag corem =- -- TODO: supply tag here as well ?- liftIO =<< runCoreM <$> fmap removeFlag getHscEnv <*> getRuleBase <*>- getUniqMask <*> getModule <*>- getVisibleOrphanMods <*>- getPrintUnqualified <*> getSrcSpanM <*>- pure corem- -- Nuke existing ticks in module.- -- TODO: Ticks in unfoldings. Maybe change unfolding so it removes- -- them in absence of debugLevel > 0.- let nukeTicks = stripTicksE (not . tickishIsCode)- nukeAnnotsBind :: CoreBind -> CoreBind- nukeAnnotsBind bind = case bind of- Rec bs -> Rec $ map (\(b,e) -> (b, nukeTicks e)) bs- NonRec b e -> NonRec b $ nukeTicks e- nukeAnnotsMod mg@ModGuts{mg_binds=binds}- = mg{mg_binds = map nukeAnnotsBind binds}- -- Perform pass with all changes applied- fmap fst $ withoutFlag $ pass (nukeAnnotsMod guts)
compiler/GHC/Core/Opt/CSE.hs view
@@ -404,7 +404,7 @@ -- These rules are probably auto-generated specialisations, -- since Ids with manual rules usually have manually-inserted -- delayed inlining anyway- = bndr `setInlineActivation` activeAfterInitial+ = bndr `setInlineActivation` activateAfterInitial | otherwise = bndr @@ -775,7 +775,7 @@ csEnvSubst = cs_subst lookupSubst :: CSEnv -> Id -> OutExpr-lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst (text "CSE.lookupSubst") sub x+lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst sub x extendCSSubst :: CSEnv -> Id -> CoreExpr -> CSEnv extendCSSubst cse x rhs = cse { cs_subst = extendSubst (cs_subst cse) x rhs }
compiler/GHC/Core/Opt/CprAnal.hs view
@@ -331,8 +331,8 @@ cprExpandUnfolding_maybe :: Id -> Maybe CoreExpr cprExpandUnfolding_maybe id = do guard (idArity id == 0)- -- There are only phase 0 Simplifier runs after CPR analysis- guard (isActiveIn 0 (idInlineActivation id))+ -- There are only FinalPhase Simplifier runs after CPR analysis+ guard (activeInFinalPhase (idInlineActivation id)) expandUnfolding_maybe (idUnfolding id) {- Note [Arity trimming for CPR signatures]@@ -373,7 +373,7 @@ -- ^ 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"+ -- iteration. See Note [Initialising strictness] in "GHC.Core.Opt.DmdAnal" , ae_fam_envs :: FamInstEnvs -- ^ Needed when expanding type families and synonyms of product types. }
compiler/GHC/Core/Opt/DmdAnal.hs view
@@ -19,6 +19,7 @@ import GHC.Core.Opt.WorkWrap.Utils import GHC.Types.Demand -- All of it import GHC.Core+import GHC.Core.Multiplicity ( scaledThing ) import GHC.Core.Seq ( seqBinds ) import GHC.Utils.Outputable import GHC.Types.Var.Env@@ -62,9 +63,10 @@ -> CoreBind -> (AnalEnv, CoreBind) dmdAnalTopBind env (NonRec id rhs)- = (extendAnalEnv TopLevel env id' (idStrictness id'), NonRec id' rhs')+ = ( extendAnalEnv TopLevel env id sig+ , NonRec (setIdStrictness id sig) rhs') where- ( _, id', rhs') = dmdAnalRhsLetDown Nothing env cleanEvalDmd id rhs+ ( _, sig, rhs') = dmdAnalRhsLetDown Nothing env cleanEvalDmd id rhs dmdAnalTopBind env (Rec pairs) = (env', Rec pairs')@@ -216,16 +218,14 @@ -- 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+ (rhs_ty, rhs') = dmdAnal env 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 fam_envs = ae_fam_envs env alt_ty3- -- See Note [Precise exceptions and strictness analysis] in Demand+ -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" | exprMayThrowPreciseException fam_envs scrut = deferAfterPreciseException alt_ty2 | otherwise@@ -259,7 +259,7 @@ -- when there really are no alternatives fam_envs = ae_fam_envs env alt_ty2- -- See Note [Precise exceptions and strictness analysis] in Demand+ -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" | exprMayThrowPreciseException fam_envs scrut = deferAfterPreciseException alt_ty | otherwise@@ -299,8 +299,9 @@ 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)+ (lazy_fv, sig, rhs') = dmdAnalRhsLetDown Nothing env dmd id rhs+ id1 = setIdStrictness id sig+ env1 = extendAnalEnv NotTopLevel env id sig (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]@@ -358,7 +359,7 @@ | Just DataConAppContext{ dcac_dc = dc, dcac_arg_tys = field_tys } <- deepSplitProductType_maybe fam_envs ty , isUnboxedTupleCon dc- = any (\(ty,_) -> ty `eqType` realWorldStatePrimTy) field_tys+ = any (\(ty,_) -> scaledThing ty `eqType` realWorldStatePrimTy) field_tys | otherwise = False @@ -509,95 +510,11 @@ = -- pprTrace "dmdTransform:other" (vcat [ppr var, ppr sig, ppr dmd, ppr res]) $ unitDmdType (unitVarEnv var (mkOnceUsedDmd dmd)) -{--************************************************************************+{- ********************************************************************* * *-\subsection{Bindings}+ Binding right-hand sides * *-************************************************************************--}---- 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).@@ -615,30 +532,26 @@ :: Maybe [Id] -- Just bs <=> recursive, Nothing <=> non-recursive -> AnalEnv -> CleanDemand -> Id -> CoreExpr- -> (DmdEnv, Id, CoreExpr)+ -> (DmdEnv, StrictSig, CoreExpr) -- Process the RHS of the binding, add the strictness signature -- to the Id, and augment the environment with the signature as well.+-- See Note [NOINLINE and strictness] dmdAnalRhsLetDown rec_flag env let_dmd id rhs- = (lazy_fv, id', rhs')+ = (lazy_fv, sig, 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- sig = mkStrictSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div)- id' = -- pprTrace "dmdAnalRhsLetDown" (ppr id <+> ppr sig) $- setIdStrictness id sig- -- See Note [NOINLINE and strictness]+ 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+ sig = mkStrictSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div) -- See Note [Aggregated demand for cardinality] rhs_fv1 = case rec_flag of@@ -912,14 +825,152 @@ 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}+ Fixpoints * *-************************************************************************+********************************************************************* -}++-- 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 = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idStrictness id)+ -- | (id,_)<- pairs]) $+ loop' n pairs++ 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, sig, rhs') = dmdAnalRhsLetDown (Just bndrs) env let_dmd id rhs+ lazy_fv' = plusVarEnv_C bothDmd lazy_fv lazy_fv1+ env' = extendAnalEnv top_lvl env id sig+ id' = setIdStrictness id sig++ 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")++Note [Trimming a demand to a type]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are two reasons we sometimes trim a demand to match a type.+ 1. GADTs+ 2. Recursive products and widening++More on both below. But the botttom line is: we really don't want to+have a binder whose demand is more deeply-nested than its type+"allows". So in findBndrDmd we call trimToType and findTypeShape to+trim the demand on the binder to a form that matches the type++Now to the reasons. For (1) consider+ f :: a -> Bool+ f x = case ... of+ A g1 -> case (x |> g1) of (p,q) -> ...+ B -> error "urk"++where A,B are the constructors of a GADT. We'll get a U(U,U) demand+on x from the A branch, but that's a stupid demand for x itself, which+has type 'a'. Indeed we get ASSERTs going off (notably in+splitUseProdDmd, #8569).++For (2) consider+ data T = MkT Int T -- A recursive product+ f :: Int -> T -> Int+ f 0 _ = 0+ f _ (MkT n t) = f n t++Here f is lazy in T, but its *usage* is infinite: U(U,U(U,U(U, ...))).+Notice that this happens becuase T is a product type, and is recrusive.+If we are not careful, we'll fail to iterate to a fixpoint in dmdFix,+and bale out entirely, which is inefficient and over-conservative.++Worse, as we discovered in #18304, the size of the usages we compute+can grow /exponentially/, so even 10 iterations costs far too much.+Especially since we then discard the result.++To avoid this we use the same findTypeShape function as for (1), but+arrange that it trims the demand if it encounters the same type constructor+twice (or three times, etc). We use our standard RecTcChecker mechanism+for this -- see GHC.Core.Opt.WorkWrap.Utils.findTypeShape.++This is usually call "widening". We could do it just in dmdFix, but+since are doing this findTypeShape business /anyway/ because of (1),+and it has all the right information to hand, it's extremely+convenient to do it there.+ -} +{- *********************************************************************+* *+ Strictness signatures and types+* *+********************************************************************* -}+ unitDmdType :: DmdEnv -> DmdType unitDmdType dmd_env = DmdType dmd_env [] topDiv @@ -1133,7 +1184,6 @@ , ae_sigs :: SigEnv , ae_virgin :: Bool -- True on first iteration only -- See Note [Initialising strictness]- , ae_rec_tc :: RecTcChecker , ae_fam_envs :: FamInstEnvs } @@ -1157,7 +1207,6 @@ = AE { ae_dflags = dflags , ae_sigs = emptySigEnv , ae_virgin = True- , ae_rec_tc = initRecTc , ae_fam_envs = fam_envs } @@ -1199,7 +1248,7 @@ | otherwise = go dmd_ty bs findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand)--- See Note [Trimming a demand to a type] in GHC.Types.Demand+-- See Note [Trimming a demand to a type] findBndrDmd env arg_of_dfun dmd_ty id = (dmd_ty', dmd') where
compiler/GHC/Core/Opt/Driver.hs view
@@ -18,7 +18,7 @@ import GHC.Core.Opt.CSE ( cseProgram ) import GHC.Core.Rules ( mkRuleBase, unionRuleBase, extendRuleBaseList, ruleCheckProgram, addRuleInfo,- getRules )+ getRules, initRuleOpts ) import GHC.Core.Ppr ( pprCoreBindings, pprCoreExpr ) import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) import GHC.Types.Id.Info@@ -37,7 +37,7 @@ 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.Basic import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Core.Opt.LiberateCase ( liberateCase )@@ -141,8 +141,10 @@ maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase) - maybe_strictness_before phase- = runWhen (phase `elem` strictnessBefore dflags) CoreDoDemand+ maybe_strictness_before (Phase phase)+ | phase `elem` strictnessBefore dflags = CoreDoDemand+ maybe_strictness_before _+ = CoreDoNothing base_mode = SimplMode { sm_phase = panic "base_mode" , sm_names = []@@ -152,20 +154,20 @@ , sm_inline = True , sm_case_case = True } - simpl_phase phase names iter+ simpl_phase phase name iter = CoreDoPasses $ [ maybe_strictness_before phase , CoreDoSimplify iter- (base_mode { sm_phase = Phase phase- , sm_names = names })-- , maybe_rule_check (Phase phase) ]+ (base_mode { sm_phase = phase+ , sm_names = [name] }) - simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter- | phase <- [phases, phases-1 .. 1] ]+ , maybe_rule_check phase ] + -- Run GHC's internal simplification phase, after all rules have run.+ -- See Note [Compiler phases] in GHC.Types.Basic+ simplify name = simpl_phase FinalPhase name max_iter - -- initial simplify: mk specialiser happy: minimum effort please+ -- initial simplify: mk specialiser happy: minimum effort please simpl_gently = CoreDoSimplify max_iter (base_mode { sm_phase = InitialPhase , sm_names = ["Gentle"]@@ -182,7 +184,7 @@ demand_analyser = (CoreDoPasses ( dmd_cpr_ww ++- [simpl_phase 0 ["post-worker-wrapper"] max_iter]+ [simplify "post-worker-wrapper"] )) -- Static forms are moved to the top level with the FloatOut pass.@@ -203,7 +205,7 @@ if opt_level == 0 then [ static_ptrs_float_outwards, CoreDoSimplify max_iter- (base_mode { sm_phase = Phase 0+ (base_mode { sm_phase = FinalPhase , sm_names = ["Non-opt simplification"] }) ] @@ -251,8 +253,10 @@ -- GHC.Iface.Tidy.StaticPtrTable. static_ptrs_float_outwards, - simpl_phases,-+ -- Run the simplier phases 2,1,0 to allow rewrite rules to fire+ CoreDoPasses [ simpl_phase (Phase phase) "main" max_iter+ | phase <- [phases, phases-1 .. 1] ],+ simpl_phase (Phase 0) "main" (max max_iter 3), -- Phase 0: allow all Ids to be inlined now -- This gets foldr inlined before strictness analysis @@ -263,7 +267,6 @@ -- ==> 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@@ -274,9 +277,10 @@ runWhen call_arity $ CoreDoPasses [ CoreDoCallArity- , simpl_phase 0 ["post-call-arity"] max_iter+ , simplify "post-call-arity" ], + -- Strictness analysis runWhen strictness demand_analyser, runWhen exitification CoreDoExitify,@@ -302,24 +306,24 @@ runWhen do_float_in CoreDoFloatInwards, - maybe_rule_check (Phase 0),+ maybe_rule_check FinalPhase, -- 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+ simplify "post-liberate-case" ]), -- 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),+ maybe_rule_check FinalPhase, runWhen late_specialise (CoreDoPasses [ CoreDoSpecialising- , simpl_phase 0 ["post-late-spec"] max_iter]),+ , simplify "post-late-spec"]), -- LiberateCase can yield new CSE opportunities because it peels -- off one layer of a recursive function (concretely, I saw this@@ -328,11 +332,10 @@ runWhen ((liberate_case || spec_constr) && cse) CoreCSE, -- Final clean-up simplification:- simpl_phase 0 ["final"] max_iter,+ simplify "final", runWhen late_dmd_anal $ CoreDoPasses (- dmd_cpr_ww ++- [simpl_phase 0 ["post-late-ww"] max_iter]+ dmd_cpr_ww ++ [simplify "post-late-ww"] ), -- Final run of the demand_analyser, ensures that one-shot thunks are@@ -342,7 +345,7 @@ -- can become /exponentially/ more expensive. See #11731, #12996. runWhen (strictness || late_dmd_anal) CoreDoDemand, - maybe_rule_check (Phase 0)+ maybe_rule_check FinalPhase ] -- Remove 'CoreDoNothing' and flatten 'CoreDoPasses' for clarity.@@ -494,9 +497,10 @@ ; vis_orphs <- getVisibleOrphanMods ; let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn ++ (mg_rules guts)+ ; let ropts = initRuleOpts dflags ; liftIO $ putLogMsg dflags NoReason Err.SevDump noSrcSpan $ withPprStyle defaultDumpStyle- (ruleCheckProgram current_phase pat+ (ruleCheckProgram ropts current_phase pat rule_fn (mg_binds guts)) ; return guts } @@ -906,7 +910,7 @@ x_exported = tick<x> <expression> 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+bindings. Note however 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.
compiler/GHC/Core/Opt/Exitify.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE PatternSynonyms #-}+ module GHC.Core.Opt.Exitify ( exitifyProgram ) where {-@@ -265,7 +267,7 @@ `extendInScopeSet` exit_id_tmpl -- just cosmetics return (uniqAway avoid exit_id_tmpl) where- exit_id_tmpl = mkSysLocal (fsLit "exit") initExitJoinUnique ty+ exit_id_tmpl = mkSysLocal (fsLit "exit") initExitJoinUnique Many ty `asJoinId` join_arity addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId
compiler/GHC/Core/Opt/FloatIn.hs view
@@ -36,7 +36,6 @@ import GHC.Utils.Misc import GHC.Driver.Session import GHC.Utils.Outputable--- import Data.List ( mapAccumL ) import GHC.Types.Basic ( RecFlag(..), isRec ) {-@@ -93,7 +92,7 @@ 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.+GHC.Core.Opt.SetLevels module, which tags things with their level numbers. \item do the full laziness pass (floating lets outwards). \item@@ -206,7 +205,7 @@ | otherwise = (res_ty, extra_fvs) where- (arg_ty, res_ty) = splitFunTy fun_ty+ (_, arg_ty, res_ty) = splitFunTy fun_ty {- Note [Dead bindings] ~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Core/Opt/SetLevels.hs view
@@ -47,9 +47,20 @@ 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.++ This can only work if @wild@ is an unrestricted binder. Indeed, even with the+ extended typing rule (in the linter) for case expressions, if+ case x of wild # 1 { p -> e}+ is well-typed, then+ case x of wild # 1 { p -> e[wild\x] }+ is only well-typed if @e[wild\x] = e@ (that is, if @wild@ is not used in @e@+ at all). In which case, it is, of course, pointless to do the substitution+ anyway. So for a linear binder (and really anything which isn't unrestricted),+ doing this substitution would either produce ill-typed terms or be the+ identity. -} -{-# LANGUAGE CPP, MultiWayIf #-}+{-# LANGUAGE CPP, MultiWayIf, PatternSynonyms #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module GHC.Core.Opt.SetLevels (@@ -73,6 +84,7 @@ , exprIsTopLevelBindable , isExprLevPoly , collectMakeStaticArgs+ , mkLamTypes ) import GHC.Core.Opt.Arity ( exprBotStrictness_maybe ) import GHC.Core.FVs -- all of it@@ -92,8 +104,9 @@ import GHC.Types.Name ( getOccName, mkSystemVarName ) import GHC.Types.Name.Occurrence ( occNameString ) import GHC.Types.Unique ( hasKey )-import GHC.Core.Type ( Type, mkLamTypes, splitTyConApp_maybe, tyCoVarsOfType+import GHC.Core.Type ( Type, splitTyConApp_maybe, tyCoVarsOfType , mightBeUnliftedType, closeOverKindsDSet )+import GHC.Core.Multiplicity ( pattern Many ) import GHC.Types.Basic ( Arity, RecFlag(..), isRec ) import GHC.Core.DataCon ( dataConOrigResTy ) import GHC.Builtin.Types@@ -477,6 +490,7 @@ , 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+ , Many <- idMult case_bndr -- See Note [Floating linear case] = -- 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)@@ -548,6 +562,18 @@ * We only do this with a single-alternative case +Note [Floating linear case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Linear case can't be floated past case branches:+ case u of { p1 -> case[1] v of { C x -> ...x...}; p2 -> ... }+Is well typed, but+ case[1] v of { C x -> case u of { p1 -> ...x...; p2 -> ... }}+Will not be, because of how `x` is used in one alternative but not the other.++It is not easy to float this linear cases precisely, so, instead, we elect, for+the moment, to simply not float linear case.++ Note [Setting levels when floating single-alternative cases] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Handling level-setting when floating a single-alternative case binding@@ -1047,8 +1073,8 @@ 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+"GHC.CoreToStg" and Note [Count coercion arguments in boring contexts] in+"GHC.Core.Unfold"), so we still want to float out variables applied only to coercion arguments. Note [Escaping a value lambda]@@ -1579,6 +1605,7 @@ -> LevelEnv extendCaseBndrEnv le@(LE { le_subst = subst, le_env = id_env }) case_bndr (Var scrut_var)+ | Many <- varMult case_bndr = le { le_subst = extendSubstWithVar subst case_bndr scrut_var , le_env = add_id id_env (case_bndr, scrut_var) } extendCaseBndrEnv env _ _ = env@@ -1682,7 +1709,7 @@ 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+ mkSysLocal (mkFastString str) uniq (idMult bndr) poly_ty where str = "poly_" ++ occNameString (getOccName bndr) poly_ty = mkLamTypes abs_vars (GHC.Core.Subst.substTy subst (idType bndr))@@ -1717,7 +1744,7 @@ = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr")) rhs_ty | otherwise- = mkSysLocal (mkFastString "lvl") uniq rhs_ty+ = mkSysLocal (mkFastString "lvl") uniq Many rhs_ty -- | Clone the binders bound by a single-alternative case. cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var])
compiler/GHC/Core/Opt/Simplify.hs view
@@ -46,21 +46,23 @@ import GHC.Types.Unique ( hasKey ) import GHC.Core.Unfold import GHC.Core.Utils+import GHC.Core.Opt.Arity ( etaExpand ) 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.Core.Rules ( lookupRule, getRules, initRuleOpts )+import GHC.Types.Basic import GHC.Utils.Monad ( mapAccumLM, liftIO ) import GHC.Types.Var ( isTyCoVar )-import GHC.Data.Maybe ( orElse )+import GHC.Data.Maybe ( orElse, fromMaybe ) 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.Core.Multiplicity+import GHC.Core.TyCo.Rep ( TyCoBinder(..) ) import GHC.Builtin.PrimOps ( PrimOp (SeqOp) ) @@ -170,10 +172,10 @@ -- 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+ -- so that if a rewrite 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.+ -- See note [Glomming] in "GHC.Core.Opt.OccurAnal". ; env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0) ; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0 ; freeTick SimplifierDone@@ -318,8 +320,8 @@ -- 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_floats, bndr2, body2) <- {-#SCC "prepareBinding" #-}+ prepareBinding env top_lvl bndr bndr1 body1 ; let body_floats2 = body_floats1 `addLetFloats` let_floats ; (rhs_floats, rhs')@@ -344,7 +346,7 @@ ; return (floats, rhs') } ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats)- top_lvl Nothing bndr bndr1 rhs'+ top_lvl Nothing bndr bndr2 rhs' ; return (rhs_floats `addFloats` bind_float, env2) } --------------------------@@ -358,8 +360,44 @@ 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' }+ ; let mult = contHoleScaling cont+ arity = fromMaybe (pprPanic "simplJoinBind" (ppr new_bndr)) $+ isJoinIdDetails_maybe (idDetails new_bndr)+ new_type = scaleJoinPointType mult arity (varType new_bndr)+ new_bndr' = setIdType new_bndr new_type+ ; completeBind env NotTopLevel (Just cont) old_bndr new_bndr' rhs' } +{-+Note [Scaling join point arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a join point which is linear in its variable, in some context E:++E[join j :: a #-> a+ j x = x+ in case v of+ A -> j 'x'+ B -> <blah>]++The simplifier changes to:++join j :: a #-> a+ j x = E[x]+in case v of+ A -> j 'x'+ B -> E[<blah>]++If E uses its argument in a nonlinear way (e.g. a case['Many]), then+this is wrong: the join point has to change its type to a -> a.+Otherwise, we'd get a linearity error.++See also Note [Return type for join points] and Note [Join points and case-of-case].+-}+scaleJoinPointType :: Mult -> Int -> Type -> Type+scaleJoinPointType mult arity ty | arity == 0 = ty+ | otherwise = case splitPiTy ty of+ (binder, ty') -> mkPiTy (scaleBinder binder) (scaleJoinPointType mult (arity-1) ty')+ where scaleBinder (Anon af t) = Anon af (scaleScaled mult t)+ scaleBinder b@(Named _) = b -------------------------- simplNonRecX :: SimplEnv -> InId -- Old binder; not a JoinId@@ -396,16 +434,16 @@ 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+ do { (prepd_floats, new_bndr, new_rhs)+ <- prepareBinding env top_lvl old_bndr new_bndr new_rhs ; let floats = emptyFloats env `addLetFloats` prepd_floats ; (rhs_floats, rhs2) <-- if doFloatFromRhs NotTopLevel NonRecursive is_strict floats rhs1+ if doFloatFromRhs NotTopLevel NonRecursive is_strict floats new_rhs then -- Add the floats to the main env do { tick LetFloatFromLet- ; return (floats, rhs1) }+ ; return (floats, new_rhs) } else -- Do not float; wrap the floats around the RHS- return (emptyFloats env, wrapFloats floats rhs1)+ return (emptyFloats env, wrapFloats floats new_rhs) ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats) NotTopLevel Nothing@@ -415,12 +453,146 @@ {- ********************************************************************* * *- prepareRhs, makeTrivial+ prepareBinding, prepareRhs, makeTrivial * * ************************************************************************ -Note [prepareRhs]-~~~~~~~~~~~~~~~~~+Note [Cast worker/wrappers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we have a binding+ x = e |> co+we want to do something very similar to worker/wrapper:+ $wx = e+ x = $wx |> co++So now x can be inlined freely. 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+ t = T m+ go 0 = 0+ go n = case t of { T m -> go (n-m) }+ -- This case should optimise++We call this making a cast worker/wrapper, and it's done by prepareBinding.++We need to be careful with inline/noinline pragmas:+ rec { {-# NOINLINE f #-}+ f = (...g...) |> co+ ; g = ...f... }+This is legitimate -- it tells GHC to use f as the loop breaker+rather than g. Now we do the cast thing, to get something like+ rec { $wf = ...g...+ ; f = $wf |> co+ ; g = ...f... }+Where should the NOINLINE pragma go? If we leave it on f we'll get+ rec { $wf = ...g...+ ; {-# NOINLINE f #-}+ f = $wf |> co+ ; g = ...f... }+and that is bad: the whole point is that we want to inline that+cast! We want to transfer the pagma to $wf:+ rec { {-# NOINLINE $wf #-}+ $wf = ...g...+ ; f = $wf |> co+ ; g = ...f... }+It's exactly like worker/wrapper for strictness analysis:+ f is the wrapper and must inline like crazy+ $wf is the worker and must carry f's original pragma+See Note [Worker-wrapper for NOINLINE functions] in+GHC.Core.Opt.WorkWrap.++See #17673, #18093, #18078.++Note [Preserve strictness in cast w/w]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the Note [Cast worker/wrappers] 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 [Cast w/w: unlifted]+~~~~~~~~~~~~~~~~~~~~~~~~~+BUT don't do cast worker/wrapper 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++NOTE: Nowadays we don't use casts for these error functions;+instead, we use (case erorr ... of {}). So I'm not sure+this Note makes much sense any more.+-}++prepareBinding :: SimplEnv -> TopLevelFlag+ -> InId -> OutId -> OutExpr+ -> SimplM (LetFloats, OutId, OutExpr)++prepareBinding env top_lvl old_bndr bndr rhs+ | Cast rhs1 co <- rhs+ -- Try for cast worker/wrapper+ -- See Note [Cast worker/wrappers]+ , not (isStableUnfolding (realIdUnfolding old_bndr))+ -- Don't make a cast w/w if the thing is going to be inlined anyway+ , not (exprIsTrivial rhs1)+ -- Nor if the RHS is trivial; then again it'll be inlined+ , let ty1 = coercionLKind co+ , not (isUnliftedType ty1)+ -- Not if rhs has an unlifted type; see Note [Cast w/w: unlifted]+ = do { (floats, new_id) <- makeTrivialBinding (getMode env) top_lvl+ (getOccFS bndr) worker_info rhs1 ty1+ ; let bndr' = bndr `setInlinePragma` mkCastWrapperInlinePrag (idInlinePragma bndr)+ ; return (floats, bndr', Cast (Var new_id) co) }++ | otherwise+ = do { (floats, rhs') <- prepareRhs (getMode env) top_lvl (getOccFS bndr) rhs+ ; return (floats, bndr, rhs') }+ where+ info = idInfo bndr+ worker_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info+ `setCprInfo` cprInfo info+ `setDemandInfo` demandInfo info+ `setInlinePragInfo` inlinePragInfo info+ `setArityInfo` arityInfo info+ -- We do /not/ want to transfer OccInfo, Rules, Unfolding+ -- Note [Preserve strictness in cast w/w]++mkCastWrapperInlinePrag :: InlinePragma -> InlinePragma+-- See Note [Cast wrappers]+mkCastWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info })+ = InlinePragma { inl_src = SourceText "{-# INLINE"+ , inl_inline = NoUserInline -- See Note [Wrapper NoUserInline]+ , inl_sat = Nothing -- in GHC.Core.Opt.WorkWrap+ , inl_act = wrap_act -- See Note [Wrapper activation]+ , inl_rule = rule_info } -- in GHC.Core.Opt.WorkWrap+ -- RuleMatchInfo is (and must be) unaffected+ where+ -- See Note [Wrapper activation] in GHC.Core.Opt.WorkWrap+ -- But simpler, because we don't need to disable during InitialPhase+ wrap_act | isNeverActive act = activateDuringFinal+ | otherwise = act++{- 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@@ -438,26 +610,16 @@ -} prepareRhs :: SimplMode -> TopLevelFlag- -> FastString -- Base for any new variables- -> IdInfo -- IdInfo for the LHS of this binding+ -> FastString -- Base for any new variables -> OutExpr -> SimplM (LetFloats, OutExpr)--- Transforms a RHS into a better RHS by adding floats+-- Transforms a RHS into a better RHS by ANF'ing args+-- for expandable RHSs: constructors and PAPs -- 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+prepareRhs mode top_lvl occ rhs0 = do { (_is_exp, floats, rhs1) <- go 0 rhs0 ; return (floats, rhs1) } where@@ -480,7 +642,7 @@ 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+ -- 'GHC.Core.Opt.OccurAnal.occAnalApp' go n_val_args (Tick t rhs) -- We want to be able to float bindings past this@@ -501,61 +663,10 @@ 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)+makeTrivialArg mode arg@(ValArg { as_arg = e }) = do { (floats, e') <- makeTrivial mode NotTopLevel (fsLit "arg") e- ; return (floats, ValArg e') }+ ; return (floats, arg { as_arg = e' }) } makeTrivialArg _ arg = return (emptyLetFloats, arg) -- CastBy, TyArg @@ -564,31 +675,34 @@ -> 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+makeTrivial mode top_lvl occ_fs expr | exprIsTrivial expr -- Already trivial || not (bindingOk top_lvl expr expr_ty) -- Cannot trivialise -- See Note [Cannot trivialise] = return (emptyLetFloats, expr) + | Cast expr' co <- expr+ = do { (floats, triv_expr) <- makeTrivial mode top_lvl occ_fs expr'+ ; return (floats, Cast triv_expr co) }+ | 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+ = do { (floats, new_id) <- makeTrivialBinding mode top_lvl occ_fs+ vanillaIdInfo expr expr_ty+ ; return (floats, Var new_id) }+ where+ expr_ty = exprType expr++makeTrivialBinding :: SimplMode -> TopLevelFlag+ -> FastString -- ^ a "friendly name" to build the new binder from+ -> IdInfo+ -> OutExpr -- ^ This expression satisfies the let/app invariant+ -> OutType -- Type of the expression+ -> SimplM (LetFloats, OutId)+makeTrivialBinding mode top_lvl occ_fs info expr expr_ty+ = do { (floats, expr1) <- prepareRhs mode top_lvl occ_fs expr+ ; uniq <- getUniqueM ; let name = mkSystemVarName uniq occ_fs- var = mkLocalIdWithInfo name expr_ty info+ var = mkLocalIdWithInfo name Many expr_ty info -- Now something very like completeBind, -- but without the postInlineUnconditionally part@@ -598,9 +712,7 @@ ; 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+ ; return ( floats `addLetFlts` unitLetFloat bind, final_id ) } bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool -- True iff we can have a binding of this expression at this level@@ -609,15 +721,8 @@ | 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]-~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Cannot trivialise]+~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider: f :: Int -> Addr# @@ -699,7 +804,7 @@ -- Simplify the unfolding ; new_unfolding <- simplLetUnfolding env top_lvl mb_cont old_bndr- final_rhs (idType new_bndr) old_unf+ final_rhs (idType new_bndr) new_arity old_unf ; let final_bndr = addLetBndrInfo new_bndr new_arity is_bot new_unfolding -- See Note [In-scope set as a substitution]@@ -901,8 +1006,8 @@ simplExprF1 :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) -simplExprF1 _ (Type ty) _- = pprPanic "simplExprF: type" (ppr ty)+simplExprF1 _ (Type ty) cont+ = pprPanic "simplExprF: type" (ppr ty <+> text"cont: " <+> ppr cont) -- simplExprF does only with term-valued expressions -- The (Type ty) case is handled separately by simplExpr -- and by the other callers of simplExprF@@ -929,9 +1034,22 @@ ApplyToTy { sc_arg_ty = arg' , sc_hole_ty = hole' , sc_cont = cont } }- _ -> simplExprF env fun $+ _ ->+ -- crucially, these are /lazy/ bindings. They will+ -- be forced only if we need to run contHoleType.+ -- When these are forced, we might get quadratic behavior;+ -- this quadratic blowup could be avoided by drilling down+ -- to the function and getting its multiplicities all at once+ -- (instead of one-at-a-time). But in practice, we have not+ -- observed the quadratic behavior, so this extra entanglement+ -- seems not worthwhile.+ let fun_ty = exprType fun+ (m, _, _) = splitFunTy fun_ty+ in+ simplExprF env fun $ ApplyToVal { sc_arg = arg, sc_env = env- , sc_dup = NoDup, sc_cont = cont }+ , sc_hole_ty = substTy env (exprType fun)+ , sc_dup = NoDup, sc_cont = cont, sc_mult = m } simplExprF1 env expr@(Lam {}) cont = {-#SCC "simplExprF1-Lam" #-}@@ -1037,7 +1155,8 @@ 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+ mult = contHoleScaling cont+ ; (env', join_bndrs') <- simplLamBndrs env (map (scaleVarBy mult) join_bndrs) ; join_body' <- simplExprC env' join_body cont ; return $ mkLams join_bndrs' join_body' } @@ -1235,8 +1354,8 @@ 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+ StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty, sc_mult = m }+ -> rebuildCall env (addValArgTo fun (m, expr) fun_ty ) 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@@ -1274,7 +1393,7 @@ * (f |> co) @t1 @t2 ... @tn x1 .. xm- Here we wil use pushCoTyArg and pushCoValArg successively, which+ Here we will 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@@ -1313,22 +1432,22 @@ where co' = mkTransCo co1 co2 - addCoerce co cont@(ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })+ addCoerce co (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' }) }+ ; return (ApplyToTy { sc_arg_ty = arg_ty'+ , sc_cont = tail'+ , sc_hole_ty = coercionLKind co }) }+ -- NB! As the cast goes past, the+ -- type of the hole changes (#16312) + -- (f |> co) e ===> (f (e |> co1)) |> co2+ -- where co :: (s1->s2) ~ (t1~t2)+ -- co1 :: t1 ~ s1+ -- co2 :: s2 ~ t2 addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se- , sc_dup = dup, sc_cont = tail })+ , sc_dup = dup, sc_cont = tail, sc_mult = m }) | Just (co1, m_co2) <- pushCoValArg co , let new_ty = coercionRKind co1 , not (isTypeLevPoly new_ty) -- Without this check, we get a lev-poly arg@@ -1337,7 +1456,8 @@ = {-#SCC "addCoerce-pushCoValArg" #-} do { tail' <- addCoerceM m_co2 tail ; if isReflCo co1- then return (cont { sc_cont = tail' })+ then return (cont { sc_cont = tail'+ , sc_hole_ty = coercionLKind co }) -- Avoid simplifying if possible; -- See Note [Avoiding exponential behaviour] else do@@ -1350,7 +1470,9 @@ ; return (ApplyToVal { sc_arg = mkCast arg' co1 , sc_env = arg_se' , sc_dup = dup'- , sc_cont = tail' }) } }+ , sc_cont = tail'+ , sc_hole_ty = coercionLKind co+ , sc_mult = m }) } } addCoerce co cont | isReflexiveCo co = return cont -- Having this at the end makes a huge@@ -1429,7 +1551,7 @@ | isId bndr && hasCoreUnfolding old_unf -- Special case = do { (env1, bndr1) <- simplBinder env bndr ; unf' <- simplStableUnfolding env1 NotTopLevel Nothing bndr- old_unf (idType bndr1)+ (idType bndr1) (idArity bndr1) old_unf ; let bndr2 = bndr1 `setIdUnfolding` unf' ; return (modifyInScope env1 bndr2, bndr2) } @@ -1877,36 +1999,39 @@ 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 (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont })+ = rebuildCall env (addTyArgTo info arg_ty hole_ty) cont ---------- The runRW# rule. Do this after absorbing all arguments ------ -- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o--- K[ runRW# rr ty (\s. body) ] --> runRW rr' ty' (\s. K[ body ])+-- K[ runRW# rr ty body ] --> runRW rr' ty' (\s. K[ body s ]) rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args })- (ApplyToVal { sc_arg = arg, sc_env = arg_se, sc_cont = cont })+ (ApplyToVal { sc_arg = arg, sc_env = arg_se, sc_cont = cont, sc_mult = m }) | fun `hasKey` runRWKey , not (contIsStop cont) -- Don't fiddle around if the continuation is boring , [ TyArg {}, TyArg {} ] <- rev_args- = do { s <- newId (fsLit "s") realWorldStatePrimTy+ = do { s <- newId (fsLit "s") Many realWorldStatePrimTy ; let env' = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s]+ ty' = contResultType cont cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s- , sc_env = env', sc_cont = cont }+ , sc_env = env', sc_cont = cont+ , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty'+ , sc_mult = m }+ -- cont' applies to s, then K ; body' <- simplExprC env' arg cont' ; let arg' = Lam s body'- ty' = contResultType cont rr' = getRuntimeRep ty' call' = mkApps (Var fun) [mkTyArg rr', mkTyArg ty', arg'] ; return (emptyFloats env, call') } -rebuildCall env info@(ArgInfo { ai_type = fun_ty, ai_encl = encl_rules+rebuildCall env info@(ArgInfo { ai_encl = encl_rules , ai_strs = str:strs, ai_discs = disc:discs }) (ApplyToVal { sc_arg = arg, sc_env = arg_se- , sc_dup = dup_flag, sc_cont = cont })-+ , sc_dup = dup_flag, sc_hole_ty = fun_ty+ , sc_cont = cont, sc_mult = m }) -- Argument is already simplified | isSimplified dup_flag -- See Note [Avoid redundant simplification]- = rebuildCall env (addValArgTo info' arg) cont+ = rebuildCall env (addValArgTo info' (m, arg) fun_ty) cont -- Strict arguments | str@@ -1914,7 +2039,8 @@ = -- 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 })+ , sc_dup = Simplified, sc_fun_ty = fun_ty+ , sc_cont = cont, sc_mult = m }) -- Note [Shadowing] -- Lazy arguments@@ -1925,7 +2051,7 @@ -- floating a demanded let. = do { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg (mkLazyArgStop arg_ty cci_lazy)- ; rebuildCall env (addValArgTo info' arg') cont }+ ; rebuildCall env (addValArgTo info' (m, arg') fun_ty) cont } where info' = info { ai_strs = strs, ai_discs = discs } arg_ty = funArgTy fun_ty@@ -2056,7 +2182,7 @@ ; return (Just (val_arg, Select dup new_bndr new_alts se cont)) } -} - | Just (rule, rule_rhs) <- lookupRule dflags (getUnfoldingInRuleMatch env)+ | Just (rule, rule_rhs) <- lookupRule ropts (getUnfoldingInRuleMatch env) (activeRule (getMode env)) fn (argInfoAppArgs args) rules -- Fire a rule for the function@@ -2079,6 +2205,7 @@ ; return Nothing } where+ ropts = initRuleOpts dflags dflags = seDynFlags env zapped_env = zapSubstEnv env -- See Note [zapSubstEnv] @@ -2133,9 +2260,11 @@ 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+ seq_id_ty = idType seqId -- forall r a (b::TYPE r). a -> b -> b+ res1_ty = piResultTy seq_id_ty rhs_rep -- forall a (b::TYPE rhs_rep). a -> b -> b+ res2_ty = piResultTy res1_ty scrut_ty -- forall (b::TYPE rhs_rep). scrut_ty -> b -> b+ res3_ty = piResultTy res2_ty rhs_ty -- scrut_ty -> rhs_ty -> rhs_ty+ res4_ty = funResultTy res3_ty -- rhs_ty -> rhs_ty rhs_ty = substTy in_env (exprType rhs) rhs_rep = getRuntimeRep rhs_ty out_args = [ TyArg { as_arg_ty = rhs_rep@@ -2144,9 +2273,26 @@ , as_hole_ty = res1_ty } , TyArg { as_arg_ty = rhs_ty , as_hole_ty = res2_ty }- , ValArg no_cast_scrut]+ , ValArg { as_arg = no_cast_scrut+ , as_hole_ty = res3_ty+ , as_mult = Many } ]+ -- The multiplicity of the scrutiny above is Many because the type+ -- of seq requires that its first argument is unrestricted. The+ -- typing rule of case also guarantees it though. In a more+ -- general world, where the first argument of seq would have+ -- affine multiplicity, then we could use the multiplicity of+ -- the case (held in the case binder) instead. rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs- , sc_env = in_env, sc_cont = cont }+ , sc_env = in_env, sc_cont = cont+ , sc_hole_ty = res4_ty, sc_mult = Many }+ -- The multiplicity in sc_mult above is the+ -- multiplicity of the second argument of seq. Since+ -- seq's type, as it stands, imposes that its second+ -- argument be unrestricted, so is+ -- sc_mult. However, a more precise typing rule,+ -- for seq, would be to have it be linear. In which+ -- case, sc_mult should be 1.+ -- Lazily evaluated, so we don't do most of this drop_casts (Cast e _) = drop_casts e@@ -2499,13 +2645,14 @@ -- as well as when it's an explicit constructor application , let env0 = setInScopeSet env in_scope' = do { tick (KnownBranch case_bndr)+ ; let scaled_wfloats = map scale_float wfloats ; 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+ in simple_rhs env0 scaled_wfloats con_app bs rhs+ Just (_, bs, rhs) -> knownCon env0 scrut scaled_wfloats con ty_args other_args case_bndr bs rhs cont } where@@ -2523,7 +2670,32 @@ GHC.Core.Make.wrapFloats wfloats $ wrapFloats (floats1 `addFloats` floats2) expr' )} + -- This scales case floats by the multiplicity of the continuation hole (see+ -- Note [Scaling in case-of-case]). Let floats are _not_ scaled, because+ -- they are aliases anyway.+ scale_float (GHC.Core.Make.FloatCase scrut case_bndr con vars) =+ let+ scale_id id = scaleVarBy holeScaling id+ in+ GHC.Core.Make.FloatCase scrut (scale_id case_bndr) con (map scale_id vars)+ scale_float f = f + holeScaling = contHoleScaling cont `mkMultMul` idMult case_bndr+ -- We are in the following situation+ -- case[p] case[q] u of { D x -> C v } of { C x -> w }+ -- And we are producing case[??] u of { D x -> w[x\v]}+ --+ -- What should the multiplicity `??` be? In order to preserve the usage of+ -- variables in `u`, it needs to be `pq`.+ --+ -- As an illustration, consider the following+ -- case[Many] case[1] of { C x -> C x } of { C x -> (x, x) }+ -- Where C :: A #-> T is linear+ -- If we were to produce a case[1], like the inner case, we would get+ -- case[1] of { C x -> (x, x) }+ -- Which is ill-typed with respect to linearity. So it needs to be a+ -- case[Many].+ -------------------------------------------------- -- 2. Eliminate the case if scrutinee is evaluated --------------------------------------------------@@ -2604,8 +2776,11 @@ | otherwise = do { (floats, cont') <- mkDupableCaseCont env alts cont ; case_expr <- simplAlts (env `setInScopeFromF` floats)- scrut case_bndr alts cont'+ scrut (scaleIdBy holeScaling case_bndr) (scaleAltsBy holeScaling alts) cont' ; return (floats, case_expr) }+ where+ holeScaling = contHoleScaling cont+ -- Note [Scaling in case-of-case] {- simplCaseBinder checks whether the scrutinee is a variable, v. If so,@@ -2616,7 +2791,7 @@ 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].+"GHC.Core.Opt.OccurAnal" Note [Binder swap]. Note [knownCon occ info] ~~~~~~~~~~~~~~~~~~~~~~~~@@ -2684,6 +2859,39 @@ 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.)++Note [Scaling in case-of-case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When two cases commute, if done naively, the multiplicities will be wrong:++ case (case u of w[1] { (x[1], y[1]) } -> f x y) of w'[Many]+ { (z[Many], t[Many]) -> z+ }++The multiplicities here, are correct, but if I perform a case of case:++ case u of w[1]+ { (x[1], y[1]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z }+ }++This is wrong! Using `f x y` inside a `case … of w'[Many]` means that `x` and+`y` must have multiplicities `Many` not `1`! The correct solution is to make+all the `1`-s be `Many`-s instead:++ case u of w[Many]+ { (x[Many], y[Many]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z }+ }++In general, when commuting two cases, the rule has to be:++ case (case … of x[p] {…}) of y[q] { … }+ ===> case … of x[p*q] { … case … of y[q] { … } }++This is materialised, in the simplifier, by the fact that every time we simplify+case alternatives with a continuation (the surrounded case (or more!)), we must+scale the entire case we are simplifying, by a scaling factor which can be+computed in the continuation (with function `contHoleScaling`). -} simplAlts :: SimplEnv@@ -2726,7 +2934,7 @@ -- 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+ = do { case_bndr2 <- newId (fsLit "nt") Many ty2 ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing env2 = extendIdSubst env case_bndr rhs ; return (env2, scrut `Cast` co, case_bndr2) }@@ -2848,11 +3056,12 @@ env1 = addBinderUnfolding env case_bndr con_app_unf -- See Note [Add unfolding for scrutinee]- env2 = case scrut of+ env2 | Many <- idMult case_bndr = 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+ | otherwise = env1 ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app]) ; return env2 }@@ -2897,8 +3106,8 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 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.+because the binder-swap in OccurAnal has got rid of all such occurrences+See Note [Binder swap] in "GHC.Core.Opt.OccurAnal". BUT it is still VERY IMPORTANT to add a suitable unfolding for a variable scrutinee, in simplAlt. Here's why@@ -2927,7 +3136,10 @@ So instead we add the unfolding x -> Just a, and x -> Nothing in the respective RHSs. +Since this transformation is tantamount to a binder swap, the same caveat as in+Note [Suppressing binder-swaps on linear case] in OccurAnal apply. + ************************************************************************ * * \subsection{Known constructor}@@ -3136,7 +3348,8 @@ , sc_dup = OkToDup , sc_cont = mkBoringStop res_ty } ) } -mkDupableCont env (StrictArg { sc_fun = info, sc_cci = cci, sc_cont = cont })+mkDupableCont env (StrictArg { sc_fun = info, sc_cci = cci+ , sc_cont = cont, sc_fun_ty = fun_ty, sc_mult = m }) -- See Note [Duplicating StrictArg] -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable = do { (floats1, cont') <- mkDupableCont env cont@@ -3144,8 +3357,10 @@ (ai_args info) ; return ( foldl' addLetFloats floats1 floats_s , StrictArg { sc_fun = info { ai_args = args' }- , sc_cci = cci , sc_cont = cont'+ , sc_cci = cci+ , sc_fun_ty = fun_ty+ , sc_mult = m , sc_dup = OkToDup} ) } mkDupableCont env (ApplyToTy { sc_cont = cont@@ -3155,7 +3370,8 @@ , 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 })+ , sc_env = se, sc_cont = cont+ , sc_hole_ty = hole_ty, sc_mult = mult }) = -- e.g. [...hole...] (...arg...) -- ==> -- let a = ...arg...@@ -3173,7 +3389,8 @@ -- 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' }) }+ , sc_dup = OkToDup, sc_cont = cont'+ , sc_hole_ty = hole_ty, sc_mult = mult }) } mkDupableCont env (Select { sc_bndr = case_bndr, sc_alts = alts , sc_env = se, sc_cont = cont })@@ -3189,8 +3406,10 @@ -- 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+ ; let cont_scaling = contHoleScaling cont+ -- See Note [Scaling in case-of-case]+ ; (alt_env', case_bndr') <- simplBinder alt_env (scaleIdBy cont_scaling case_bndr)+ ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' alt_cont) (scaleAltsBy cont_scaling 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@@ -3517,11 +3736,11 @@ simplLetUnfolding :: SimplEnv-> TopLevelFlag -> MaybeJoinCont -> InId- -> OutExpr -> OutType+ -> OutExpr -> OutType -> Arity -> Unfolding -> SimplM Unfolding-simplLetUnfolding env top_lvl cont_mb id new_rhs rhs_ty unf+simplLetUnfolding env top_lvl cont_mb id new_rhs rhs_ty arity unf | isStableUnfolding unf- = simplStableUnfolding env top_lvl cont_mb id unf rhs_ty+ = simplStableUnfolding env top_lvl cont_mb id rhs_ty arity unf | isExitJoinId id = return noUnfolding -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify | otherwise@@ -3547,9 +3766,10 @@ simplStableUnfolding :: SimplEnv -> TopLevelFlag -> MaybeJoinCont -- Just k => a join point with continuation k -> InId- -> Unfolding -> OutType -> SimplM Unfolding+ -> OutType -> Arity -> Unfolding+ ->SimplM Unfolding -- Note [Setting the new unfolding]-simplStableUnfolding env top_lvl mb_cont id unf rhs_ty+simplStableUnfolding env top_lvl mb_cont id rhs_ty id_arity unf = case unf of NoUnfolding -> return unf BootUnfolding -> return unf@@ -3562,9 +3782,13 @@ 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)+ -> do { expr' <- case mb_cont of+ Just cont -> -- Binder is a join point+ -- See Note [Rules and unfolding for join points]+ simplJoinRhs unf_env id expr cont+ Nothing -> -- Binder is not a join point+ do { expr' <- simplExprC unf_env expr (mkBoringStop rhs_ty)+ ; return (eta_expand expr') } ; case guide of UnfWhen { ug_arity = arity , ug_unsat_ok = sat_ok@@ -3601,7 +3825,41 @@ unf_env = updMode (updModeForStableUnfoldings act) env -- See Note [Simplifying inside stable unfoldings] in GHC.Core.Opt.Simplify.Utils -{-+ -- See Note [Eta-expand stable unfoldings]+ eta_expand expr+ | not eta_on = expr+ | exprIsTrivial expr = expr+ | otherwise = etaExpand id_arity expr+ eta_on = sm_eta_expand (getMode env)++{- Note [Eta-expand stable unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For INLINE/INLINABLE things (which get stable unfoldings) there's a danger+of getting+ f :: Int -> Int -> Int -> Blah+ [ Arity = 3 -- Good arity+ , Unf=Stable (\xy. blah) -- Less good arity, only 2+ f = \pqr. e++This can happen because f's RHS is optimised more vigorously than+its stable unfolding. Now suppose we have a call+ g = f x+Because f has arity=3, g will have arity=2. But if we inline f (using+its stable unfolding) g's arity will reduce to 1, because <blah>+hasn't been optimised yet. This happened in the 'parsec' library,+for Text.Pasec.Char.string.++Generally, if we know that 'f' has arity N, it seems sensible to+eta-expand the stable unfolding to arity N too. Simple and consistent.++Wrinkles+* Don't eta-expand a trivial expr, else each pass will eta-reduce it,+ and then eta-expand again. See Note [Do not eta-expand trivial expressions]+ in GHC.Core.Opt.Simplify.Utils.+* Don't eta-expand join points; see Note [Do not eta-expand join points]+ in GHC.Core.Opt.Simplify.Utils. We uphold this because the join-point+ case (mb_cont = Just _) doesn't use eta_expand.+ Note [Force bottoming field] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We need to force bottoming, or the new unfolding holds@@ -3637,7 +3895,7 @@ 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+See Note [Forming Rec groups] in "GHC.Core.Opt.OccurAnal" -} addBndrRules :: SimplEnv -> InBndr -> OutBndr
compiler/GHC/Core/Opt/Simplify/Env.hs view
@@ -276,7 +276,7 @@ -- The top level "enclosing CC" is "SUBSUMED". init_in_scope :: InScopeSet-init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder unitTy))+init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder Many unitTy)) -- See Note [WildCard binders] {-@@ -724,6 +724,8 @@ 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.++See also Note [Scaling join point arguments]. -} simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])@@ -852,7 +854,7 @@ {- Note [Arity robustness] ~~~~~~~~~~~~~~~~~~~~~~~-We *do* transfer the arity from from the in_id of a let binding to the+We *do* transfer the arity 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)....@@ -927,12 +929,15 @@ ------------------ 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+ | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env)+ || no_free_vars = id- | otherwise = Id.setIdType id (Type.substTy (TCvSubst in_scope tv_env cv_env) old_ty)+ | otherwise = Id.updateIdTypeAndMult (Type.substTyUnchecked subst) id -- 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+ no_free_vars = noFreeVarsOfType old_ty && noFreeVarsOfType old_w+ subst = TCvSubst in_scope tv_env cv_env old_ty = idType id+ old_w = varMult id
compiler/GHC/Core/Opt/Simplify/Monad.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE PatternSynonyms #-} {- (c) The AQUA Project, Glasgow University, 1993-1998 @@ -26,9 +27,10 @@ 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.Type ( Type, Mult ) import GHC.Core.FamInstEnv ( FamInstEnv ) import GHC.Core ( RuleEnv(..) )+import GHC.Core.Utils ( mkLamTypes ) import GHC.Types.Unique.Supply import GHC.Driver.Session import GHC.Core.Opt.Monad@@ -40,6 +42,7 @@ import GHC.Utils.Panic (throwGhcExceptionIO, GhcException (..)) import GHC.Types.Basic ( IntWithInf, treatZeroAsInf, mkIntWithInf ) import Control.Monad ( ap )+import GHC.Core.Multiplicity ( pattern Many ) {- ************************************************************************@@ -180,9 +183,9 @@ 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)+newId :: FastString -> Mult -> Type -> SimplM Id+newId fs w ty = do uniq <- getUniqueM+ return (mkSysLocalOrCoVar fs uniq w ty) newJoinId :: [Var] -> Type -> SimplM Id newJoinId bndrs body_ty@@ -196,7 +199,7 @@ id_info = vanillaIdInfo `setArityInfo` arity -- `setOccInfo` strongLoopBreaker - ; return (mkLocalVar details name join_id_ty id_info) }+ ; return (mkLocalVar details name Many join_id_ty id_info) } {- ************************************************************************
compiler/GHC/Core/Opt/Simplify/Utils.hs view
@@ -19,7 +19,7 @@ -- The continuation type SimplCont(..), DupFlag(..), StaticEnv, isSimplified, contIsStop,- contIsDupable, contResultType, contHoleType,+ contIsDupable, contResultType, contHoleType, contHoleScaling, contIsTrivial, contArgs, countArgs, mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg,@@ -62,6 +62,7 @@ import GHC.Core.Type hiding( substTy ) import GHC.Core.Coercion hiding( substCo ) import GHC.Core.DataCon ( dataConWorkId, isNullaryRepDataCon )+import GHC.Core.Multiplicity import GHC.Utils.Misc import GHC.Data.OrdList ( isNilOL ) import GHC.Utils.Monad@@ -118,15 +119,18 @@ SimplCont | ApplyToVal -- (ApplyToVal arg K)[e] = K[ e arg ]- { sc_dup :: DupFlag -- See Note [DupFlag invariants]+ { sc_dup :: DupFlag -- See Note [DupFlag invariants]+ , sc_hole_ty :: OutType -- Type of the function, presumably (forall a. blah)+ -- See Note [The hole type in ApplyToTy/Val] , sc_arg :: InExpr -- The argument, , sc_env :: StaticEnv -- see Note [StaticEnv invariant]- , sc_cont :: SimplCont }+ , sc_cont :: SimplCont+ , sc_mult :: Mult } | 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]+ -- See Note [The hole type in ApplyToTy/Val] , sc_cont :: SimplCont } | Select -- (Select alts K)[e] = K[ case e of alts ]@@ -151,7 +155,11 @@ , 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 }+ , sc_fun_ty :: OutType -- Type of the function (f e1 .. en),+ -- presumably (arg_ty -> res_ty)+ -- where res_ty is expected by sc_cont+ , sc_cont :: SimplCont+ , sc_mult :: Mult } | TickIt -- (TickIt t K)[e] = K[ tick t e ] (Tickish Id) -- Tick tickish <hole>@@ -199,7 +207,7 @@ (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)+ (and hence no need to re-simplify) -} instance Outputable DupFlag where@@ -213,9 +221,10 @@ 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 (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont, sc_hole_ty = hole_ty })+ = (hang (text "ApplyToVal" <+> ppr dup <+> text "hole" <+> ppr hole_ty)+ 2 (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 })@@ -254,8 +263,6 @@ 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@@ -271,37 +278,37 @@ } data ArgSpec- = ValArg OutExpr -- Apply to this (coercion or value); c.f. ApplyToVal+ = ValArg { as_mult :: Mult+ , as_arg :: OutExpr -- Apply to this (coercion or value); c.f. ApplyToVal+ , as_hole_ty :: OutType } -- Type of the function (presumably t1 -> t2) | 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 (ValArg { as_mult = mult, as_arg = arg }) = text "ValArg" <+> ppr mult <+> ppr arg 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) }+addValArgTo :: ArgInfo -> (Mult, OutExpr) -> OutType -> ArgInfo+addValArgTo ai (w, arg) hole_ty = ai { ai_args = arg_spec : ai_args ai+ , ai_rules = decRules (ai_rules ai) }+ where+ arg_spec = ValArg { as_arg = arg, as_hole_ty = hole_ty, as_mult = w } -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) }+addTyArgTo :: ArgInfo -> OutType -> OutType -> ArgInfo+addTyArgTo ai arg_ty hole_ty = ai { ai_args = arg_spec : ai_args ai+ , 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 }+ arg_spec = TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty } addCastTo :: ArgInfo -> OutCoercion -> ArgInfo-addCastTo ai co = ai { ai_args = CastBy co : ai_args ai- , ai_type = coercionRKind co }+addCastTo ai co = ai { ai_args = CastBy co : ai_args ai } argInfoAppArgs :: [ArgSpec] -> [OutExpr] argInfoAppArgs [] = [] argInfoAppArgs (CastBy {} : _) = [] -- Stop at a cast-argInfoAppArgs (ValArg e : as) = e : argInfoAppArgs as+argInfoAppArgs (ValArg { as_arg = arg } : as) = arg : argInfoAppArgs as argInfoAppArgs (TyArg { as_arg_ty = ty } : as) = Type ty : argInfoAppArgs as pushSimplifiedArgs :: SimplEnv -> [ArgSpec] -> SimplCont -> SimplCont@@ -310,7 +317,9 @@ = 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 }+ ValArg { as_arg = arg, as_hole_ty = hole_ty, as_mult = w }+ -> ApplyToVal { sc_arg = arg, sc_env = env, sc_dup = Simplified+ , sc_hole_ty = hole_ty, sc_cont = rest, sc_mult = w } CastBy c -> CastIt c rest where rest = pushSimplifiedArgs env args k@@ -323,7 +332,7 @@ = go rev_args where go [] = Var fun- go (ValArg a : as) = go as `App` a+ go (ValArg { as_arg = arg } : as) = go as `App` arg go (TyArg { as_arg_ty = ty } : as) = go as `App` Type ty go (CastBy co : as) = mkCast (go as) co @@ -409,14 +418,33 @@ 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 (StrictArg { sc_fun_ty = ty, sc_mult = _m }) = funArgTy ty 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 (ApplyToVal { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy/Val] contHoleType (Select { sc_dup = d, sc_bndr = b, sc_env = se }) = perhapsSubstTy d se (idType b) ++-- Computes the multiplicity scaling factor at the hole. That is, in (case [] of+-- x ::(p) _ { … }) (respectively for arguments of functions), the scaling+-- factor is p. And in E[G[]], the scaling factor is the product of the scaling+-- factor of E and that of G.+--+-- The scaling factor at the hole of E[] is used to determine how a binder+-- should be scaled if it commutes with E. This appears, in particular, in the+-- case-of-case transformation.+contHoleScaling :: SimplCont -> Mult+contHoleScaling (Stop _ _) = One+contHoleScaling (CastIt _ k) = contHoleScaling k+contHoleScaling (StrictBind { sc_bndr = id, sc_cont = k }) =+ (idMult id) `mkMultMul` contHoleScaling k+contHoleScaling (StrictArg { sc_mult = w, sc_cont = k }) =+ w `mkMultMul` contHoleScaling k+contHoleScaling (Select { sc_bndr = id, sc_cont = k }) =+ (idMult id) `mkMultMul` contHoleScaling k+contHoleScaling (ApplyToTy { sc_cont = k }) = contHoleScaling k+contHoleScaling (ApplyToVal { sc_cont = k }) = contHoleScaling k+contHoleScaling (TickIt _ k) = contHoleScaling k ------------------- countArgs :: SimplCont -> Int -- Count all arguments, including types, coercions, and other values@@ -458,13 +486,13 @@ 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+ = ArgInfo { ai_fun = fun, ai_args = [] , 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+ = ArgInfo { ai_fun = fun, ai_args = [] , ai_rules = fun_rules , ai_encl = interestingArgContext rules call_cont , ai_strs = arg_stricts@@ -519,7 +547,7 @@ 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+ | 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@@ -1091,7 +1119,7 @@ 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+Conclusion: inline top level things gaily until FinalPhase (the last phase), at which point don't. Note [pre/postInlineUnconditionally in gentle mode]@@ -1214,23 +1242,21 @@ -- 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.+ early_phase = sm_phase mode /= FinalPhase+ -- 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. {- ************************************************************************@@ -1549,7 +1575,7 @@ return (new_arity, is_bot, new_rhs) } where try_expand- | exprIsTrivial rhs+ | exprIsTrivial rhs -- See Note [Do not eta-expand trivial expressions] = return (exprArity rhs, False, rhs) | sm_eta_expand mode -- Provided eta-expansion is on@@ -1593,9 +1619,17 @@ as far as the programmer is concerned, it's not applied to two arguments! +Note [Do not eta-expand trivial expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Do not eta-expand a trivial RHS like+ f = g+If we eta expand do+ f = \x. g x+we'll just eta-reduce again, and so on; so the+simplifier never terminates.+ 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@@ -1770,7 +1804,7 @@ = 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) }+ ; return (float_binds, GHC.Core.Subst.substExpr subst body) } where is_top_lvl = isTopLevel top_lvl main_tv_set = mkVarSet main_tvs@@ -1784,7 +1818,7 @@ 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+ rhs' = GHC.Core.Subst.substExpr subst rhs -- tvs_here: see Note [Which type variables to abstract over] tvs_here = scopedSort $@@ -1797,8 +1831,7 @@ ; 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 ]+ , let rhs' = GHC.Core.Subst.substExpr subst' rhs ] ; return (subst', Rec poly_pairs) } where (ids,rhss) = unzip prs@@ -1823,7 +1856,7 @@ ; let poly_name = setNameUnique (idName var) uniq -- Keep same name poly_ty = mkInfForAllTys tvs_here (idType var) -- But new type of course poly_id = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in GHC.Types.Id- mkLocalId poly_name poly_ty+ mkLocalId poly_name (idMult var) 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!@@ -1945,7 +1978,10 @@ -- 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+ (yes2, alts2) = refineDefaultAlt us (idMult case_bndr') tc tys idcs1 alts1+ -- the multiplicity on case_bndr's is the multiplicity of the+ -- case expression The newly introduced patterns in+ -- refineDefaultAlt must be scaled by this multiplicity (yes3, idcs3, alts3) = combineIdenticalAlts idcs1 alts2 -- "idcs" stands for "impossible default data constructors" -- i.e. the constructors that can't match the default case@@ -2176,7 +2212,7 @@ _ -> True , gopt Opt_CaseFolding dflags , Just (scrut', tx_con, mk_orig) <- caseRules (targetPlatform dflags) scrut- = do { bndr' <- newId (fsLit "lwild") (exprType scrut')+ = do { bndr' <- newId (fsLit "lwild") Many (exprType scrut') ; alts' <- mapMaybeM (tx_alt tx_con mk_orig bndr') alts -- mapMaybeM: discard unreachable alternatives@@ -2227,7 +2263,7 @@ = -- 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+ ; let (ex_tvs, arg_ids) = dataConRepInstPat us (idMult new_bndr) dc (tyConAppArgs (idType new_bndr)) ; return (ex_tvs ++ arg_ids) } mk_new_bndrs _ _ = return []
compiler/GHC/Core/Opt/SpecConstr.hs view
@@ -32,6 +32,7 @@ import GHC.Core.Rules import GHC.Core.Type hiding ( substTy ) import GHC.Core.TyCon ( tyConName )+import GHC.Core.Multiplicity import GHC.Types.Id import GHC.Core.Ppr ( pprParendExpr ) import GHC.Core.Make ( mkImpossibleExpr )@@ -752,7 +753,7 @@ After optimisation, including SpecConstr, we get: f :: Int# -> Int -> Int- f x y = case case remInt# x 2# of+ f x y = case remInt# x 2# of __DEFAULT -> case x of __DEFAULT -> f (+# wild_Xp 1#) (I# x) 1000000# -> ...@@ -859,7 +860,7 @@ lookupHowBound env id = lookupVarEnv (sc_how_bound env) id scSubstId :: ScEnv -> Id -> CoreExpr-scSubstId env v = lookupIdSubst (text "scSubstId") (sc_subst env) v+scSubstId env v = lookupIdSubst (sc_subst env) v scSubstTy :: ScEnv -> Type -> Type scSubstTy env ty = substTy (sc_subst env) ty@@ -969,7 +970,7 @@ forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var forceSpecFunTy :: ScEnv -> Type -> Bool-forceSpecFunTy env = any (forceSpecArgTy env) . fst . splitFunTys+forceSpecFunTy env = any (forceSpecArgTy env) . map scaledThing . fst . splitFunTys forceSpecArgTy :: ScEnv -> Type -> Bool forceSpecArgTy env ty@@ -1675,7 +1676,7 @@ spec_join_arity | isJoinId fn = Just (length spec_lam_args) | otherwise = Nothing- spec_id = mkLocalId spec_name+ spec_id = mkLocalId spec_name Many (mkLamTypes spec_lam_args body_ty) -- See Note [Transfer strictness] `setIdStrictness` spec_str@@ -1760,8 +1761,8 @@ 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+in FinalPhase; after all, currently, the specConstr transformation is+only run after the simplifier has reached FinalPhase, but that meant that specialisations didn't fire inside wrappers; see test simplCore/should_compile/spec-inline. @@ -2052,7 +2053,7 @@ -- 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)+ sanitise id = updateIdTypeAndMult expandTypeSynonyms id -- See Note [Free type variables of the qvar types] -- Bad coercion variables: see Note [SpecConstr and casts]@@ -2110,15 +2111,15 @@ 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+ -- See Note [Matching lets] in "GHC.Core.Rules" -- 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+{- Disabled; see Note [Matching cases] in "GHC.Core.Rules" argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ- | exprOkForSpeculation scrut -- See Note [Matching cases] in Rule.hhs+ | exprOkForSpeculation scrut -- See Note [Matching cases] in "GHC.Core.Rules" = argToPat env in_scope val_env rhs arg_occ -} @@ -2212,7 +2213,7 @@ wildCardPat :: Type -> UniqSM (Bool, CoreArg) wildCardPat ty = do { uniq <- getUniqueM- ; let id = mkSysLocalOrCoVar (fsLit "sc") uniq ty+ ; let id = mkSysLocalOrCoVar (fsLit "sc") uniq Many ty ; return (False, varToCoreExpr id) } argsToPats :: ScEnv -> InScopeSet -> ValueEnv
compiler/GHC/Core/Opt/Specialise.hs view
@@ -5,6 +5,7 @@ -} {-# LANGUAGE CPP #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ViewPatterns #-} @@ -18,6 +19,7 @@ import GHC.Types.Id import GHC.Tc.Utils.TcType hiding( substTy ) import GHC.Core.Type hiding( substTy, extendTvSubstList )+import GHC.Core.Multiplicity import GHC.Core.Predicate import GHC.Unit.Module( Module, HasModule(..) ) import GHC.Core.Coercion( Coercion )@@ -1006,7 +1008,7 @@ , text "interesting =" <+> ppr interesting ]) specVar :: SpecEnv -> Id -> CoreExpr-specVar env v = Core.lookupIdSubst (text "specVar") (se_subst env) v+specVar env v = Core.lookupIdSubst (se_subst env) v specExpr :: SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails) @@ -1130,9 +1132,10 @@ sc_args' = filter is_flt_sc_arg args' clone_me bndr = do { uniq <- getUniqueM- ; return (mkUserLocalOrCoVar occ uniq ty loc) }+ ; return (mkUserLocalOrCoVar occ uniq wght ty loc) } where name = idName bndr+ wght = idMult bndr ty = idType bndr occ = nameOccName name loc = getSrcSpan name@@ -1372,9 +1375,9 @@ 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)+ already_covered :: RuleOpts -> [CoreRule] -> [CoreExpr] -> Bool+ already_covered ropts new_rules args -- Note [Specialisations already covered]+ = isJust (lookupRule ropts (in_scope, realIdUnfolding) (const True) fn args (new_rules ++ existing_rules)) -- NB: we look both in the new_rules (generated by this invocation@@ -1406,8 +1409,9 @@ -- return () ; dflags <- getDynFlags+ ; let ropts = initRuleOpts dflags ; if not useful -- No useful specialisation- || already_covered dflags rules_acc rule_lhs_args+ || already_covered ropts rules_acc rule_lhs_args then return spec_acc else do { -- Run the specialiser on the specialised RHS@@ -1423,7 +1427,7 @@ (spec_bndrs, spec_rhs, spec_fn_ty) | add_void_arg = ( voidPrimId : spec_bndrs1 , Lam voidArgId spec_rhs1- , mkVisFunTy voidPrimTy spec_fn_ty1)+ , mkVisFunTyMany voidPrimTy spec_fn_ty1) | otherwise = (spec_bndrs1, spec_rhs1, spec_fn_ty1) join_arity_decr = length rule_lhs_args - length spec_bndrs@@ -1478,7 +1482,7 @@ (spec_inl_prag, spec_unf) | not is_local && isStrongLoopBreaker (idOccInfo fn) = (neverInlinePragma, noUnfolding)- -- See Note [Specialising imported functions] in OccurAnal+ -- See Note [Specialising imported functions] in "GHC.Core.Opt.OccurAnal" | InlinePragma { inl_inline = Inlinable } <- inl_prag = (inl_prag { inl_inline = NoUserInline }, noUnfolding)@@ -2504,7 +2508,7 @@ -- 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+ | type_determines_value (scaledThing pred) , interestingDict env arg -- Note [Interesting dictionary arguments] = SpecDict arg | otherwise = UnspecArg@@ -2890,7 +2894,7 @@ newDictBndr env b = do { uniq <- getUniqueM ; let n = idName b ty' = substTy env (idType b)- ; return (mkUserLocal (nameOccName n) uniq ty' (getSrcSpan n)) }+ ; return (mkUserLocal (nameOccName n) uniq Many ty' (getSrcSpan n)) } newSpecIdSM :: Id -> Type -> Maybe JoinArity -> SpecM Id -- Give the new Id a similar occurrence name to the old one@@ -2898,7 +2902,7 @@ = do { uniq <- getUniqueM ; let name = idName old_id new_occ = mkSpecOcc (nameOccName name)- new_id = mkUserLocal new_occ uniq new_ty (getSrcSpan name)+ new_id = mkUserLocal new_occ uniq Many new_ty (getSrcSpan name) `asJoinId_maybe` join_arity_maybe ; return new_id }
compiler/GHC/Core/Opt/StaticArgs.hs view
@@ -48,7 +48,7 @@ essential to make this work well! -} -{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, PatternSynonyms #-} module GHC.Core.Opt.StaticArgs ( doStaticArgs ) where import GHC.Prelude@@ -420,12 +420,13 @@ 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 = mkSysLocal (fsLit "sat_worker") uniq Many (exprType rec_body) -- rec_body_bndr = sat_worker -- See Note [Shadow binding]; make a SysLocal shadow_bndr = mkSysLocal (occNameFS (getOccName binder)) (idUnique binder)+ Many (exprType shadow_rhs) isStaticValue :: Staticness App -> Bool
compiler/GHC/Core/Opt/WorkWrap.hs view
@@ -245,8 +245,8 @@ (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:+demonstrates what happens when we promise to w/w a (NOINLINE) leaf+function, but fail to deliver: data C = C Int# Int# @@ -421,19 +421,27 @@ In module Bar we want to give specialisations a chance to fire before inlining f's wrapper. + 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.+ 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++ - If the user said NOINLINE, inline the wrapper only after+ phase 0, the last user-visible phase. That means that all+ rules will have had a chance to fire.++ What phase is after phase 0? Answer: FinalPhase, that's the reason it+ exists. NB: Similar to InitialPhase, users can't write INLINE[Final] f;+ it's syntactically illegal.+ - 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -575,8 +583,8 @@ 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+ NoInline -> inl_act fn_inl_prag+ _ -> inl_act wrap_prag work_prag = InlinePragma { inl_src = SourceText "{-# INLINE" , inl_inline = fn_inline_spec@@ -626,19 +634,7 @@ | 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_prag = mkStrWrapperInlinePrag fn_inl_prag wrap_id = fn_id `setIdUnfolding` mkWwInlineRule dflags wrap_rhs arity `setInlinePragma` wrap_prag `setIdOccInfo` noOccInfo@@ -655,8 +651,6 @@ 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@@ -673,6 +667,25 @@ work_cpr_info | isJoinId fn_id = cpr | otherwise = topCpr ++mkStrWrapperInlinePrag :: InlinePragma -> InlinePragma+mkStrWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info })+ = InlinePragma { inl_src = SourceText "{-# INLINE"+ , inl_inline = NoUserInline -- See Note [Wrapper NoUserInline]+ , inl_sat = Nothing+ , inl_act = wrap_act+ , inl_rule = rule_info } -- RuleMatchInfo is (and must be) unaffected+ where+ wrap_act = case act of -- See Note [Wrapper activation]+ NeverActive -> activateDuringFinal+ FinalActive -> act+ ActiveAfter {} -> act+ ActiveBefore {} -> activateAfterInitial+ AlwaysActive -> activateAfterInitial+ -- For the last two cases, see (4) in Note [Wrapper activation]+ -- NB: the (ActiveBefore n) isn't quite right. We really want+ -- it to be active *after* Initial but *before* n. We don't have+ -- a way to say that, alas. {- Note [Demand on the worker]
compiler/GHC/Core/Opt/WorkWrap/Utils.hs view
@@ -34,6 +34,7 @@ import GHC.Types.Var.Env ( mkInScopeSet ) import GHC.Types.Var.Set ( VarSet ) import GHC.Core.Type+import GHC.Core.Multiplicity import GHC.Core.Predicate ( isClassPred ) import GHC.Types.RepType ( isVoidTy, typePrimRep ) import GHC.Core.Coercion@@ -185,7 +186,7 @@ -- Note [Do not split void functions] only_one_void_argument | [d] <- demands- , Just (arg_ty1, _) <- splitFunTy_maybe fun_ty+ , Just (_, arg_ty1, _) <- splitFunTy_maybe fun_ty , isAbsDmd d && isVoidTy arg_ty1 = True | otherwise@@ -231,7 +232,7 @@ 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-and the number arguments before w/w.+and the number arguments before w/w (see #18122). It is a bit all or nothing, consider @@ -248,6 +249,7 @@ 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. ************************************************************************@@ -420,9 +422,9 @@ = return ([], id, id, substTy subst fun_ty) | (dmd:demands') <- demands- , Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty+ , Just (mult, arg_ty, fun_ty') <- splitFunTy_maybe fun_ty = do { uniq <- getUniqueM- ; let arg_ty' = substTy subst arg_ty+ ; let arg_ty' = substScaledTy subst (Scaled mult 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'@@ -471,9 +473,9 @@ 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+mk_wrap_arg :: Unique -> Scaled Type -> Demand -> Id+mk_wrap_arg uniq (Scaled w ty) dmd+ = mkSysLocalOrCoVar (fsLit "w") uniq w ty `setIdDemandInfo` dmd {- Note [Freshen WW arguments]@@ -567,7 +569,7 @@ 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.+as-yet-un-filled-in unitState files. -} ----------------------@@ -634,10 +636,12 @@ , dcac_arg_tys = inst_con_arg_tys , dcac_co = co } = do { (uniq1:uniqs) <- getUniquesM- ; let -- See Note [Add demands for strict constructors]+ ; let scale = scaleScaled (idMult arg)+ scaled_inst_con_arg_tys = map (\(t,s) -> (scale t, s)) inst_con_arg_tys+ -- 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+ unpk_args = zipWith3 mk_ww_arg uniqs scaled_inst_con_arg_tys cs'+ unbox_fn = mkUnpackCase (Var arg) co (idMult arg) uniq1 data_con unpk_args arg_no_unf = zapStableUnfolding arg -- See Note [Zap unfolding when beta-reducing]@@ -948,7 +952,7 @@ = DataConAppContext { dcac_dc :: !DataCon , dcac_tys :: ![Type]- , dcac_arg_tys :: ![(Type, StrictnessMark)]+ , dcac_arg_tys :: ![(Scaled Type, StrictnessMark)] , dcac_co :: !Coercion } @@ -989,33 +993,65 @@ , let con = cons `getNth` (con_tag - fIRST_TAG) arg_tys = dataConInstArgTys con tc_args strict_marks = dataConRepStrictness con+ , all isLinear arg_tys+ -- Deactivates CPR worker/wrapper splits on constructors with non-linear+ -- arguments, for the moment, because they require unboxed tuple with variable+ -- multiplicity fields. = Just DataConAppContext { dcac_dc = con , dcac_tys = tc_args , dcac_arg_tys = zipEqual "dspt" arg_tys strict_marks , dcac_co = co } deepSplitCprType_maybe _ _ _ = Nothing +isLinear :: Scaled a -> Bool+isLinear (Scaled w _ ) =+ case w of+ One -> True+ _ -> False+ 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+-- See Note [Trimming a demand to a type] in GHC.Core.Opt.DmdAnal 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)+ = go (setRecTcMaxBound 2 initRecTc) ty+ -- You might think this bound of 2 is low, but actually+ -- I think even 1 would be fine. This only bites for recursive+ -- product types, which are rare, and we really don't want+ -- to look deep into such products -- see #18034+ where+ go rec_tc ty+ | Just (_, _, res) <- splitFunTy_maybe ty+ = TsFun (go rec_tc res) - | Just (_, res) <- splitFunTy_maybe ty- = TsFun (findTypeShape fam_envs res)+ | Just (tc, tc_args) <- splitTyConApp_maybe ty+ = go_tc rec_tc tc tc_args - | Just (_, ty') <- splitForAllTy_maybe ty- = findTypeShape fam_envs ty'+ | Just (_, ty') <- splitForAllTy_maybe ty+ = go rec_tc ty' - | Just (_, ty') <- topNormaliseType_maybe fam_envs ty- = findTypeShape fam_envs ty'+ | otherwise+ = TsUnk - | otherwise- = TsUnk+ go_tc rec_tc tc tc_args+ | Just (_, rhs, _) <- topReduceTyFamApp_maybe fam_envs tc tc_args+ = go rec_tc rhs + | Just con <- isDataProductTyCon_maybe tc+ , Just rec_tc <- if isTupleTyCon tc+ then Just rec_tc+ else checkRecTc rec_tc tc+ -- We treat tuples specially because they can't cause loops.+ -- Maybe we should do so in checkRecTc.+ = TsProd (map (go rec_tc . scaledThing) (dataConInstArgTys con tc_args))++ | Just (ty', _) <- instNewTyCon_maybe tc tc_args+ , Just rec_tc <- checkRecTc rec_tc tc+ = go rec_tc ty'++ | otherwise+ = TsUnk+ {- ************************************************************************ * *@@ -1062,8 +1098,9 @@ 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+ , isUnliftedType (scaledThing arg_ty1)+ , isLinear arg_ty1+ -- Special case when there is a single result of unlifted, linear, type -- -- Wrapper: case (..call worker..) of x -> C x -- Worker: case ( ..body.. ) of C x -> x@@ -1073,42 +1110,50 @@ ; return ( True , \ wkr_call -> mkDefaultCase wkr_call arg con_app- , \ body -> mkUnpackCase body co work_uniq data_con [arg] (varToCoreExpr arg)+ , \ body -> mkUnpackCase body co One work_uniq data_con [arg] (varToCoreExpr arg) -- varToCoreExpr important here: arg can be a coercion -- Lacking this caused #10658- , arg_ty1 ) }+ , scaledThing 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 #)+ --+ -- Remark on linearity: in both the case of the wrapper and the worker,+ -- we build a linear case. All the multiplicity information is kept in+ -- the constructors (both C and (#, #)). In particular (#,#) is+ -- parametrised by the multiplicity of its fields. Specifically, in this+ -- instance, the multiplicity of the fields of (#,#) is chosen to be the+ -- same as those of C. = do { (work_uniq : wild_uniq : uniqs) <- getUniquesM- ; let wrap_wild = mk_ww_local wild_uniq (ubx_tup_ty,MarkedStrict)+ ; let wrap_wild = mk_ww_local wild_uniq (linear 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)+ ubx_tup_app = mkCoreUbxTup (map (scaledThing . 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+ , \ body -> mkUnpackCase body co One work_uniq data_con args ubx_tup_app , ubx_tup_ty ) } -mkUnpackCase :: CoreExpr -> Coercion -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr+mkUnpackCase :: CoreExpr -> Coercion -> Mult -> 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+mkUnpackCase (Tick tickish e) co mult uniq con args body -- See Note [Profiling and unpacking]+ = Tick tickish (mkUnpackCase e co mult uniq con args body)+mkUnpackCase scrut co mult 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)-+ bndr = mk_ww_local uniq (Scaled mult (exprType casted_scrut), MarkedStrict)+ -- An unpacking case can always be chosen linear, because the variables+ -- are always passed to a constructor. This limits the {- Note [non-algebraic or open body type warning] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1244,10 +1289,10 @@ -- See also Note [Unique Determinism] in GHC.Types.Unique unlifted_rhs = mkTyApps (Lit rubbishLit) [arg_ty] -mk_ww_local :: Unique -> (Type, StrictnessMark) -> Id+mk_ww_local :: Unique -> (Scaled 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)+mk_ww_local uniq (Scaled w ty,str) = setCaseBndrEvald str $- mkSysLocalOrCoVar (fsLit "ww") uniq ty+ mkSysLocalOrCoVar (fsLit "ww") uniq w ty
compiler/GHC/Core/Ppr/TyThing.hs view
@@ -166,7 +166,7 @@ -- We pretty-print 'TyThing' via 'IfaceDecl' -- See Note [Pretty-printing TyThings] pprTyThing ss ty_thing- = pprIfaceDecl ss' (tyThingToIfaceDecl ty_thing)+ = sdocWithDynFlags (\dflags -> pprIfaceDecl ss' (tyThingToIfaceDecl dflags ty_thing)) where ss' = case ss_how_much ss of ShowHeader (AltPpr Nothing) -> ss { ss_how_much = ShowHeader ppr' }
compiler/GHC/Core/Rules.hs view
@@ -1,7 +1,7 @@ {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -\section[CoreRules]{Transformation rules}+\section[CoreRules]{Rewrite rules} -} {-# LANGUAGE CPP #-}@@ -23,7 +23,7 @@ -- * Misc. CoreRule helpers rulesOfBinds, getRules, pprRulesForUser, - lookupRule, mkRule, roughTopNames+ lookupRule, mkRule, roughTopNames, initRuleOpts ) where #include "GhclibHsVersions.h"@@ -202,7 +202,7 @@ -- 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+-- (if that name is a GlobalId: see "GHC.Types.Var#globalvslocal"), or -- -- 2. The 'TyCon' if the expression is a 'Type' --@@ -375,14 +375,14 @@ -- 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+lookupRule :: RuleOpts -> 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+lookupRule opts in_scope is_active fn args rules = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $ case go [] rules of [] -> Nothing@@ -399,7 +399,7 @@ 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+ | Just e <- matchRule opts in_scope is_active fn args' rough_args r = go ((r,mkTicks ticks e):ms) rs | otherwise = -- pprTrace "match failed" (ppr r $$ ppr args $$@@ -478,7 +478,7 @@ -} -------------------------------------matchRule :: DynFlags -> InScopeEnv -> (Activation -> Bool)+matchRule :: RuleOpts -> InScopeEnv -> (Activation -> Bool) -> Id -> [CoreExpr] -> [Maybe Name] -> CoreRule -> Maybe CoreExpr @@ -504,15 +504,10 @@ -- 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+matchRule opts 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+ = case match_fn opts rule_env fn args of Nothing -> Nothing Just expr -> Just expr @@ -523,6 +518,16 @@ | ruleCantMatch tpl_tops rough_args = Nothing | otherwise = matchN in_scope rule_name tpl_vars tpl_args args rhs ++-- | Initialize RuleOpts from DynFlags+initRuleOpts :: DynFlags -> RuleOpts+initRuleOpts dflags = RuleOpts+ { roPlatform = targetPlatform dflags+ , roNumConstantFolding = gopt Opt_NumConstantFolding dflags+ , roExcessRationalPrecision = gopt Opt_ExcessPrecision dflags+ }++ --------------------------------------- matchN :: InScopeEnv -> RuleName -> [Var] -> [CoreExpr]@@ -917,7 +922,7 @@ Var v2 | v1' == rnOccR rn_env v2 -> Just subst - | Var v2' <- lookupIdSubst (text "match_var") flt_env v2+ | Var v2' <- lookupIdSubst flt_env v2 , v1' == v2' -> Just subst @@ -965,7 +970,7 @@ 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+ | otherwise = substExpr flt_env e2 id_subst' = extendVarEnv (rs_id_subst subst) v1' e2' -- No further renaming to do on e2',@@ -1155,12 +1160,13 @@ -- | Report partial matches for rules beginning with the specified -- string for the purposes of error reporting-ruleCheckProgram :: CompilerPhase -- ^ Rule activation test+ruleCheckProgram :: RuleOpts -- ^ Rule options+ -> 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+ruleCheckProgram ropts phase rule_pat rules binds | isEmptyBag results = text "Rule check results: no rule application sites" | otherwise@@ -1173,7 +1179,9 @@ , rc_id_unf = idUnfolding -- Not quite right -- Should use activeUnfolding , rc_pattern = rule_pat- , rc_rules = rules }+ , rc_rules = rules+ , rc_ropts = ropts+ } results = unionManyBags (map (ruleCheckBind env) binds) line = text (replicate 20 '-') @@ -1181,7 +1189,8 @@ rc_is_active :: Activation -> Bool, rc_id_unf :: IdUnfoldingFun, rc_pattern :: String,- rc_rules :: Id -> [CoreRule]+ rc_rules :: Id -> [CoreRule],+ rc_ropts :: RuleOpts } ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc@@ -1228,16 +1237,15 @@ i_args = args `zip` [1::Int ..] rough_args = map roughTopName args - check_rule rule = sdocWithDynFlags $ \dflags ->- rule_herald rule <> colon <+> rule_info dflags rule+ check_rule rule = rule_herald rule <> colon <+> rule_info (rc_ropts env) 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)+ rule_info opts rule+ | Just _ <- matchRule opts (emptyInScopeSet, rc_id_unf env) noBlackList fn args rough_args rule = text "matches (which is very peculiar!)"
compiler/GHC/Core/Tidy.hs view
@@ -149,8 +149,9 @@ -- though we could extract it from the Id -- ty' = tidyType env (idType id)+ mult' = tidyType env (idMult id) name' = mkInternalName (idUnique id) occ' noSrcSpan- id' = mkLocalIdWithInfo name' ty' new_info+ id' = mkLocalIdWithInfo name' mult' ty' new_info var_env' = extendVarEnv var_env id id' -- Note [Tidy IdInfo]@@ -174,9 +175,10 @@ = case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> let ty' = tidyType env (idType id)+ mult' = tidyType env (idMult id) name' = mkInternalName (idUnique id) occ' noSrcSpan details = idDetails id- id' = mkLocalVar details name' ty' new_info+ id' = mkLocalVar details name' mult' ty' new_info var_env' = extendVarEnv var_env id id' -- Note [Tidy IdInfo]
compiler/GHC/CoreToByteCode.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_GHC -fprof-auto-top #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} --@@ -28,7 +29,6 @@ import GHC.Types.Name import GHC.Types.Id.Make import GHC.Types.Id-import GHC.Types.Var ( updateVarType ) import GHC.Types.ForeignCall import GHC.Driver.Types import GHC.Core.Utils@@ -625,7 +625,7 @@ -- Here (k n) :: a :: Type r, so we don't know if it's lifted -- or not; but that should be fine provided we add that void arg. - id <- newId (mkVisFunTy realWorldStatePrimTy ty)+ id <- newId (mkVisFunTyMany realWorldStatePrimTy ty) st <- newId realWorldStatePrimTy let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyDVarSet, exp))) (emptyDVarSet, (AnnApp (emptyDVarSet, AnnVar id)@@ -708,7 +708,7 @@ protectNNLJoinPointId :: Id -> Id protectNNLJoinPointId x = ASSERT( isNNLJoinPoint x )- updateVarType (voidPrimTy `mkVisFunTy`) x+ updateIdTypeButNotMult (voidPrimTy `mkVisFunTyMany`) x {- Ticked Expressions@@ -1091,8 +1091,8 @@ | otherwise = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG)) my_discr (LitAlt l, _, _)- = case l of LitNumber LitNumInt i _ -> DiscrI (fromInteger i)- LitNumber LitNumWord w _ -> DiscrW (fromInteger w)+ = case l of LitNumber LitNumInt i -> DiscrI (fromInteger i)+ LitNumber LitNumWord w -> DiscrW (fromInteger w) LitFloat r -> DiscrF (fromRational r) LitDouble r -> DiscrD (fromRational r) LitChar i -> DiscrI (ord i)@@ -1455,7 +1455,7 @@ , isDataTyCon tyc = map (getName . dataConWorkId) (tyConDataCons tyc) -- NOTE: use the worker name, not the source name of- -- the DataCon. See DataCon.hs for details.+ -- the DataCon. See "GHC.Core.DataCon" for details. | otherwise = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty) @@ -1619,14 +1619,14 @@ wordsToBytes platform size_words) case lit of- LitLabel _ _ _ -> code N- LitFloat _ -> code F- LitDouble _ -> code D- LitChar _ -> code N- LitNullAddr -> code N- LitString _ -> code N- LitRubbish -> code N- LitNumber nt _ _ -> case nt of+ LitLabel _ _ _ -> code N+ LitFloat _ -> code F+ LitDouble _ -> code D+ LitChar _ -> code N+ LitNullAddr -> code N+ LitString _ -> code N+ LitRubbish -> code N+ LitNumber nt _ -> case nt of LitNumInt -> code N LitNumWord -> code N LitNumInt64 -> code L@@ -2060,7 +2060,7 @@ newId :: Type -> BcM Id newId ty = do uniq <- newUnique- return $ mkSysLocal tickFS uniq ty+ return $ mkSysLocal tickFS uniq Many ty tickFS :: FastString tickFS = fsLit "ticked"
compiler/GHC/CoreToStg.hs view
@@ -372,8 +372,8 @@ -- No LitInteger's or LitNatural's should be left by the time this is called. -- CorePrep should have converted them all to a real core representation.-coreToStgExpr (Lit (LitNumber LitNumInteger _ _)) = panic "coreToStgExpr: LitInteger"-coreToStgExpr (Lit (LitNumber LitNumNatural _ _)) = panic "coreToStgExpr: LitNatural"+coreToStgExpr (Lit (LitNumber LitNumInteger _)) = panic "coreToStgExpr: LitInteger"+coreToStgExpr (Lit (LitNumber LitNumNatural _)) = panic "coreToStgExpr: LitNatural" coreToStgExpr (Lit l) = return (StgLit l) coreToStgExpr (App (Lit LitRubbish) _some_unlifted_type) -- We lower 'LitRubbish' to @()@ here, which is much easier than doing it in@@ -435,7 +435,10 @@ let stg = StgCase scrut2 bndr (mkStgAltType bndr alts) alts2 -- See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce case scrut2 of- StgApp id [] | idName id == unsafeEqualityProofName ->+ StgApp id [] | idName id == unsafeEqualityProofName+ , isDeadBinder bndr ->+ -- We can only discard the case if the case-binder is dead+ -- It usually is, but see #18227 case alts2 of [(_, [_co], rhs)] -> return rhs
compiler/GHC/CoreToStg/Prep.hs view
@@ -9,11 +9,12 @@ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -module GHC.CoreToStg.Prep (- corePrepPgm, corePrepExpr, cvtLitInteger, cvtLitNatural,- lookupMkIntegerName, lookupIntegerSDataConName,- lookupMkNaturalName, lookupNaturalSDataConName- ) where+module GHC.CoreToStg.Prep+ ( corePrepPgm+ , corePrepExpr+ , mkConvertNumLiteral+ )+where #include "GhclibHsVersions.h" @@ -59,7 +60,8 @@ import GHC.Types.Name ( NamedThing(..), nameSrcSpan, isInternalName ) import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc ) import Data.Bits-import GHC.Utils.Monad ( mapAccumLM )+import GHC.Utils.Monad ( mapAccumLM )+import Data.List ( unfoldr ) import Control.Monad import GHC.Types.CostCentre ( CostCentre, ccFromThisModule ) import qualified Data.Set as S@@ -115,19 +117,14 @@ 9. Replace (lazy e) by e. See Note [lazyId magic] in GHC.Types.Id.Make Also replace (noinline e) by e. -10. Convert (LitInteger i t) into the core representation- for the Integer i. Normally this uses mkInteger, but if- we are using the integer-gmp implementation then there is a- special case where we use the S# constructor for Integers that- are in the range of Int.--11. Same for LitNatural.+10. Convert bignum literals (LitNatural and LitInteger) into their+ core representation. -12. Uphold tick consistency while doing this: We move ticks out of+11. Uphold tick consistency while doing this: We move ticks out of (non-type) applications where we can, and make sure that we annotate according to scoping rules when floating. -13. Collect cost centres (including cost centres in unfoldings) if we're in+12. Collect cost centres (including cost centres in unfoldings) if we're in profiling mode. We have to do this here beucase we won't have unfoldings after this pass (see `zapUnfolding` and Note [Drop unfoldings and rules]. @@ -182,7 +179,7 @@ (text "CorePrep"<+>brackets (ppr this_mod)) (const ()) $ do us <- mkSplitUniqSupply 's'- initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env+ initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env let cost_centres | WayProf `S.member` ways dflags@@ -204,14 +201,15 @@ where dflags = hsc_dflags hsc_env -corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr-corePrepExpr dflags hsc_env expr =+corePrepExpr :: HscEnv -> CoreExpr -> IO CoreExpr+corePrepExpr hsc_env expr = do+ let dflags = hsc_dflags hsc_env withTiming dflags (text "CorePrep [expr]") (const ()) $ do- us <- mkSplitUniqSupply 's'- initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env- let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr)- dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr)- return new_expr+ us <- mkSplitUniqSupply 's'+ initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env+ let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr)+ dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr)+ return new_expr corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats -- Note [Floating out of top level bindings]@@ -571,12 +569,10 @@ cpeRhsE _env expr@(Type {}) = return (emptyFloats, expr) cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr)-cpeRhsE env (Lit (LitNumber LitNumInteger i _))- = cpeRhsE env (cvtLitInteger (targetPlatform (cpe_dynFlags env)) (getMkIntegerId env)- (cpe_integerSDataCon env) i)-cpeRhsE env (Lit (LitNumber LitNumNatural i _))- = cpeRhsE env (cvtLitNatural (targetPlatform (cpe_dynFlags env)) (getMkNaturalId env)- (cpe_naturalSDataCon env) i)+cpeRhsE env expr@(Lit (LitNumber nt i))+ = case cpe_convertNumLit env nt i of+ Nothing -> return (emptyFloats, expr)+ Just e -> cpeRhsE env e cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr) cpeRhsE env expr@(Var {}) = cpeApp env expr cpeRhsE env expr@(App {}) = cpeApp env expr@@ -650,46 +646,6 @@ ; rhs' <- cpeBodyNF env2 rhs ; return (con, bs', rhs') } -cvtLitInteger :: Platform -> Id -> Maybe DataCon -> Integer -> CoreExpr--- Here we convert a literal Integer to the low-level--- representation. Exactly how we do this depends on the--- library that implements Integer. If it's GMP we--- use the S# data constructor for small literals.--- See Note [Integer literals] in GHC.Types.Literal-cvtLitInteger platform _ (Just sdatacon) i- | platformInIntRange platform i -- Special case for small integers- = mkConApp sdatacon [Lit (mkLitInt platform i)]--cvtLitInteger platform mk_integer _ i- = mkApps (Var mk_integer) [isNonNegative, ints]- where isNonNegative = if i < 0 then mkConApp falseDataCon []- else mkConApp trueDataCon []- ints = mkListExpr intTy (f (abs i))- f 0 = []- f x = let low = x .&. mask- high = x `shiftR` bits- in mkConApp intDataCon [Lit (mkLitInt platform low)] : f high- bits = 31- mask = 2 ^ bits - 1--cvtLitNatural :: Platform -> Id -> Maybe DataCon -> Integer -> CoreExpr--- Here we convert a literal Natural to the low-level--- representation.--- See Note [Natural literals] in GHC.Types.Literal-cvtLitNatural platform _ (Just sdatacon) i- | platformInWordRange platform i -- Special case for small naturals- = mkConApp sdatacon [Lit (mkLitWord platform i)]--cvtLitNatural platform mk_natural _ i- = mkApps (Var mk_natural) [words]- where words = mkListExpr wordTy (f i)- f 0 = []- f x = let low = x .&. mask- high = x `shiftR` bits- in mkConApp wordDataCon [Lit (mkLitWord platform low)] : f high- bits = 32- mask = 2 ^ bits - 1- -- --------------------------------------------------------------------------- -- CpeBody: produces a result satisfying CpeBody -- ---------------------------------------------------------------------------@@ -916,7 +872,7 @@ (_ : ss_rest, True) -> (topDmd, ss_rest) (ss1 : ss_rest, False) -> (ss1, ss_rest) ([], _) -> (topDmd, [])- (arg_ty, res_ty) =+ (_, arg_ty, res_ty) = case splitFunTy_maybe fun_ty of Just as -> as Nothing -> pprPanic "cpeBody" (ppr fun_ty $$ ppr expr)@@ -1095,15 +1051,6 @@ | otherwise = exprIsTrivial e -isUnsafeEqualityProof :: CoreExpr -> Bool--- See (U3) and (U4) in--- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce-isUnsafeEqualityProof e- | Var v `App` Type _ `App` Type _ `App` Type _ <- e- = idName v == unsafeEqualityProofName- | otherwise- = False- -- This is where we arrange that a non-trivial argument is let-bound cpeArg :: CorePrepEnv -> Demand -> CoreArg -> Type -> UniqSM (Floats, CpeArg)@@ -1261,7 +1208,7 @@ ok _ _ = False -- We can't eta reduce something which must be saturated.- ok_to_eta_reduce (Var f) = not (hasNoBinding f)+ ok_to_eta_reduce (Var f) = not (hasNoBinding f) && not (isLinearType (idType f)) ok_to_eta_reduce _ = False -- Safe. ToDo: generalise @@ -1533,73 +1480,107 @@ -- 3. To let us inline trivial RHSs of non top-level let-bindings, -- see Note [lazyId magic], Note [Inlining in CorePrep] -- and Note [CorePrep inlines trivial CoreExpr not Id] (#12076)- , cpe_mkIntegerId :: Id- , cpe_mkNaturalId :: Id- , cpe_integerSDataCon :: Maybe DataCon- , cpe_naturalSDataCon :: Maybe DataCon++ , cpe_convertNumLit :: LitNumType -> Integer -> Maybe CoreExpr+ -- ^ Convert some numeric literals (Integer, Natural) into their+ -- final Core form } -lookupMkIntegerName :: DynFlags -> HscEnv -> IO Id-lookupMkIntegerName dflags hsc_env- = guardIntegerUse dflags $ liftM tyThingId $- lookupGlobal hsc_env mkIntegerName+-- | Create a function that converts Bignum literals into their final CoreExpr+mkConvertNumLiteral+ :: HscEnv+ -> IO (LitNumType -> Integer -> Maybe CoreExpr)+mkConvertNumLiteral hsc_env = do+ let+ dflags = hsc_dflags hsc_env+ platform = targetPlatform dflags+ guardBignum act+ | homeUnitId dflags == primUnitId+ = return $ panic "Bignum literals are not supported in ghc-prim"+ | homeUnitId dflags == bignumUnitId+ = return $ panic "Bignum literals are not supported in ghc-bignum"+ | otherwise = act -lookupMkNaturalName :: DynFlags -> HscEnv -> IO Id-lookupMkNaturalName dflags hsc_env- = guardNaturalUse dflags $ liftM tyThingId $- lookupGlobal hsc_env mkNaturalName+ lookupBignumId n = guardBignum (tyThingId <$> lookupGlobal hsc_env n) --- 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) $- lookupGlobal hsc_env integerSDataConName- IntegerSimple -> return Nothing+ -- The lookup is done here but the failure (panic) is reported lazily when we+ -- try to access the `bigNatFromWordList` function.+ --+ -- If we ever get built-in ByteArray# literals, we could avoid the lookup by+ -- directly using the Integer/Natural wired-in constructors for big numbers. -lookupNaturalSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon)-lookupNaturalSDataConName dflags hsc_env = case integerLibrary dflags of- IntegerGMP -> guardNaturalUse dflags $ liftM (Just . tyThingDataCon) $- lookupGlobal hsc_env naturalSDataConName- IntegerSimple -> return Nothing+ bignatFromWordListId <- lookupBignumId bignatFromWordListName --- | Helper for 'lookupMkIntegerName', 'lookupIntegerSDataConName'-guardIntegerUse :: DynFlags -> IO a -> IO a-guardIntegerUse dflags act- | thisPackage dflags == primUnitId- = return $ panic "Can't use Integer in ghc-prim"- | thisPackage dflags == integerUnitId- = return $ panic "Can't use Integer in integer-*"- | otherwise = act+ let+ convertNumLit nt i = case nt of+ LitNumInteger -> Just (convertInteger i)+ LitNumNatural -> Just (convertNatural i)+ _ -> Nothing --- | Helper for 'lookupMkNaturalName', 'lookupNaturalSDataConName'------ Just like we can't use Integer literals in `integer-*`, we can't use Natural--- literals in `base`. If we do, we get interface loading error for GHC.Natural.-guardNaturalUse :: DynFlags -> IO a -> IO a-guardNaturalUse dflags act- | thisPackage dflags == primUnitId- = return $ panic "Can't use Natural in ghc-prim"- | thisPackage dflags == integerUnitId- = return $ panic "Can't use Natural in integer-*"- | thisPackage dflags == baseUnitId- = return $ panic "Can't use Natural in base"- | otherwise = act+ convertInteger i+ | platformInIntRange platform i -- fit in a Int#+ = mkConApp integerISDataCon [Lit (mkLitInt platform i)] -mkInitialCorePrepEnv :: DynFlags -> HscEnv -> IO CorePrepEnv-mkInitialCorePrepEnv dflags hsc_env- = do mkIntegerId <- lookupMkIntegerName dflags hsc_env- mkNaturalId <- lookupMkNaturalName dflags hsc_env- integerSDataCon <- lookupIntegerSDataConName dflags hsc_env- naturalSDataCon <- lookupNaturalSDataConName dflags hsc_env- return $ CPE {- cpe_dynFlags = dflags,- cpe_env = emptyVarEnv,- cpe_mkIntegerId = mkIntegerId,- cpe_mkNaturalId = mkNaturalId,- cpe_integerSDataCon = integerSDataCon,- cpe_naturalSDataCon = naturalSDataCon- }+ | otherwise -- build a BigNat and embed into IN or IP+ = let con = if i > 0 then integerIPDataCon else integerINDataCon+ in mkBigNum con (convertBignatPrim (abs i)) + convertNatural i+ | platformInWordRange platform i -- fit in a Word#+ = mkConApp naturalNSDataCon [Lit (mkLitWord platform i)]++ | otherwise --build a BigNat and embed into NB+ = mkBigNum naturalNBDataCon (convertBignatPrim i)++ -- we can't simply generate:+ --+ -- NB (bigNatFromWordList# [W# 10, W# 20])+ --+ -- using `mkConApp` because it isn't in ANF form. Instead we generate:+ --+ -- case bigNatFromWordList# [W# 10, W# 20] of ba { DEFAULT -> NB ba }+ --+ -- via `mkCoreApps`++ mkBigNum con ba = mkCoreApps (Var (dataConWorkId con)) [ba]++ convertBignatPrim i =+ let+ target = targetPlatform dflags++ -- ByteArray# literals aren't supported (yet). Were they supported,+ -- we would use them directly. We would need to handle+ -- wordSize/endianness conversion between host and target+ -- wordSize = platformWordSize platform+ -- byteOrder = platformByteOrder platform++ -- For now we build a list of Words and we produce+ -- `bigNatFromWordList# list_of_words`++ words = mkListExpr wordTy (reverse (unfoldr f i))+ where+ f 0 = Nothing+ f x = let low = x .&. mask+ high = x `shiftR` bits+ in Just (mkConApp wordDataCon [Lit (mkLitWord platform low)], high)+ bits = platformWordSizeInBits target+ mask = 2 ^ bits - 1++ in mkApps (Var bignatFromWordListId) [words]+++ return convertNumLit+++mkInitialCorePrepEnv :: HscEnv -> IO CorePrepEnv+mkInitialCorePrepEnv hsc_env = do+ convertNumLit <- mkConvertNumLiteral hsc_env+ return $ CPE+ { cpe_dynFlags = hsc_dflags hsc_env+ , cpe_env = emptyVarEnv+ , cpe_convertNumLit = convertNumLit+ }+ extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv extendCorePrepEnv cpe id id' = cpe { cpe_env = extendVarEnv (cpe_env cpe) id (Var id') }@@ -1619,12 +1600,6 @@ Nothing -> Var id Just exp -> exp -getMkIntegerId :: CorePrepEnv -> Id-getMkIntegerId = cpe_mkIntegerId--getMkNaturalId :: CorePrepEnv -> Id-getMkNaturalId = cpe_mkNaturalId- ------------------------------------------------------------------------------ -- Cloning binders -- ---------------------------------------------------------------------------@@ -1696,7 +1671,7 @@ newVar ty = seqType ty `seq` do uniq <- getUniqueM- return (mkSysLocalOrCoVar (fsLit "sat") uniq ty)+ return (mkSysLocalOrCoVar (fsLit "sat") uniq Many ty) ------------------------------------------------------------------------------
compiler/GHC/Data/Bitmap.hs view
@@ -76,7 +76,7 @@ Note [Strictness when building Bitmaps] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -One of the places where @Bitmap@ is used is in in building Static Reference+One of the places where @Bitmap@ is used is in building Static Reference Tables (SRTs) (in @GHC.Cmm.Info.Build.procpointSRT@). In #7450 it was noticed that some test cases (particularly those whose C-- have large numbers of CAFs) produced large quantities of allocations from this function.
compiler/GHC/Driver/Backpack.hs view
@@ -86,7 +86,7 @@ POk _ pkgname_bkp -> do -- OK, so we have an LHsUnit PackageName, but we want an -- LHsUnit HsComponentId. So let's rename it.- let pkgstate = pkgState dflags+ let pkgstate = unitState dflags let bkp = renameHsUnits pkgstate (bkpPackageNameMap pkgstate pkgname_bkp) pkgname_bkp initBkpM src_filename bkp $ forM_ (zip [1..] bkp) $ \(i, lunit) -> do@@ -171,9 +171,12 @@ hscTarget = case session_type of TcSession -> HscNothing _ -> hscTarget dflags,- thisUnitIdInsts_ = Just insts,- thisComponentId_ = Just cid,- thisUnitId =+ homeUnitInstantiations = insts,+ -- if we don't have any instantiation, don't+ -- fill `homeUnitInstanceOfId` as it makes no+ -- sense (we're not instantiating anything)+ homeUnitInstanceOfId = if null insts then Nothing else Just cid,+ homeUnitId = case session_type of TcSession -> newUnitId cid Nothing -- No hash passed if no instances@@ -191,7 +194,8 @@ importPaths = [], -- Synthesized the flags packageFlags = packageFlags dflags ++ map (\(uid0, rn) ->- let uid = unwireUnit dflags (improveUnit (unitInfoMap (pkgState dflags)) $ renameHoleUnit (pkgState dflags) (listToUFM insts) uid0)+ let state = unitState dflags+ uid = unwireUnit state (improveUnit state $ renameHoleUnit state (listToUFM insts) uid0) in ExposePackage (showSDoc dflags (text "-unit-id" <+> ppr uid <+> ppr rn))@@ -199,8 +203,7 @@ } )) $ do dflags <- getSessionDynFlags -- pprTrace "flags" (ppr insts <> ppr deps) $ return ()- -- Calls initPackages- _ <- setSessionDynFlags dflags+ setSessionDynFlags dflags -- calls initUnits do_this withBkpExeSession :: [(Unit, ModRenaming)] -> BkpM a -> BkpM a@@ -259,7 +262,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 (renameHoleUnit (pkgState dflags) hsubst) raw_deps+ deps0 = map (renameHoleUnit (unitState 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@@ -272,7 +275,7 @@ dflags <- getDynFlags -- IMPROVE IT- let deps = map (improveUnit (unitInfoMap (pkgState dflags))) deps0+ let deps = map (improveUnit (unitState dflags)) deps0 mb_old_eps <- case session of TcSession -> fmap Just getEpsGhc@@ -302,6 +305,7 @@ $ home_mod_infos getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) obj_files = concatMap getOfiles linkables+ state = unitState (hsc_dflags hsc_env) let compat_fs = unitIdFS (indefUnit cid) compat_pn = PackageName compat_fs@@ -312,7 +316,7 @@ unitPackageId = PackageId compat_fs, unitPackageName = compat_pn, unitPackageVersion = makeVersion [],- unitId = toUnitId (thisPackage dflags),+ unitId = toUnitId (homeUnit dflags), unitComponentName = Nothing, unitInstanceOf = cid, unitInstantiations = insts,@@ -326,7 +330,7 @@ -- really used for anything, so we leave it -- blank for now. TcSession -> []- _ -> map (toUnitId . unwireUnit dflags)+ _ -> map (toUnitId . unwireUnit state) $ deps ++ [ moduleUnit mod | (_, mod) <- insts , not (isHoleModule mod) ],@@ -363,7 +367,7 @@ compileExe :: LHsUnit HsComponentId -> BkpM () compileExe lunit = do- msgUnitId mainUnitId+ msgUnitId mainUnit let deps_w_rns = hsunitDeps False (unLoc lunit) deps = map fst deps_w_rns -- no renaming necessary@@ -376,30 +380,29 @@ ok <- load' LoadAllTargets (Just msg) mod_graph when (failed ok) (liftIO $ exitWith (ExitFailure 1)) --- | Register a new virtual package database containing a single unit+-- | Register a new virtual unit database containing a single unit addPackage :: GhcMonad m => UnitInfo -> m () addPackage pkg = do dflags <- GHC.getSessionDynFlags- case pkgDatabase dflags of+ case unitDatabases dflags of Nothing -> panic "addPackage: called too early" Just dbs -> do- let newdb = PackageDatabase- { packageDatabasePath = "(in memory " ++ showSDoc dflags (ppr (unitId pkg)) ++ ")"- , packageDatabaseUnits = [pkg]+ let newdb = UnitDatabase+ { unitDatabasePath = "(in memory " ++ showSDoc dflags (ppr (unitId pkg)) ++ ")"+ , unitDatabaseUnits = [pkg] }- _ <- GHC.setSessionDynFlags (dflags { pkgDatabase = Just (dbs ++ [newdb]) })- return ()+ GHC.setSessionDynFlags (dflags { unitDatabases = Just (dbs ++ [newdb]) }) compileInclude :: Int -> (Int, Unit) -> BkpM () compileInclude n (i, uid) = do hsc_env <- getSession- let dflags = hsc_dflags hsc_env+ let pkgs = unitState (hsc_dflags hsc_env) msgInclude (i, n) uid -- Check if we've compiled it already case uid of HoleUnit -> return () RealUnit _ -> return ()- VirtUnit i -> case lookupUnit dflags uid of+ VirtUnit i -> case lookupUnit pkgs uid of Nothing -> innerBkpM $ compileUnit (instUnitInstanceOf i) (instUnitInsts i) Just _ -> return () @@ -557,14 +560,14 @@ -- For now, something really simple, since we're not actually going -- to use this for anything-unitDefines :: PackageState -> LHsUnit PackageName -> (PackageName, HsComponentId)+unitDefines :: UnitState -> LHsUnit PackageName -> (PackageName, HsComponentId) unitDefines pkgstate (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) }) = (pn, HsComponentId pn (mkIndefUnitId pkgstate fs)) -bkpPackageNameMap :: PackageState -> [LHsUnit PackageName] -> PackageNameMap HsComponentId+bkpPackageNameMap :: UnitState -> [LHsUnit PackageName] -> PackageNameMap HsComponentId bkpPackageNameMap pkgstate units = Map.fromList (map (unitDefines pkgstate) units) -renameHsUnits :: PackageState -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId]+renameHsUnits :: UnitState -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId] renameHsUnits pkgstate m units = map (fmap renameHsUnit) units where @@ -652,7 +655,7 @@ -- requirement. let node_map = Map.fromList [ ((ms_mod_name n, ms_hsc_src n == HsigFile), n) | n <- nodes ]- req_nodes <- fmap catMaybes . forM (thisUnitIdInsts dflags) $ \(mod_name, _) ->+ req_nodes <- fmap catMaybes . forM (homeUnitInstantiations dflags) $ \(mod_name, _) -> let has_local = Map.member (mod_name, True) node_map in if has_local then return Nothing@@ -772,7 +775,7 @@ hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location) -- Also copied from 'getImports'- let (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps+ let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps -- GHC.Prim doesn't exist physically, so don't go looking for it. ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)
compiler/GHC/Driver/CodeOutput.hs view
@@ -58,7 +58,7 @@ -> ModLocation -> ForeignStubs -> [(ForeignSrcLang, FilePath)]- -- ^ additional files to be compiled with with the C compiler+ -- ^ additional files to be compiled with the C compiler -> [UnitId] -> Stream IO RawCmmGroup a -- Compiled C-- -> IO (FilePath,@@ -131,7 +131,7 @@ -- * -#include options from the cmdline and OPTIONS pragmas -- * the _stub.h file, if there is one. --- let rts = unsafeGetUnitInfo dflags rtsUnitId+ let rts = unsafeLookupUnitId (unitState dflags) rtsUnitId let cc_injects = unlines (map mk_include (unitIncludes rts)) mk_include h_file =@@ -223,7 +223,7 @@ -- we need the #includes from the rts package for the stub files let rts_includes =- let rts_pkg = unsafeGetUnitInfo dflags rtsUnitId in+ let rts_pkg = unsafeLookupUnitId (unitState dflags) rtsUnitId in concatMap mk_include (unitIncludes rts_pkg) mk_include i = "#include \"" ++ i ++ "\"\n" @@ -275,11 +275,9 @@ -- module; -- | Generate code to initialise cost centres-profilingInitCode :: DynFlags -> Module -> CollectedCCs -> SDoc-profilingInitCode dflags this_mod (local_CCs, singleton_CCSs)- = if not (gopt Opt_SccProfilingOn dflags)- then empty- else vcat+profilingInitCode :: Module -> CollectedCCs -> SDoc+profilingInitCode this_mod (local_CCs, singleton_CCSs)+ = vcat $ map emit_cc_decl local_CCs ++ map emit_ccs_decl singleton_CCSs ++ [emit_cc_list local_CCs]
compiler/GHC/Driver/Finder.hs view
@@ -42,6 +42,7 @@ import GHC.Utils.Misc import GHC.Builtin.Names ( gHC_PRIM ) import GHC.Driver.Session+import GHC.Driver.Ways import GHC.Utils.Outputable as Outputable import GHC.Data.Maybe ( expectJust ) @@ -63,7 +64,7 @@ -- source, interface, and object files for that module live. -- It does *not* know which particular package a module lives in. Use--- Packages.lookupModuleInAllPackages for that.+-- Packages.lookupModuleInAllUnits for that. -- ----------------------------------------------------------------------------- -- The finder's cache@@ -74,7 +75,7 @@ flushFinderCaches hsc_env = atomicModifyIORef' fc_ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ()) where- this_pkg = thisPackage (hsc_dflags hsc_env)+ this_pkg = homeUnit (hsc_dflags hsc_env) fc_ref = hsc_FC hsc_env is_ext mod _ | not (moduleUnit mod `unitIdEq` this_pkg) = True | otherwise = False@@ -135,7 +136,7 @@ findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult findExactModule hsc_env mod = let dflags = hsc_dflags hsc_env- in if moduleUnit mod `unitIdEq` thisPackage dflags+ in if moduleUnit mod `unitIdEq` homeUnit dflags then findInstalledHomeModule hsc_env (moduleName mod) else findPackageModule hsc_env mod @@ -182,14 +183,14 @@ findExposedPackageModule hsc_env mod_name mb_pkg = findLookupResult hsc_env $ lookupModuleWithSuggestions- (hsc_dflags hsc_env) mod_name mb_pkg+ (unitState (hsc_dflags hsc_env)) mod_name mb_pkg findExposedPluginPackageModule :: HscEnv -> ModuleName -> IO FindResult findExposedPluginPackageModule hsc_env mod_name = findLookupResult hsc_env $ lookupPluginModuleWithSuggestions- (hsc_dflags hsc_env) mod_name Nothing+ (unitState (hsc_dflags hsc_env)) mod_name Nothing findLookupResult :: HscEnv -> LookupResult -> IO FindResult findLookupResult hsc_env r = case r of@@ -226,12 +227,15 @@ , fr_mods_hidden = [] , fr_unusables = unusables' , fr_suggestions = [] })- LookupNotFound suggest ->+ LookupNotFound suggest -> do+ let suggest'+ | gopt Opt_HelpfulErrors (hsc_dflags hsc_env) = suggest+ | otherwise = [] return (NotFound{ fr_paths = [], fr_pkg = Nothing , fr_pkgs_hidden = [] , fr_mods_hidden = [] , fr_unusables = []- , fr_suggestions = suggest })+ , fr_suggestions = suggest' }) modLocationCache :: HscEnv -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult modLocationCache hsc_env mod do_this = do@@ -245,7 +249,7 @@ mkHomeInstalledModule :: DynFlags -> ModuleName -> InstalledModule mkHomeInstalledModule dflags mod_name =- let iuid = thisUnitId dflags+ let iuid = homeUnitId dflags in Module iuid mod_name -- This returns a module because it's more convenient for users@@ -253,7 +257,7 @@ addHomeModuleToFinder hsc_env mod_name loc = do let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name addToFinderCache (hsc_FC hsc_env) mod (InstalledFound loc mod)- return (mkModule (thisPackage (hsc_dflags hsc_env)) mod_name)+ return (mkHomeModule (hsc_dflags hsc_env) mod_name) uncacheModule :: HscEnv -> ModuleName -> IO () uncacheModule hsc_env mod_name = do@@ -279,7 +283,7 @@ } where dflags = hsc_dflags hsc_env- uid = thisPackage dflags+ uid = homeUnit dflags -- | Implements the search for a module name in the home package only. Calling -- this function directly is usually *not* what you want; currently, it's used@@ -340,16 +344,16 @@ let dflags = hsc_dflags hsc_env pkg_id = moduleUnit mod- pkgstate = pkgState dflags+ pkgstate = unitState dflags --- case lookupInstalledPackage pkgstate pkg_id of+ case lookupUnitId pkgstate pkg_id of Nothing -> return (InstalledNoPackage pkg_id) Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf -- | Look up the interface file associated with module @mod@. This function -- requires a few invariants to be upheld: (1) the 'Module' in question must -- be the module identifier of the *original* implementation of a module,--- not a reexport (this invariant is upheld by @Packages.hs@) and (2)+-- not a reexport (this invariant is upheld by "GHC.Unit.State") and (2) -- the 'UnitInfo' must be consistent with the unit id in the 'Module'. -- The redundancy is to avoid an extra lookup in the package state -- for the appropriate config.@@ -365,7 +369,7 @@ let dflags = hsc_dflags hsc_env- tag = buildTag dflags+ tag = waysBuildTag (ways dflags) -- hi-suffix for packages depends on the build tag. package_hisuf | null tag = "hi"@@ -669,6 +673,7 @@ = ptext cannot_find <+> quotes (ppr mod_name) $$ more_info where+ pkgs = unitState dflags more_info = case find_result of NoPackage pkg@@ -678,7 +683,7 @@ NotFound { fr_paths = files, fr_pkg = mb_pkg , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens , fr_unusables = unusables, fr_suggestions = suggest }- | Just pkg <- mb_pkg, pkg /= thisPackage dflags+ | Just pkg <- mb_pkg, pkg /= homeUnit dflags -> not_found_in_package pkg files | not (null suggest)@@ -696,7 +701,7 @@ _ -> panic "cantFindErr" - build_tag = buildTag dflags+ build_tag = waysBuildTag (ways dflags) not_found_in_package pkg files | build_tag /= ""@@ -723,11 +728,11 @@ <> dot $$ pkg_hidden_hint uid pkg_hidden_hint uid | gopt Opt_BuildingCabalPackage dflags- = let pkg = expectJust "pkg_hidden" (lookupUnit dflags uid)+ = let pkg = expectJust "pkg_hidden" (lookupUnit pkgs uid) in text "Perhaps you need to add" <+> quotes (ppr (unitPackageName pkg)) <+> text "to the build-depends in your .cabal file."- | Just pkg <- lookupUnit dflags uid+ | Just pkg <- lookupUnit pkgs uid = text "You can run" <+> quotes (text ":set -package " <> ppr (unitPackageName pkg)) <+> text "to expose it." $$@@ -754,7 +759,7 @@ pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o where provenance ModHidden = Outputable.empty provenance (ModUnusable _) = Outputable.empty- provenance (ModOrigin{ fromOrigPackage = e,+ provenance (ModOrigin{ fromOrigUnit = e, fromExposedReexport = res, fromPackageFlag = f }) | Just True <- e@@ -771,7 +776,7 @@ pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o where provenance ModHidden = Outputable.empty provenance (ModUnusable _) = Outputable.empty- provenance (ModOrigin{ fromOrigPackage = e,+ provenance (ModOrigin{ fromOrigUnit = e, fromHiddenReexport = rhs }) | Just False <- e = parens (text "needs flag -package-id"@@ -794,7 +799,7 @@ text "was found" $$ looks_like_srcpkgid pkg InstalledNotFound files mb_pkg- | Just pkg <- mb_pkg, not (pkg `unitIdEq` thisPackage dflags)+ | Just pkg <- mb_pkg, not (pkg `unitIdEq` homeUnit dflags) -> not_found_in_package pkg files | null files@@ -805,8 +810,8 @@ _ -> panic "cantFindInstalledErr" - build_tag = buildTag dflags- pkgstate = pkgState dflags+ build_tag = waysBuildTag (ways dflags)+ pkgstate = unitState dflags looks_like_srcpkgid :: UnitId -> SDoc looks_like_srcpkgid pk
compiler/GHC/Driver/Main.hs view
@@ -7,7 +7,7 @@ -- -- This module implements compilation of a Haskell source. It is -- /not/ concerned with preprocessing of source files; this is handled--- in GHC.Driver.Pipeline+-- in "GHC.Driver.Pipeline" -- -- There are various entry points depending on what mode we're in: -- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and@@ -132,7 +132,6 @@ import GHC.Types.CostCentre import GHC.Core.TyCon import GHC.Types.Name-import GHC.Types.Name.Set import GHC.Cmm import GHC.Cmm.Parser ( parseCmmFile ) import GHC.Cmm.Info.Build@@ -147,6 +146,7 @@ import GHC.Builtin.Names import GHC.Driver.Plugins import GHC.Runtime.Loader ( initializePlugins )+import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos) import GHC.Driver.Session import GHC.Utils.Error@@ -175,6 +175,7 @@ import Data.Set (Set) import Data.Functor import Control.DeepSeq (force)+import Data.Bifunctor (first) import GHC.Iface.Ext.Ast ( mkHieFile ) import GHC.Iface.Ext.Types ( getAsts, hie_asts, hie_module )@@ -192,7 +193,7 @@ newHscEnv :: DynFlags -> IO HscEnv newHscEnv dflags = do- eps_var <- newIORef initExternalPackageState+ eps_var <- newIORef (initExternalPackageState dflags) us <- mkSplitUniqSupply 'r' nc_var <- newIORef (initNameCache us knownKeyNames) fc_var <- newIORef emptyInstalledModuleEnv@@ -456,7 +457,7 @@ hsc_typecheck True mod_summary (Just rdr_module) --- | A bunch of logic piled around around @tcRnModule'@, concerning a) backpack+-- | A bunch of logic piled around @tcRnModule'@, concerning a) backpack -- b) concerning dumping rename info and hie files. It would be nice to further -- separate this stuff out, probably in conjunction better separating renaming -- and type checking (#17781).@@ -469,12 +470,12 @@ dflags = hsc_dflags hsc_env outer_mod = ms_mod mod_summary mod_name = moduleName outer_mod- outer_mod' = mkModule (thisPackage dflags) mod_name+ outer_mod' = mkHomeModule dflags mod_name inner_mod = canonicalizeHomeModule dflags mod_name 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( moduleUnit outer_mod == thisPackage dflags )+ MASSERT( isHomeModule dflags outer_mod ) tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod) then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod' real_loc else@@ -996,10 +997,10 @@ -- -- The code for this is quite tricky as the whole algorithm is done in a few -- distinct phases in different parts of the code base. See--- GHC.Rename.Names.rnImportDecl for where package trust dependencies for a+-- 'GHC.Rename.Names.rnImportDecl' for where package trust dependencies for a -- module are collected and unioned. Specifically see the Note [Tracking Trust--- Transitively] in GHC.Rename.Names and the Note [Trust Own Package] in--- GHC.Rename.Names.+-- Transitively] in "GHC.Rename.Names" and the Note [Trust Own Package] in+-- "GHC.Rename.Names". checkSafeImports :: TcGblEnv -> Hsc TcGblEnv checkSafeImports tcg_env = do@@ -1115,8 +1116,8 @@ dflags <- getDynFlags (tw, pkgs) <- isModSafe m l case tw of- False -> return (Nothing, pkgs)- True | isHomePkg dflags m -> return (Nothing, pkgs)+ False -> return (Nothing, pkgs)+ True | isHomeModule 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 $ toUnitId (moduleUnit m), pkgs)@@ -1158,21 +1159,22 @@ return (trust == Sf_Trustworthy, pkgRs) where+ state = unitState dflags inferredImportWarn = unitBag $ makeIntoWarning (Reason Opt_WarnInferredSafeImports)- $ mkWarnMsg dflags l (pkgQual dflags)+ $ mkWarnMsg dflags l (pkgQual state) $ sep [ text "Importing Safe-Inferred module " <> ppr (moduleName m) <> text " from explicitly Safe module" ]- pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $+ pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual state) $ sep [ ppr (moduleName m) <> text ": Can't be safely imported!" , text "The package (" <> ppr (moduleUnit m) <> text ") the module resides in isn't trusted." ]- modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $+ modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual state) $ sep [ ppr (moduleName m) <> text ": Can't be safely imported!" , text "The module itself isn't safe." ]@@ -1190,8 +1192,8 @@ packageTrusted _ Sf_Safe False _ = True packageTrusted _ Sf_SafeInferred False _ = True packageTrusted dflags _ _ m- | isHomePkg dflags m = True- | otherwise = unitIsTrusted $ unsafeGetUnitInfo dflags (moduleUnit m)+ | isHomeModule dflags m = True+ | otherwise = unitIsTrusted $ unsafeLookupUnit (unitState dflags) (moduleUnit m) lookup' :: Module -> Hsc (Maybe ModIface) lookup' m = do@@ -1209,21 +1211,17 @@ return iface' - isHomePkg :: DynFlags -> Module -> Bool- isHomePkg dflags m- | thisPackage dflags == moduleUnit m = True- | otherwise = False- -- | Check the list of packages are trusted. checkPkgTrust :: Set UnitId -> Hsc () checkPkgTrust pkgs = do dflags <- getDynFlags let errors = S.foldr go [] pkgs+ state = unitState dflags go pkg acc- | unitIsTrusted $ getInstalledPackageDetails (pkgState dflags) pkg+ | unitIsTrusted $ unsafeLookupUnitId state pkg = acc | otherwise- = (:acc) $ mkErrMsg dflags noSrcSpan (pkgQual dflags)+ = (:acc) $ mkErrMsg dflags noSrcSpan (pkgQual state) $ text "The package (" <> ppr pkg <> text ") is required" <> text " to be trusted but it isn't!" case errors of@@ -1384,7 +1382,7 @@ -- | Compile to hard-code. hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath- -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], NonCaffySet)+ -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], CgInfos) -- ^ @Just f@ <=> _stub.c is f hscGenHardCode hsc_env cgguts location output_filename = do let CgGuts{ -- This is the last use of the ModGuts in a compilation.@@ -1414,7 +1412,9 @@ let cost_centre_info = (S.toList local_ccs ++ caf_ccs, caf_cc_stacks)- prof_init = profilingInitCode dflags this_mod cost_centre_info+ prof_init+ | sccProfilingEnabled dflags = profilingInitCode this_mod cost_centre_info+ | otherwise = empty foreign_stubs = foreign_stubs0 `appendStubC` prof_init ------------------ Code generation ------------------@@ -1434,7 +1434,7 @@ ------------------ Code output ----------------------- rawcmms0 <- {-# SCC "cmmToRawCmm" #-}- lookupHook cmmToRawCmmHook+ lookupHook (\x -> cmmToRawCmmHook x) (\dflg _ -> cmmToRawCmm dflg) dflags dflags (Just this_mod) cmms let dump a = do@@ -1443,11 +1443,11 @@ return a rawcmms1 = Stream.mapM dump rawcmms0 - (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, caf_infos)+ (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cg_infos) <- {-# SCC "codeOutput" #-} codeOutput dflags this_mod output_filename location foreign_stubs foreign_files dependencies rawcmms1- return (output_filename, stub_c_exists, foreign_fps, caf_infos)+ return (output_filename, stub_c_exists, foreign_fps, cg_infos) hscInteractive :: HscEnv@@ -1492,7 +1492,7 @@ let -- Make up a module name to give the NCG. We can't pass bottom here -- lest we reproduce #11784. mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename- cmm_mod = mkModule (thisPackage dflags) mod_name+ cmm_mod = mkHomeModule dflags mod_name -- Compile decls in Cmm files one decl at a time, to avoid re-ordering -- them in SRT analysis.@@ -1506,7 +1506,7 @@ unless (null cmmgroup) $ dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" FormatCMM (ppr cmmgroup)- rawCmms <- lookupHook cmmToRawCmmHook+ rawCmms <- lookupHook (\x -> cmmToRawCmmHook x) (\dflgs _ -> cmmToRawCmm dflgs) dflags dflags Nothing (Stream.yield cmmgroup) _ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] [] rawCmms@@ -1541,7 +1541,7 @@ -> CollectedCCs -> [StgTopBinding] -> HpcInfo- -> IO (Stream IO CmmGroupSRTs NonCaffySet)+ -> IO (Stream IO CmmGroupSRTs CgInfos) -- Note we produce a 'Stream' of CmmGroups, so that the -- backend can be run incrementally. Otherwise it generates all -- the C-- up front, which has a significant space cost.@@ -1553,7 +1553,7 @@ dumpIfSet_dyn dflags Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings stg_binds_w_fvs) - let cmm_stream :: Stream IO CmmGroup ()+ let cmm_stream :: Stream IO CmmGroup ModuleLFInfos -- See Note [Forcing of stg_binds] cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-} lookupHook stgToCmmHook StgToCmm.codeGen dflags dflags this_mod data_tycons@@ -1572,11 +1572,15 @@ ppr_stream1 = Stream.mapM dump1 cmm_stream - pipeline_stream =- {-# SCC "cmmPipeline" #-}- Stream.mapAccumL (cmmPipeline hsc_env) (emptySRT this_mod) ppr_stream1- <&> (srtMapNonCAFs . moduleSRTMap)+ pipeline_stream :: Stream IO CmmGroupSRTs CgInfos+ pipeline_stream = do+ (non_cafs, lf_infos) <-+ {-# SCC "cmmPipeline" #-}+ Stream.mapAccumL_ (cmmPipeline hsc_env) (emptySRT this_mod) ppr_stream1+ <&> first (srtMapNonCAFs . moduleSRTMap) + return CgInfos{ cgNonCafs = non_cafs, cgLFInfos = lf_infos }+ dump2 a = do unless (null a) $ dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" FormatCMM (ppr a)@@ -1766,7 +1770,7 @@ return (new_tythings, new_ictxt) -- | Load the given static-pointer table entries into the interpreter.--- See Note [Grand plan for static forms] in GHC.Iface.Tidy.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 ()@@ -1886,16 +1890,14 @@ hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue hscCompileCoreExpr' hsc_env srcspan ds_expr- = do { let dflags = hsc_dflags hsc_env-- {- Simplify it -}- ; simpl_expr <- simplifyExpr hsc_env ds_expr+ = do { {- Simplify it -}+ simpl_expr <- simplifyExpr hsc_env ds_expr {- Tidy it (temporary, until coreSat does cloning) -} ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr {- Prepare for codegen -}- ; prepd_expr <- corePrepExpr dflags hsc_env tidy_expr+ ; prepd_expr <- corePrepExpr hsc_env tidy_expr {- Lint if necessary -} ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr
compiler/GHC/Driver/Make.hs view
@@ -21,14 +21,14 @@ ms_home_srcimps, ms_home_imps, - IsBoot(..), summariseModule, hscSourceToIsBoot, findExtraSigImports, implicitRequirements, noModError, cyclicModuleErr,- moduleGraphNodes, SummaryNode+ moduleGraphNodes, SummaryNode,+ IsBootInterface(..) ) where #include "GhclibHsVersions.h"@@ -274,7 +274,7 @@ -- -- This function implements the core of GHC's @--make@ mode. It preprocesses, -- compiles and loads the specified modules, avoiding re-compilation wherever--- possible. Depending on the target (see 'DynFlags.hscTarget') compiling+-- possible. Depending on the target (see 'GHC.Driver.Session.hscTarget') compiling -- and loading may result in files being created on disk. -- -- Calls the 'defaultWarnErrLogger' after each compiling each module, whether@@ -307,10 +307,11 @@ eps <- liftIO $ hscEPS hsc_env let dflags = hsc_dflags hsc_env+ state = unitState dflags pit = eps_PIT eps let loadedPackages- = map (unsafeGetUnitInfo dflags)+ = map (unsafeLookupUnit state) . nub . sort . map moduleUnit . moduleEnvKeys@@ -319,7 +320,7 @@ requestedArgs = mapMaybe packageArg (packageFlags dflags) unusedArgs- = filter (\arg -> not $ any (matching dflags arg) loadedPackages)+ = filter (\arg -> not $ any (matching state arg) loadedPackages) requestedArgs let warn = makeIntoWarning@@ -347,15 +348,15 @@ = str == unitPackageIdString p || str == unitPackageNameString p - matching :: DynFlags -> PackageArg -> UnitInfo -> Bool+ matching :: UnitState -> PackageArg -> UnitInfo -> Bool matching _ (PackageArg str) p = matchingStr str p- matching dflags (UnitIdArg uid) p = uid == realUnit dflags p+ matching state (UnitIdArg uid) p = uid == realUnit state p -- For wired-in packages, we have to unwire their id, -- otherwise they won't match package flags- realUnit :: DynFlags -> UnitInfo -> Unit- realUnit dflags- = unwireUnit dflags+ realUnit :: UnitState -> UnitInfo -> Unit+ realUnit state+ = unwireUnit state . RealUnit . Definite . unitId@@ -378,7 +379,7 @@ -- (see msDeps) let all_home_mods = mkUniqSet [ ms_mod_name s- | s <- mgModSummaries mod_graph, not (isBootSummary s)]+ | s <- mgModSummaries mod_graph, isBootSummary s == NotBoot] -- TODO: Figure out what the correct form of this assert is. It's violated -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot -- files without corresponding hs files.@@ -656,7 +657,7 @@ | nameIsFromExternalPackage this_pkg old_name = old_name | otherwise = ic_name empty_ic where- this_pkg = thisPackage dflags+ this_pkg = homeUnit dflags old_name = ic_name old_ic -- | If there is no -o option, guess the name of target executable@@ -930,23 +931,26 @@ return ((ms,mvar,log_queue):rest, cycle) CyclicSCC mss -> return ([], Just mss) --- A Module and whether it is a boot module.-type BuildModule = (Module, IsBoot)---- | '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 = NotBoot | IsBoot- deriving (Ord, Eq, Show, Read)+-- | A Module and whether it is a boot module.+--+-- We need to treat boot modules specially when building compilation graphs,+-- since they break cycles. Regular source files and signature files are treated+-- equivalently.+type BuildModule = ModuleWithIsBoot --- | Tests if an 'HscSource' is a boot file, primarily for constructing--- elements of 'BuildModule'.-hscSourceToIsBoot :: HscSource -> IsBoot+-- | Tests if an 'HscSource' is a boot file, primarily for constructing elements+-- of 'BuildModule'. We conflate signatures and modules because they are bound+-- in the same namespace; only boot interfaces can be disambiguated with+-- `import {-# SOURCE #-}`.+hscSourceToIsBoot :: HscSource -> IsBootInterface hscSourceToIsBoot HsBootFile = IsBoot hscSourceToIsBoot _ = NotBoot mkBuildModule :: ModSummary -> BuildModule-mkBuildModule ms = (ms_mod ms, if isBootSummary ms then IsBoot else NotBoot)+mkBuildModule ms = GWIB+ { gwib_mod = ms_mod ms+ , gwib_isBoot = isBootSummary ms+ } -- | The entry point to the parallel upsweep. --@@ -1014,12 +1018,12 @@ -- NB: For convenience, the last module of each loop (aka the module that -- finishes the loop) is prepended to the beginning of the loop. let graph = map fstOf3 (reverse comp_graph)- boot_modules = mkModuleSet [ms_mod ms | ms <- graph, isBootSummary ms]+ boot_modules = mkModuleSet [ms_mod ms | ms <- graph, isBootSummary ms == IsBoot] comp_graph_loops = go graph boot_modules where- remove ms bm- | isBootSummary ms = delModuleSet bm (ms_mod ms)- | otherwise = bm+ remove ms bm = case isBootSummary ms of+ IsBoot -> delModuleSet bm (ms_mod ms)+ NotBoot -> bm go [] _ = [] go mg@(ms:mss) boot_modules | Just loop <- getModLoop ms mg (`elemModuleSet` boot_modules)@@ -1193,9 +1197,13 @@ let home_src_imps = map unLoc $ ms_home_srcimps mod -- All the textual imports of this module.- let textual_deps = Set.fromList $ mapFst (mkModule (thisPackage lcl_dflags)) $- zip home_imps (repeat NotBoot) ++- zip home_src_imps (repeat IsBoot)+ let textual_deps = Set.fromList $+ zipWith f home_imps (repeat NotBoot) +++ zipWith f home_src_imps (repeat IsBoot)+ where f mn isBoot = GWIB+ { gwib_mod = mkHomeModule lcl_dflags mn+ , gwib_isBoot = isBoot+ } -- Dealing with module loops -- ~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1301,8 +1309,8 @@ -- SCCs include the loop closer, so we have to filter -- it out. Just loop -> typecheckLoop lcl_dflags lcl_hsc_env' $- filter (/= moduleName (fst this_build_mod)) $- map (moduleName . fst) loop+ filter (/= moduleName (gwib_mod this_build_mod)) $+ map (moduleName . gwib_mod) loop -- Compile the module. mod_info <- upsweep_mod lcl_hsc_env'' mHscMessage old_hpt stable_mods@@ -1315,7 +1323,7 @@ let this_mod = ms_mod_name mod -- Prune the old HPT unless this is an hs-boot module.- unless (isBootSummary mod) $+ unless (isBootSummary mod == IsBoot) $ atomicModifyIORef' old_hpt_var $ \old_hpt -> (delFromHpt old_hpt this_mod, ()) @@ -1331,7 +1339,7 @@ hsc_env'' <- case finish_loop of Nothing -> return hsc_env' Just loop -> typecheckLoop lcl_dflags hsc_env' $- map (moduleName . fst) loop+ map (moduleName . gwib_mod) loop return (hsc_env'', localize_hsc_env hsc_env'') -- Clean up any intermediate files.@@ -1491,8 +1499,9 @@ -- main Haskell source file. Deleting it -- would force the real module to be recompiled -- every time.- old_hpt1 | isBootSummary mod = old_hpt- | otherwise = delFromHpt old_hpt this_mod+ old_hpt1 = case isBootSummary mod of+ IsBoot -> old_hpt+ NotBoot -> delFromHpt old_hpt this_mod done' = extendMG done mod @@ -1518,13 +1527,13 @@ upsweep' old_hpt1 done' mods (mod_index+1) nmods uids_to_check' done_holes' --- | Return a list of instantiated units to type check from the PackageState.+-- | Return a list of instantiated units to type check from the UnitState. -- -- 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))+ nubSort $ concatMap goUnit (explicitUnits (unitState dflags)) where goUnit HoleUnit = [] goUnit (RealUnit _) = []@@ -1596,10 +1605,10 @@ mb_old_iface = case old_hmi of- Nothing -> Nothing- Just hm_info | isBootSummary summary -> Just iface- | not (mi_boot iface) -> Just iface- | otherwise -> Nothing+ Nothing -> Nothing+ Just hm_info | isBootSummary summary == IsBoot -> Just iface+ | mi_boot iface == NotBoot -> Just iface+ | otherwise -> Nothing where iface = hm_iface hm_info @@ -1823,7 +1832,7 @@ | Just loop <- getModLoop ms mss appearsAsBoot -- SOME hs-boot files should still -- get used, just not the loop-closer.- , let non_boot = filter (\l -> not (isBootSummary l &&+ , let non_boot = filter (\l -> not (isBootSummary l == IsBoot && ms_mod l == ms_mod ms)) loop = typecheckLoop (hsc_dflags hsc_env) hsc_env (map ms_mod_name non_boot) | otherwise@@ -1874,7 +1883,7 @@ -> (Module -> Bool) -- check if a module appears as a boot module in 'graph' -> Maybe [ModSummary] getModLoop ms graph appearsAsBoot- | not (isBootSummary ms)+ | isBootSummary ms == NotBoot , appearsAsBoot this_mod , let mss = reachableBackwards (ms_mod_name ms) graph = Just mss@@ -1908,7 +1917,7 @@ = [ node_payload node | node <- reachableG (transposeG graph) root ] where -- the rest just sets up the graph: (graph, lookup_node) = moduleGraphNodes False summaries- root = expectJust "reachableBackwards" (lookup_node HsBootFile mod)+ root = expectJust "reachableBackwards" (lookup_node IsBoot mod) -- --------------------------------------------------------------------------- --@@ -1951,7 +1960,7 @@ -- the specified module. We do this by building a graph with -- the full set of nodes, and determining the reachable set from -- the specified node.- let root | Just node <- lookup_node HsSrcFile root_mod+ let root | Just node <- lookup_node NotBoot root_mod , graph `hasVertexG` node = node | otherwise@@ -1967,21 +1976,27 @@ summaryNodeSummary = node_payload moduleGraphNodes :: Bool -> [ModSummary]- -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)+ -> (Graph SummaryNode, IsBootInterface -> ModuleName -> Maybe SummaryNode) moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVerticesUniq nodes, lookup_node) where numbered_summaries = zip summaries [1..] - lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode- lookup_node hs_src mod = Map.lookup (mod, hscSourceToIsBoot hs_src) node_map+ lookup_node :: IsBootInterface -> ModuleName -> Maybe SummaryNode+ lookup_node hs_src mod = Map.lookup+ (GWIB { gwib_mod = mod, gwib_isBoot = hs_src })+ node_map - lookup_key :: HscSource -> ModuleName -> Maybe Int+ lookup_key :: IsBootInterface -> ModuleName -> Maybe Int lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod) node_map :: NodeMap SummaryNode- node_map = Map.fromList [ ((moduleName (ms_mod s),- hscSourceToIsBoot (ms_hsc_src s)), node)+ node_map = Map.fromList [ ( GWIB+ { gwib_mod = moduleName $ ms_mod s+ , gwib_isBoot = hscSourceToIsBoot $ ms_hsc_src s+ }+ , node+ ) | node <- nodes , let s = summaryNodeSummary node ] @@ -1990,13 +2005,13 @@ nodes = [ DigraphNode s key out_keys | (s, key) <- numbered_summaries -- Drop the hi-boot ones if told to do so- , not (isBootSummary s && drop_hs_boot_nodes)+ , not (isBootSummary s == IsBoot && drop_hs_boot_nodes) , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++- out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) +++ out_edge_keys NotBoot (map unLoc (ms_home_imps s)) ++ (-- see [boot-edges] below if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile then []- else case lookup_key HsBootFile (ms_mod_name s) of+ else case lookup_key IsBoot (ms_mod_name s) of Nothing -> [] Just k -> [k]) ] @@ -2009,23 +2024,26 @@ -- most up to date information. -- Drop hs-boot nodes by using HsSrcFile as the key- hs_boot_key | drop_hs_boot_nodes = HsSrcFile- | otherwise = HsBootFile+ hs_boot_key | drop_hs_boot_nodes = NotBoot -- is regular mod or signature+ | otherwise = IsBoot - out_edge_keys :: HscSource -> [ModuleName] -> [Int]+ out_edge_keys :: IsBootInterface -> [ModuleName] -> [Int] out_edge_keys hi_boot ms = mapMaybe (lookup_key hi_boot) ms -- If we want keep_hi_boot_nodes, then we do lookup_key with- -- IsBoot; else NotBoot+ -- IsBoot; else False -- The nodes of the graph are keyed by (mod, is boot?) pairs -- NB: hsig files show up as *normal* nodes (not boot!), since they don't -- participate in cycles (for now)-type NodeKey = (ModuleName, IsBoot)+type NodeKey = ModuleNameWithIsBoot type NodeMap a = Map.Map NodeKey a msKey :: ModSummary -> NodeKey msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot })- = (moduleName mod, hscSourceToIsBoot boot)+ = GWIB+ { gwib_mod = moduleName mod+ , gwib_isBoot = hscSourceToIsBoot boot+ } mkNodeMap :: [ModSummary] -> NodeMap ModSummary mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries]@@ -2143,7 +2161,7 @@ dup_roots :: [[ModSummary]] -- Each at least of length 2 dup_roots = filterOut isSingleton $ map rights $ nodeMapElts root_map - loop :: [(Located ModuleName,IsBoot)]+ loop :: [GenWithIsBoot (Located ModuleName)] -- Work list: process these modules -> NodeMap [Either ErrorMessages ModSummary] -- Visited set; the range is a list because@@ -2152,7 +2170,7 @@ -> IO (NodeMap [Either ErrorMessages ModSummary]) -- The result is the completed NodeMap loop [] done = return done- loop ((wanted_mod, is_boot) : ss) done+ loop (s : ss) done | Just summs <- Map.lookup key done = if isSingleton summs then loop ss done@@ -2170,7 +2188,12 @@ loop (calcDeps s) (Map.insert key [Right s] done) loop ss new_map where- key = (unLoc wanted_mod, is_boot)+ GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = s+ wanted_mod = L loc mod+ key = GWIB+ { gwib_mod = unLoc wanted_mod+ , gwib_isBoot = is_boot+ } -- | Update the every ModSummary that is depended on -- by a module that needs template haskell. We enable codegen to@@ -2188,14 +2211,14 @@ hscTarget dflags == HscNothing && -- Don't enable codegen for TH on indefinite packages; we -- can't compile anything anyway! See #16219.- not (isIndefinite dflags)+ homeUnitIsDefinite dflags -- | Update the every ModSummary that is depended on -- by a module that needs unboxed tuples. We enable codegen to -- the specified target, disable optimization and change the .hi -- and .o file locations to be temporary files. ----- This is used used in order to load code that uses unboxed tuples+-- This is used in order to load code that uses unboxed tuples -- or sums into GHCi while still allowing some code to be interpreted. enableCodeGenForUnboxedTuplesOrSums :: HscTarget -> NodeMap [Either ErrorMessages ModSummary]@@ -2206,7 +2229,7 @@ condition ms = unboxed_tuples_or_sums (ms_hspp_opts ms) && not (gopt Opt_ByteCode (ms_hspp_opts ms)) &&- not (isBootSummary ms)+ (isBootSummary ms == NotBoot) unboxed_tuples_or_sums d = xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d should_modify (ModSummary { ms_hspp_opts = dflags }) =@@ -2281,10 +2304,11 @@ -- If a module imports a boot module, msDeps helpfully adds a -- dependency to that non-boot module in it's result. This -- means we don't have to think about boot modules here.- | (L _ mn, NotBoot) <- msDeps ms- , dep_ms <-- toList (Map.lookup (mn, NotBoot) nodemap) >>= toList >>=- toList+ | dep <- msDeps ms+ , NotBoot == gwib_isBoot dep+ , dep_ms_0 <- toList $ Map.lookup (unLoc <$> dep) nodemap+ , dep_ms_1 <- toList $ dep_ms_0+ , dep_ms <- toList $ dep_ms_1 ] new_marked_mods = Set.insert ms_mod marked_mods in foldl' go new_marked_mods deps@@ -2302,10 +2326,16 @@ -- modules always contains B.hs if it contains B.hs-boot. -- Remember, this pass isn't doing the topological sort. It's -- just gathering the list of all relevant ModSummaries-msDeps :: ModSummary -> [(Located ModuleName, IsBoot)]-msDeps s =- concat [ [(m,IsBoot), (m,NotBoot)] | m <- ms_home_srcimps s ]- ++ [ (m,NotBoot) | m <- ms_home_imps s ]+msDeps :: ModSummary -> [GenWithIsBoot (Located ModuleName)]+msDeps s = [ d+ | m <- ms_home_srcimps s+ , d <- [ GWIB { gwib_mod = m, gwib_isBoot = IsBoot }+ , GWIB { gwib_mod = m, gwib_isBoot = NotBoot }+ ]+ ]+ ++ [ GWIB { gwib_mod = m, gwib_isBoot = NotBoot }+ | m <- ms_home_imps s+ ] ----------------------------------------------------------------------------- -- Summarising modules@@ -2392,7 +2422,7 @@ (x:_) -> Just x checkSummaryTimestamp- :: HscEnv -> DynFlags -> Bool -> IsBoot+ :: HscEnv -> DynFlags -> Bool -> IsBootInterface -> (UTCTime -> IO (Either e ModSummary)) -> ModSummary -> ModLocation -> UTCTime -> IO (Either e ModSummary)@@ -2433,7 +2463,7 @@ summariseModule :: HscEnv -> NodeMap ModSummary -- Map of old summaries- -> IsBoot -- IsBoot <=> a {-# SOURCE #-} import+ -> IsBootInterface -- True <=> a {-# SOURCE #-} import -> Located ModuleName -- Imported module to be summarised -> Bool -- object code allowed? -> Maybe (StringBuffer, UTCTime)@@ -2445,7 +2475,9 @@ | wanted_mod `elem` excl_mods = return Nothing - | Just old_summary <- Map.lookup (wanted_mod, is_boot) old_summary_map+ | Just old_summary <- Map.lookup+ (GWIB { gwib_mod = wanted_mod, gwib_isBoot = is_boot })+ old_summary_map = do -- Find its new timestamp; all the -- ModSummaries in the old map have valid ml_hs_files let location = ms_location old_summary@@ -2491,8 +2523,9 @@ just_found location mod = do -- Adjust location to point to the hs-boot source file, -- hi file, object file, when is_boot says so- let location' | IsBoot <- is_boot = addBootSuffixLocn location- | otherwise = location+ let location' = case is_boot of+ IsBoot -> addBootSuffixLocn location+ NotBoot -> location src_fn = expectJust "summarise2" (ml_hs_file location') -- Check that it exists@@ -2514,10 +2547,10 @@ -- case, we know if it's a boot or not because of the {-# SOURCE #-} -- annotation, but we don't know if it's a signature or a regular -- module until we actually look it up on the filesystem.- let hsc_src = case is_boot of- IsBoot -> HsBootFile- _ | isHaskellSigFilename src_fn -> HsigFile- | otherwise -> HsSrcFile+ let hsc_src+ | is_boot == IsBoot = HsBootFile+ | isHaskellSigFilename src_fn = HsigFile+ | otherwise = HsSrcFile when (pi_mod_name /= wanted_mod) $ throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $@@ -2525,12 +2558,12 @@ $$ text "Saw:" <+> quotes (ppr pi_mod_name) $$ text "Expected:" <+> quotes (ppr wanted_mod) - when (hsc_src == HsigFile && isNothing (lookup pi_mod_name (thisUnitIdInsts dflags))) $+ when (hsc_src == HsigFile && isNothing (lookup pi_mod_name (homeUnitInstantiations dflags))) $ let suggested_instantiated_with = hcat (punctuate comma $ [ ppr k <> text "=" <> ppr v | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name)- : thisUnitIdInsts dflags)+ : homeUnitInstantiations dflags) ]) in throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $ text "Unexpected signature:" <+> quotes (ppr pi_mod_name)@@ -2560,7 +2593,7 @@ = MakeNewModSummary { nms_src_fn :: FilePath , nms_src_timestamp :: UTCTime- , nms_is_boot :: IsBoot+ , nms_is_boot :: IsBootInterface , nms_hsc_src :: HscSource , nms_location :: ModLocation , nms_mod :: Module@@ -2604,10 +2637,11 @@ , ms_obj_date = obj_timestamp } -getObjTimestamp :: ModLocation -> IsBoot -> IO (Maybe UTCTime)+getObjTimestamp :: ModLocation -> IsBootInterface -> IO (Maybe UTCTime) getObjTimestamp location is_boot- = if is_boot == IsBoot then return Nothing- else modificationTimeIfExists (ml_obj_file location)+ = case is_boot of+ IsBoot -> return Nothing+ NotBoot -> modificationTimeIfExists (ml_obj_file location) data PreprocessedImports = PreprocessedImports@@ -2722,8 +2756,11 @@ graph = [ DigraphNode ms (msKey ms) (get_deps ms) | ms <- mss] get_deps :: ModSummary -> [NodeKey]- get_deps ms = ([ (unLoc m, IsBoot) | m <- ms_home_srcimps ms ] ++- [ (unLoc m, NotBoot) | m <- ms_home_imps ms ])+ get_deps ms =+ [ GWIB { gwib_mod = unLoc m, gwib_isBoot = IsBoot }+ | m <- ms_home_srcimps ms ] +++ [ GWIB { gwib_mod = unLoc m, gwib_isBoot = NotBoot }+ | m <- ms_home_imps ms ] show_path [] = panic "show_path" show_path [m] = text "module" <+> ppr_ms m
compiler/GHC/Driver/MakeFile.hs view
@@ -20,7 +20,6 @@ import qualified GHC import GHC.Driver.Monad import GHC.Driver.Session-import GHC.Driver.Ways import GHC.Utils.Misc import GHC.Driver.Types import qualified GHC.SysTools as SysTools@@ -65,11 +64,10 @@ -- be specified. let dflags = dflags0 { ways = Set.empty,- buildTag = waysTag Set.empty, hiSuf = "hi", objectSuf = "o" }- _ <- GHC.setSessionDynFlags dflags+ GHC.setSessionDynFlags dflags when (null (depSuffixes dflags)) $ liftIO $ throwGhcExceptionIO (ProgramError "You must specify at least one -dep-suffix")@@ -247,8 +245,8 @@ | (mb_pkg, L loc mod) <- idecls, mod `notElem` excl_mods ] - ; do_imps True (ms_srcimps node)- ; do_imps False (ms_imps node)+ ; do_imps IsBoot (ms_srcimps node)+ ; do_imps NotBoot (ms_imps node) } @@ -258,7 +256,7 @@ -> ModuleName -- Imported module -> IsBootInterface -- Source import -> Bool -- Record dependency on package modules- -> IO (Maybe FilePath) -- Interface file file+ -> IO (Maybe FilePath) -- Interface file findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do { -- Find the module; this will be fast because -- we've done it once during downsweep@@ -298,7 +296,7 @@ :: FilePath -- Original filename; e.g. "foo.o" -> [String] -- Suffix prefixes e.g. ["x_", "y_"] -> [FilePath] -- Zapped filenames e.g. ["foo.x_o", "foo.y_o"]- -- Note that that the extra bit gets inserted *before* the old suffix+ -- Note that the extra bit gets inserted *before* the old suffix -- We assume the old suffix contains no dots, so we know where to -- split it insertSuffixes file_name extras
compiler/GHC/Driver/Pipeline.hs view
@@ -71,7 +71,7 @@ import GHC.Data.Bag ( unitBag ) import GHC.Data.FastString ( mkFastString ) import GHC.Iface.Make ( mkFullIface )-import GHC.Iface.UpdateCafInfos ( updateModDetailsCafInfos )+import GHC.Iface.UpdateIdInfos ( updateModDetailsIdInfos ) import GHC.Utils.Exception as Exception import System.Directory@@ -379,7 +379,7 @@ -- https://gitlab.haskell.org/ghc/ghc/issues/12673 -- and https://github.com/haskell/cabal/issues/2257 empty_stub <- newTempName dflags TFL_CurrentModule "c"- let src = text "int" <+> ppr (mkModule (thisPackage dflags) mod_name) <+> text "= 0;"+ let src = text "int" <+> ppr (mkHomeModule dflags mod_name) <+> text "= 0;" writeFile empty_stub (showSDoc dflags (pprCode CStyle src)) _ <- runPipeline StopLn hsc_env (empty_stub, Nothing, Nothing)@@ -513,9 +513,9 @@ -- next, check libraries. XXX this only checks Haskell libraries, -- not extra_libraries or -l things from the command line.- let pkgstate = pkgState dflags+ let pkgstate = unitState dflags let pkg_hslibs = [ (collectLibraryPaths dflags [c], lib)- | Just c <- map (lookupInstalledPackage pkgstate) pkg_deps,+ | Just c <- map (lookupUnitId pkgstate) pkg_deps, lib <- packageHsLibs dflags c ] pkg_libfiles <- mapM (uncurry (findHSLib dflags)) pkg_hslibs@@ -1180,12 +1180,12 @@ PipeState{hsc_env=hsc_env'} <- getPipeState - (outputFilename, mStub, foreign_files, caf_infos) <- liftIO $+ (outputFilename, mStub, foreign_files, cg_infos) <- liftIO $ hscGenHardCode hsc_env' cgguts mod_location output_fn - final_iface <- liftIO (mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface (Just caf_infos))- let final_mod_details = {-# SCC updateModDetailsCafInfos #-}- updateModDetailsCafInfos iface_dflags caf_infos mod_details+ final_iface <- liftIO (mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface (Just cg_infos))+ let final_mod_details = {-# SCC updateModDetailsIdInfos #-}+ updateModDetailsIdInfos iface_dflags cg_infos mod_details setIface final_iface final_mod_details -- See Note [Writing interface files]@@ -1233,7 +1233,7 @@ -- add package include paths even if we're just compiling .c -- files; this is the Value Add(TM) that using ghc instead of -- gcc gives you :)- pkg_include_dirs <- liftIO $ getPackageIncludePath dflags pkgs+ pkg_include_dirs <- liftIO $ getUnitIncludePath dflags pkgs let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []@@ -1261,11 +1261,11 @@ pkg_extra_cc_opts <- liftIO $ if hcc then return []- else getPackageExtraCcOpts dflags pkgs+ else getUnitExtraCcOpts dflags pkgs framework_paths <- if platformUsesFrameworks platform- then do pkgFrameworkPaths <- liftIO $ getPackageFrameworkPath dflags pkgs+ then do pkgFrameworkPaths <- liftIO $ getUnitFrameworkPath dflags pkgs let cmdlineFrameworkPaths = frameworkPaths dflags return $ map ("-F"++) (cmdlineFrameworkPaths ++ pkgFrameworkPaths)@@ -1312,7 +1312,7 @@ -- way we do the import depends on whether we're currently compiling -- the base package or not. ++ (if platformOS platform == OSMinGW32 &&- thisPackage dflags == baseUnitId+ homeUnitId dflags == baseUnitId then [ "-DCOMPILING_BASE_PACKAGE" ] else []) @@ -1654,7 +1654,7 @@ linkBinary = linkBinary' False linkBinary' :: Bool -> DynFlags -> [FilePath] -> [UnitId] -> IO ()-linkBinary' staticLink dflags o_files dep_packages = do+linkBinary' staticLink dflags o_files dep_units = do let platform = targetPlatform dflags toolSettings' = toolSettings dflags verbFlags = getVerbFlags dflags@@ -1668,7 +1668,7 @@ then return output_fn else do d <- getCurrentDirectory return $ normalise (d </> output_fn)- pkg_lib_paths <- getPackageLibraryPath dflags dep_packages+ pkg_lib_paths <- getUnitLibraryPath dflags dep_units let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths get_pkg_lib_path_opts l | osElfTarget (platformOS platform) &&@@ -1706,7 +1706,7 @@ pkg_lib_path_opts <- if gopt Opt_SingleLibFolder dflags then do- libs <- getLibs dflags dep_packages+ libs <- getLibs dflags dep_units tmpDir <- newTempDir dflags sequence_ [ copyFile lib (tmpDir </> basename) | (lib, basename) <- libs]@@ -1723,7 +1723,7 @@ let lib_path_opts = map ("-L"++) lib_paths extraLinkObj <- mkExtraObjToLinkIntoBinary dflags- noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_packages+ noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_units let (pre_hs_libs, post_hs_libs)@@ -1736,7 +1736,7 @@ = ([],[]) pkg_link_opts <- do- (package_hs_libs, extra_libs, other_flags) <- getPackageLinkOpts dflags dep_packages+ (package_hs_libs, extra_libs, other_flags) <- getUnitLinkOpts dflags dep_units return $ if staticLink then package_hs_libs -- If building an executable really means making a static -- library (e.g. iOS), then we only keep the -l options for@@ -1758,7 +1758,7 @@ -- that defines the symbol." -- frameworks- pkg_framework_opts <- getPkgFrameworkOpts dflags platform dep_packages+ pkg_framework_opts <- getUnitFrameworkOpts dflags platform dep_units let framework_opts = getFrameworkOpts dflags platform -- probably _stub.o files@@ -1911,7 +1911,7 @@ linkDynLibCheck :: DynFlags -> [String] -> [UnitId] -> IO ()-linkDynLibCheck dflags o_files dep_packages+linkDynLibCheck dflags o_files dep_units = do when (haveRtsOptsFlags dflags) $ do putLogMsg dflags NoReason SevInfo noSrcSpan@@ -1919,13 +1919,13 @@ (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$ text " Call hs_init_ghc() from your main() function to set these options.") - linkDynLib dflags o_files dep_packages+ linkDynLib dflags o_files dep_units -- | 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] -> [UnitId] -> IO ()-linkStaticLib dflags o_files dep_packages = do+linkStaticLib dflags o_files dep_units = do let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ] modules = o_files ++ extra_ld_inputs output_fn = exeFileName True dflags@@ -1937,7 +1937,7 @@ output_exists <- doesFileExist full_output_fn (when output_exists) $ removeFile full_output_fn - pkg_cfgs <- getPreloadPackagesAnd dflags dep_packages+ pkg_cfgs <- getPreloadUnitsAnd dflags dep_units archives <- concatMapM (collectArchives dflags) pkg_cfgs ar <- foldl mappend@@ -1959,7 +1959,7 @@ let hscpp_opts = picPOpts dflags let cmdline_include_paths = includePaths dflags - pkg_include_dirs <- getPackageIncludePath dflags []+ pkg_include_dirs <- getUnitIncludePath dflags [] let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []@@ -2002,8 +2002,9 @@ let hsSourceCppOpts = [ "-include", ghcVersionH ] -- MIN_VERSION macros- let uids = explicitPackages (pkgState dflags)- pkgs = catMaybes (map (lookupUnit dflags) uids)+ let state = unitState dflags+ uids = explicitUnits state+ pkgs = catMaybes (map (lookupUnit state) uids) mb_macro_include <- if not (null pkgs) && gopt Opt_VersionMacros dflags then do macro_stub <- newTempName dflags TFL_CurrentModule "h"@@ -2222,7 +2223,7 @@ candidates <- case ghcVersionFile dflags of Just path -> return [path] Nothing -> (map (</> "ghcversion.h")) <$>- (getPackageIncludePath dflags [toUnitId rtsUnitId])+ (getUnitIncludePath dflags [rtsUnitId]) found <- filterM doesFileExist candidates case found of
compiler/GHC/HsToCore.hs view
@@ -174,7 +174,7 @@ ; let used_names = mkUsedNames tcg_env pluginModules = map lpModule (cachedPlugins (hsc_dflags hsc_env))- ; deps <- mkDependencies (thisUnitId (hsc_dflags hsc_env))+ ; deps <- mkDependencies (homeUnitId (hsc_dflags hsc_env)) (map mi_module pluginModules) tcg_env ; used_th <- readIORef tc_splice_used@@ -354,7 +354,7 @@ Reason - It makes the rules easier to look up- - It means that transformation rules and specialisations for+ - It means that rewrite rules and specialisations for locally defined Ids are handled uniformly - It keeps alive things that are referred to only from a rule (the occurrence analyser knows about rules attached to Ids)@@ -368,7 +368,7 @@ ************************************************************************ * *-* Desugaring transformation rules+* Desugaring rewrite rules * * ************************************************************************ -}@@ -691,11 +691,11 @@ , openAlphaTyVar, openBetaTyVar , x ] $ mkSingleAltCase scrut1- (mkWildValBinder scrut1_ty)+ (mkWildValBinder Many scrut1_ty) (DataAlt unsafe_refl_data_con) [rr_cv] $ mkSingleAltCase scrut2- (mkWildValBinder scrut2_ty)+ (mkWildValBinder Many scrut2_ty) (DataAlt unsafe_refl_data_con) [ab_cv] $ Var x `mkCast` x_co@@ -736,7 +736,7 @@ ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar , openAlphaTyVar, openBetaTyVar ] $- mkVisFunTy openAlphaTy openBetaTy+ mkVisFunTyMany openAlphaTy openBetaTy id = mkExportedVanillaId unsafeCoercePrimName ty `setIdInfo` info ; return (id, old_expr) }
compiler/GHC/HsToCore/Arrows.hs view
@@ -38,6 +38,7 @@ import GHC.Tc.Utils.TcType import GHC.Core.Type( splitPiTy )+import GHC.Core.Multiplicity import GHC.Tc.Types.Evidence import GHC.Core import GHC.Core.FVs@@ -107,7 +108,7 @@ where mk_bind (std_name, expr) = do { rhs <- dsExpr expr- ; id <- newSysLocalDs (exprType rhs)+ ; id <- newSysLocalDs Many (exprType rhs) -- no check needed; these are functions ; return (NonRec id rhs, (std_name, id)) } @@ -175,18 +176,18 @@ -- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> a mkFstExpr :: Type -> Type -> DsM CoreExpr mkFstExpr a_ty b_ty = do- a_var <- newSysLocalDs a_ty- b_var <- newSysLocalDs b_ty- pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty)+ a_var <- newSysLocalDs Many a_ty+ b_var <- newSysLocalDs Many b_ty+ pair_var <- newSysLocalDs Many (mkCorePairTy a_ty b_ty) return (Lam pair_var (coreCasePair pair_var a_var b_var (Var a_var))) -- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b mkSndExpr :: Type -> Type -> DsM CoreExpr mkSndExpr a_ty b_ty = do- a_var <- newSysLocalDs a_ty- b_var <- newSysLocalDs b_ty- pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty)+ a_var <- newSysLocalDs Many a_ty+ b_var <- newSysLocalDs Many b_ty+ pair_var <- newSysLocalDs Many (mkCorePairTy a_ty b_ty) return (Lam pair_var (coreCasePair pair_var a_var b_var (Var b_var))) @@ -264,9 +265,9 @@ -> DsM CoreExpr matchEnvStack env_ids stack_id body = do uniqs <- newUniqueSupply- tup_var <- newSysLocalDs (mkBigCoreVarTupTy env_ids)+ tup_var <- newSysLocalDs Many (mkBigCoreVarTupTy env_ids) let match_env = coreCaseTuple uniqs tup_var env_ids body- pair_id <- newSysLocalDs (mkCorePairTy (idType tup_var) (idType stack_id))+ pair_id <- newSysLocalDs Many (mkCorePairTy (idType tup_var) (idType stack_id)) return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env)) ----------------------------------------------@@ -283,7 +284,7 @@ -> DsM CoreExpr matchEnv env_ids body = do uniqs <- newUniqueSupply- tup_id <- newSysLocalDs (mkBigCoreVarTupTy env_ids)+ tup_id <- newSysLocalDs Many (mkBigCoreVarTupTy env_ids) return (Lam tup_id (coreCaseTuple uniqs tup_id env_ids body)) ----------------------------------------------@@ -298,7 +299,7 @@ matchVarStack [] stack_id body = return (stack_id, body) matchVarStack (param_id:param_ids) stack_id body = do (tail_id, tail_code) <- matchVarStack param_ids stack_id body- pair_id <- newSysLocalDs (mkCorePairTy (idType param_id) (idType tail_id))+ pair_id <- newSysLocalDs Many (mkCorePairTy (idType param_id) (idType tail_id)) return (pair_id, coreCasePair pair_id param_id tail_id tail_code) mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr GhcTc@@ -326,7 +327,7 @@ let env_stk_ty = mkCorePairTy env_ty unitTy let env_stk_expr = mkCorePairExpr (mkBigCoreVarTup env_ids) mkCoreUnitExpr fail_expr <- mkFailExpr ProcExpr env_stk_ty- var <- selectSimpleMatchVarL pat+ var <- selectSimpleMatchVarL Many pat match_code <- matchSimply (Var var) ProcExpr pat env_stk_expr fail_expr let pat_ty = hsLPatType pat let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty@@ -375,7 +376,7 @@ (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty core_arrow <- dsLExprNoLP arrow core_arg <- dsLExpr arg- stack_id <- newSysLocalDs stack_ty+ stack_id <- newSysLocalDs Many stack_ty core_make_arg <- matchEnvStack env_ids stack_id core_arg return (do_premap ids (envStackType env_ids stack_ty)@@ -401,7 +402,7 @@ core_arrow <- dsLExpr arrow core_arg <- dsLExpr arg- stack_id <- newSysLocalDs stack_ty+ stack_id <- newSysLocalDs Many stack_ty core_make_pair <- matchEnvStack env_ids stack_id (mkCorePairExpr core_arrow core_arg) @@ -428,8 +429,8 @@ stack_ty' = mkCorePairTy arg_ty stack_ty (core_cmd, free_vars, env_ids') <- dsfixCmd ids local_vars stack_ty' res_ty cmd- stack_id <- newSysLocalDs stack_ty- arg_id <- newSysLocalDsNoLP arg_ty+ stack_id <- newSysLocalDs Many stack_ty+ arg_id <- newSysLocalDsNoLP Many arg_ty -- push the argument expression onto the stack let stack' = mkCorePairExpr (Var arg_id) (Var stack_id)@@ -474,7 +475,7 @@ <- dsfixCmd ids local_vars stack_ty res_ty then_cmd (core_else, fvs_else, else_ids) <- dsfixCmd ids local_vars stack_ty res_ty else_cmd- stack_id <- newSysLocalDs stack_ty+ stack_id <- newSysLocalDs Many stack_ty either_con <- dsLookupTyCon eitherTyConName left_con <- dsLookupDataCon leftDataConName right_con <- dsLookupDataCon rightDataConName@@ -538,7 +539,7 @@ , mg_ext = MatchGroupTc arg_tys _ , mg_origin = origin })) env_ids = do- stack_id <- newSysLocalDs stack_ty+ stack_id <- newSysLocalDs Many stack_ty -- Extract and desugar the leaf commands in the case, building tuple -- expressions that will (after tagging) replace these leaves@@ -594,8 +595,8 @@ 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+ (HsCmdLamCase _ mg@MG { mg_ext = MatchGroupTc [Scaled arg_mult arg_ty] _ }) env_ids = do+ arg_id <- newSysLocalDs arg_mult 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 @@ -613,7 +614,7 @@ (core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty res_ty body- stack_id <- newSysLocalDs stack_ty+ stack_id <- newSysLocalDs Many stack_ty -- build a new environment, plus the stack, using the let bindings core_binds <- dsLocalBinds lbinds (buildEnvStack env_ids' stack_id) -- match the old environment and stack against the input@@ -684,7 +685,7 @@ (meth_binds, meth_ids) <- mkCmdEnv ids (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd- stack_id <- newSysLocalDs stack_ty+ stack_id <- newSysLocalDs Many stack_ty trim_code <- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id) let@@ -750,8 +751,8 @@ (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'+ param_ids <- mapM (newSysLocalDsNoLP Many) pat_tys+ stack_id' <- newSysLocalDs Many stack_ty' -- the expression is built from the inside out, so the actions -- are presented in reverse order@@ -801,7 +802,7 @@ (text "In the command:" <+> ppr body) (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids let env_ty = mkBigCoreVarTupTy env_ids- env_var <- newSysLocalDs env_ty+ env_var <- newSysLocalDs Many env_ty let core_map = Lam env_var (mkCorePairExpr (Var env_var) mkCoreUnitExpr) return (do_premap ids env_ty@@ -904,18 +905,18 @@ -- projection function -- \ (p, (xs2)) -> (zs) - env_id <- newSysLocalDs env_ty2+ env_id <- newSysLocalDs Many env_ty2 uniqs <- newUniqueSupply let after_c_ty = mkCorePairTy pat_ty env_ty2 out_ty = mkBigCoreVarTupTy out_ids body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids) - fail_expr <- mkFailExpr (StmtCtxt DoExpr) out_ty- pat_id <- selectSimpleMatchVarL pat+ fail_expr <- mkFailExpr (StmtCtxt (DoExpr Nothing)) out_ty+ pat_id <- selectSimpleMatchVarL Many pat match_code- <- matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr- pair_id <- newSysLocalDs after_c_ty+ <- matchSimply (Var pat_id) (StmtCtxt (DoExpr Nothing)) pat body_expr fail_expr+ pair_id <- newSysLocalDs Many after_c_ty let proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code) @@ -978,7 +979,7 @@ -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids) uniqs <- newUniqueSupply- env2_id <- newSysLocalDs env2_ty+ env2_id <- newSysLocalDs Many env2_ty let later_ty = mkBigCoreVarTupTy later_ids post_pair_ty = mkCorePairTy later_ty env2_ty@@ -1065,7 +1066,7 @@ -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids) - rec_id <- newSysLocalDs rec_ty+ rec_id <- newSysLocalDs Many rec_ty let env1_id_set = fv_stmts `uniqDSetMinusUniqSet` rec_id_set env1_ids = dVarSetElems env1_id_set
compiler/GHC/HsToCore/Binds.hs view
@@ -53,6 +53,7 @@ import GHC.Tc.Utils.TcType import GHC.Core.Type import GHC.Core.Coercion+import GHC.Core.Multiplicity import GHC.Builtin.Types ( typeNatKind, typeSymbolKind ) import GHC.Types.Id import GHC.Types.Id.Make(proxyHashId)@@ -156,10 +157,11 @@ -- oracle. -- addTyCsDs: Add type evidence to the refinement type -- predicate of the coverage checker- -- See Note [Type and Term Equality Propagation] in PmCheck+ -- See Note [Type and Term Equality Propagation] in "GHC.HsToCore.PmCheck" matchWrapper (mkPrefixFunRhs (L loc (idName fun))) Nothing matches+ ; core_wrap <- dsHsWrapper co_fn ; let body' = mkOptTickBox tick body rhs = core_wrap (mkLams args body')@@ -175,7 +177,7 @@ = [] ; --pprTrace "dsHsBind" (vcat [ ppr fun <+> ppr (idInlinePragma fun) -- , ppr (mg_alts matches)- -- , ppr args, ppr core_binds]) $+ -- , ppr args, ppr core_binds, ppr body']) $ return (force_var, [core_binds]) } dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss@@ -197,7 +199,11 @@ , abs_exports = exports , abs_ev_binds = ev_binds , abs_binds = binds, abs_sig = has_sig })- = do { ds_binds <- addTyCsDs FromSource (listToBag dicts) (dsLHsBinds binds)+ = do { ds_binds <- addTyCsDs FromSource (listToBag dicts) $+ dsLHsBinds binds+ -- addTyCsDs: push type constraints deeper+ -- for inner pattern match check+ -- See Check, Note [Type and Term Equality Propagation] ; ds_ev_binds <- dsTcEvBinds_s ev_binds @@ -283,7 +289,7 @@ mkLet core_bind $ tup_expr - ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)+ ; poly_tup_id <- newSysLocalDs Many (exprType poly_tup_rhs) -- Find corresponding global or make up a new one: sometimes -- we need to make new export to desugar strict binds, see@@ -293,8 +299,8 @@ ; let mk_bind (ABE { abe_wrap = wrap , abe_poly = global , abe_mono = local, abe_prags = spec_prags })- -- See Note [AbsBinds wrappers] in HsBinds- = do { tup_id <- newSysLocalDs tup_ty+ -- See Note [AbsBinds wrappers] in "GHC.Hs.Binds"+ = do { tup_id <- newSysLocalDs Many tup_ty ; core_wrap <- dsHsWrapper wrap ; let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $ mkTupleSelector all_locals local tup_id $@@ -352,7 +358,7 @@ ([],[]) lcls mk_export local =- do global <- newSysLocalDs+ do global <- newSysLocalDs Many (exprType (mkLams tyvars (mkLams dicts (Var local)))) return (ABE { abe_ext = noExtField , abe_poly = global@@ -698,7 +704,7 @@ { this_mod <- getModule ; let fn_unf = realIdUnfolding poly_id spec_unf = specUnfolding dflags spec_bndrs core_app rule_lhs_args fn_unf- spec_id = mkLocalId spec_name spec_ty+ spec_id = mkLocalId spec_name Many spec_ty -- Specialised binding is toplevel, hence Many. `setInlinePragma` inl_prag `setIdUnfolding` spec_unf @@ -871,7 +877,7 @@ = scopedSort unbound_tvs ++ unbound_dicts where unbound_tvs = [ v | v <- unbound_vars, isTyVar v ]- unbound_dicts = [ mkLocalId (localiseName (idName d)) (idType d)+ unbound_dicts = [ mkLocalId (localiseName (idName d)) Many (idType d) | d <- unbound_vars, isDictId d ] unbound_vars = [ v | v <- exprsFreeVarsList args , not (v `elemVarSet` orig_bndr_set)@@ -957,7 +963,7 @@ After type checking the LHS becomes (foo alpha (C alpha)), where alpha is an unbound meta-tyvar. The zonker in GHC.Tc.Utils.Zonk is careful not to turn the free alpha into Any (as it usually does). Instead it turns it-into a TyVar 'a'. See Note [Zonking the LHS of a RULE] in Ghc.Tc.Syntax.+into a TyVar 'a'. See Note [Zonking the LHS of a RULE] in "GHC.Tc.Utils.Zonk". 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/@@ -1121,8 +1127,8 @@ ; return (w1 . w2) } -- 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+dsHsWrapper (WpFun c1 c2 (Scaled w t1) doc)+ = do { x <- newSysLocalDsNoLP w t1 ; w1 <- dsHsWrapper c1 ; w2 <- dsHsWrapper c2 ; let app f a = mkCoreAppDs (text "dsHsWrapper") f a@@ -1135,7 +1141,9 @@ return $ \e -> mkCastDs e co dsHsWrapper (WpEvApp tm) = do { core_tm <- dsEvTerm tm ; return (\e -> App e core_tm) }-+dsHsWrapper (WpMultCoercion co) = do { when (not (isReflexiveCo co)) $+ errDs (text "Multiplicity coercions are currently not supported")+ ; return $ \e -> e } -------------------------------------- dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind] dsTcEvBinds_s [] = return []@@ -1259,24 +1267,26 @@ ; mkTrApp <- dsLookupGlobalId mkTrAppName -- mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1). -- TypeRep a -> TypeRep b -> TypeRep (a b)- ; let (k1, k2) = splitFunTy (typeKind t1)+ ; let (_, k1, k2) = splitFunTy (typeKind t1) -- drop the multiplicity,+ -- since it's a kind ; let expr = mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ]) [ e1, e2 ] -- ; pprRuntimeTrace "Trace mkTrApp" (ppr expr) expr ; return expr } -ds_ev_typeable ty (EvTypeableTrFun ev1 ev2)- | Just (t1,t2) <- splitFunTy_maybe ty+ds_ev_typeable ty (EvTypeableTrFun evm ev1 ev2)+ | Just (m,t1,t2) <- splitFunTy_maybe ty = do { e1 <- getRep ev1 t1 ; e2 <- getRep ev2 t2+ ; em <- getRep evm m ; mkTrFun <- dsLookupGlobalId mkTrFunName- -- mkTrFun :: forall r1 r2 (a :: TYPE r1) (b :: TYPE r2).- -- TypeRep a -> TypeRep b -> TypeRep (a -> b)+ -- mkTrFun :: forall (m :: Multiplicity) r1 r2 (a :: TYPE r1) (b :: TYPE r2).+ -- TypeRep m -> TypeRep a -> TypeRep b -> TypeRep (a # m -> b) ; let r1 = getRuntimeRep t1 r2 = getRuntimeRep t2- ; return $ mkApps (mkTyApps (Var mkTrFun) [r1, r2, t1, t2])- [ e1, e2 ]+ ; return $ mkApps (mkTyApps (Var mkTrFun) [m, r1, r2, t1, t2])+ [ em, e1, e2 ] } ds_ev_typeable ty (EvTypeableTyLit ev)
compiler/GHC/HsToCore/Coverage.hs view
@@ -180,7 +180,7 @@ mod_name = moduleNameString (moduleName mod) hpc_mod_dir- | moduleUnit mod == mainUnitId = hpc_dir+ | moduleUnit mod == mainUnit = hpc_dir | otherwise = hpc_dir ++ "/" ++ unitString (moduleUnit mod) tabStop = 8 -- <tab> counts as a normal char in GHC's@@ -712,6 +712,7 @@ liftM4 (\b f -> BindStmt $ XBindStmtTc { xbstc_bindOp = b , xbstc_boundResultType = xbstc_boundResultType xbs+ , xbstc_boundResultMult = xbstc_boundResultMult xbs , xbstc_failOp = f }) (addTickSyntaxExpr hpcSrcSpan (xbstc_bindOp xbs))@@ -772,11 +773,12 @@ <*> addTickLPat pat <*> addTickLHsExpr expr <*> pure isBody- addTickArg (ApplicativeArgMany x stmts ret pat) =+ addTickArg (ApplicativeArgMany x stmts ret pat ctxt) = (ApplicativeArgMany x) <$> addTickLStmts isGuard stmts <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret)) <*> addTickLPat pat+ <*> pure ctxt addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc -> TM (ParStmtBlock GhcTc GhcTc)@@ -1038,7 +1040,7 @@ coveragePasses dflags = ifa (breakpointsEnabled dflags) Breakpoints $ ifa (gopt Opt_Hpc dflags) HpcTicks $- ifa (gopt Opt_SccProfilingOn dflags &&+ ifa (sccProfilingEnabled dflags && profAuto dflags /= NoProfAuto) ProfNotes $ ifa (debugLevel dflags > 0) SourceNotes [] where ifa f x xs | f = x:xs@@ -1337,7 +1339,7 @@ package_name = hcat (map (text.charToC) $ BS.unpack $ bytesFS (unitFS (moduleUnit this_mod))) full_name_str- | moduleUnit this_mod == mainUnitId+ | moduleUnit this_mod == mainUnit = module_name | otherwise = package_name <> char '/' <> module_name
compiler/GHC/HsToCore/Docs.hs view
@@ -1,12 +1,13 @@--- | Extract docs from the renamer output so they can be be serialized.+-- | Extract docs from the renamer output so they can be serialized. {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -module GHC.HsToCore.Docs (extractDocs) where+module GHC.HsToCore.Docs where import GHC.Prelude import GHC.Data.Bag@@ -97,13 +98,7 @@ instanceMap = M.fromList [(l, n) | n <- instances, RealSrcSpan l _ <- [getSrcSpan n] ] names :: RealSrcSpan -> HsDecl GhcRn -> [Name]- names l (InstD _ d) = maybeToList $ -- See Note [1].- case d of- TyFamInstD _ _ -> M.lookup l instanceMap- -- The CoAx's loc is the whole line, but only- -- for TFs- _ -> lookupSrcSpan (getInstLoc d) instanceMap-+ names _ (InstD _ d) = maybeToList $ lookupSrcSpan (getInstLoc d) instanceMap names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See Note [1]. names _ decl = getMainDeclBinder decl @@ -145,14 +140,19 @@ getInstLoc :: InstDecl (GhcPass p) -> SrcSpan getInstLoc = \case ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc (hsSigType ty)+ -- The Names of data and type family instances have their SrcSpan's attached+ -- to the *type constructor*. For example, the Name "D:R:Foo:Int" would have+ -- its SrcSpan attached here:+ -- type family Foo a+ -- type instance Foo Int = Bool+ -- ^^^ DataFamInstD _ (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}}) -> l+ -- Since CoAxioms' Names refer to the whole line for type family instances+ -- in particular, we need to dig a bit deeper to pull out the entire+ -- equation. This does not happen for data family instances, for some reason. TyFamInstD _ (TyFamInstDecl- -- Since CoAxioms' Names refer to the whole line for type family instances- -- in particular, we need to dig a bit deeper to pull out the entire- -- equation. This does not happen for data family instances, for some- -- reason.- { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}}) -> l+ { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}}) -> l -- | Get all subordinate declarations inside a declaration, and their docs. -- A subordinate declaration is something like the associate type or data@@ -200,7 +200,7 @@ extract_deriv_ty (L l ty) = case ty of -- deriving (forall a. C a {- ^ Doc comment -})- HsForAllTy{ hst_fvf = ForallInvis+ HsForAllTy{ hst_tele = HsForAllInvis{} , hst_body = L _ (HsDocTy _ _ doc) } -> Just (l, doc) -- deriving (C a {- ^ Doc comment -})@@ -210,13 +210,15 @@ -- | Extract constructor argument docs from inside constructor decls. conArgDocs :: ConDecl GhcRn -> Map Int (HsDocString) conArgDocs con = case getConArgs con of- PrefixCon args -> go 0 (map unLoc args ++ ret)- InfixCon arg1 arg2 -> go 0 ([unLoc arg1, unLoc arg2] ++ ret)+ PrefixCon args -> go 0 (map (unLoc . hsScaledThing) args ++ ret)+ InfixCon arg1 arg2 -> go 0 ([unLoc (hsScaledThing arg1),+ unLoc (hsScaledThing arg2)] ++ ret) RecCon _ -> go 1 ret where go n = M.fromList . catMaybes . zipWith f [n..] where f n (HsDocTy _ _ lds) = Just (n, unLoc lds)+ f n (HsBangTy _ _ (L _ (HsDocTy _ _ lds))) = Just (n, unLoc lds) f _ _ = Nothing ret = case con of@@ -254,7 +256,7 @@ go _ [] = [] go s (x:xs) | y `elemNameSet` s = go s xs- | otherwise = let s' = extendNameSet s y+ | otherwise = let !s' = extendNameSet s y in x : go s' xs where y = f x@@ -264,12 +266,12 @@ typeDocs = go 0 where go n = \case- HsForAllTy { hst_body = ty } -> go n (unLoc ty)- HsQualTy { hst_body = ty } -> go n (unLoc ty)- HsFunTy _ (unLoc->HsDocTy _ _ x) ty -> M.insert n (unLoc x) $ go (n+1) (unLoc ty)- HsFunTy _ _ ty -> go (n+1) (unLoc ty)- HsDocTy _ _ doc -> M.singleton n (unLoc doc)- _ -> M.empty+ HsForAllTy { hst_body = ty } -> go n (unLoc ty)+ HsQualTy { hst_body = ty } -> go n (unLoc ty)+ HsFunTy _ _ (unLoc->HsDocTy _ _ x) ty -> M.insert n (unLoc x) $ go (n+1) (unLoc ty)+ HsFunTy _ _ _ ty -> go (n+1) (unLoc ty)+ HsDocTy _ _ doc -> M.singleton n (unLoc doc)+ _ -> M.empty -- | The top-level declarations of a module that we care about, -- ordered by source location, with documentation attached if it exists.
compiler/GHC/HsToCore/Expr.hs view
@@ -45,6 +45,7 @@ import GHC.Tc.Types.Evidence import GHC.Tc.Utils.Monad import GHC.Core.Type+import GHC.Core.Multiplicity import GHC.Core import GHC.Core.Utils import GHC.Core.Make@@ -220,7 +221,9 @@ eqn = EqnInfo { eqn_pats = [upat], eqn_orig = FromSource, eqn_rhs = cantFailMatchResult body }- ; var <- selectMatchVar upat+ ; var <- selectMatchVar Many upat+ -- `var` will end up in a let binder, so the multiplicity+ -- doesn't matter. ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body) ; return (bindNonRec var rhs result) } @@ -248,8 +251,8 @@ -- | Variant of 'dsLExpr' that ensures that the result is not levity -- polymorphic. This should be used when the resulting expression will -- be an argument to some other function.--- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad--- See Note [Levity polymorphism invariants] in GHC.Core+-- See Note [Levity polymorphism checking] in "GHC.HsToCore.Monad"+-- See Note [Levity polymorphism invariants] in "GHC.Core" dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr dsLExprNoLP (L loc e) = putSrcSpanDs loc $@@ -398,7 +401,7 @@ -- Binary operator section (x_ty:y_ty:_, _) -> do dsWhenNoErrs- (mapM newSysLocalDsNoLP [x_ty, y_ty])+ (newSysLocalsDsNoLP [x_ty, y_ty]) (\[x_id, y_id] -> bindNonRec x_id x_core $ Lam y_id (mkCoreAppsDs (text "sectionl" <+> ppr e)@@ -417,16 +420,16 @@ core_op <- dsLExpr op let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op) y_core <- dsLExpr expr- dsWhenNoErrs (mapM newSysLocalDsNoLP [x_ty, y_ty])+ dsWhenNoErrs (newSysLocalsDsNoLP [x_ty, y_ty]) (\[x_id, y_id] -> bindNonRec y_id y_core $ Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e) core_op [Var x_id, Var y_id])) dsExpr (ExplicitTuple _ tup_args boxity)- = do { let go (lam_vars, args) (L _ (Missing ty))+ = do { let go (lam_vars, args) (L _ (Missing (Scaled mult ty))) -- For every missing expression, we need -- another lambda in the desugaring.- = do { lam_var <- newSysLocalDsNoLP ty+ = do { lam_var <- newSysLocalDsNoLP mult ty ; return (lam_var : lam_vars, Var lam_var : args) } go (lam_vars, args) (L _ (Present _ expr)) -- Expressions that are present don't generate@@ -436,8 +439,9 @@ ; dsWhenNoErrs (foldM go ([], []) (reverse tup_args)) -- The reverse is because foldM goes left-to-right- (\(lam_vars, args) -> mkCoreLams lam_vars $- mkCoreTupBoxity boxity args) }+ (\(lam_vars, args) ->+ mkCoreLams lam_vars $+ mkCoreTupBoxity boxity args) } -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make dsExpr (ExplicitSum types alt arity expr)@@ -465,16 +469,16 @@ -- because the interpretation of `stmts' depends on what sort of thing it is. -- dsExpr (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty-dsExpr (HsDo _ DoExpr (L _ stmts)) = dsDo stmts-dsExpr (HsDo _ GhciStmtCtxt (L _ stmts)) = dsDo stmts-dsExpr (HsDo _ MDoExpr (L _ stmts)) = dsDo stmts+dsExpr (HsDo _ ctx@DoExpr{} (L _ stmts)) = dsDo ctx stmts+dsExpr (HsDo _ ctx@GhciStmtCtxt (L _ stmts)) = dsDo ctx stmts+dsExpr (HsDo _ ctx@MDoExpr{} (L _ stmts)) = dsDo ctx stmts dsExpr (HsDo _ MonadComp (L _ stmts)) = dsMonadComp stmts dsExpr (HsIf _ fun guard_expr then_expr else_expr) = do { pred <- dsLExpr guard_expr ; b1 <- dsLExpr then_expr ; b2 <- dsLExpr else_expr- ; case fun of -- See Note [Rebindable if] in Hs.Expr+ ; case fun of -- See Note [Rebindable if] in "GHC.Hs.Expr" (SyntaxExprTc {}) -> dsSyntaxExpr fun [pred, b1, b2] NoSyntaxExprTc -> return $ mkIfThenElse pred b1 b2 } @@ -581,8 +585,8 @@ labels = conLikeFieldLabels con_like ; con_args <- if null labels- then mapM unlabelled_bottom arg_tys- else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)+ then mapM unlabelled_bottom (map scaledThing arg_tys)+ else mapM mk_arg (zipEqual "dsExpr:RecordCon" (map scaledThing arg_tys) labels) ; return (mkCoreApps con_expr' con_args) } @@ -646,8 +650,9 @@ ; ([discrim_var], matching_code) <- matchWrapper RecUpd (Just record_expr) -- See Note [Scrutinee in Record updates] (MG { mg_alts = noLoc alts- , mg_ext = MatchGroupTc [in_ty] out_ty- , mg_origin = FromSource })+ , mg_ext = MatchGroupTc [unrestricted in_ty] out_ty+ , mg_origin = FromSource+ }) -- FromSource is not strictly right, but we -- want incomplete pattern-match warnings @@ -662,7 +667,7 @@ ds_field (L _ rec_field) = do { rhs <- dsLExpr (hsRecFieldArg rec_field) ; let fld_id = unLoc (hsRecUpdFieldId rec_field)- ; lcl_id <- newSysLocalDs (idType fld_id)+ ; lcl_id <- newSysLocalDs (idMult fld_id) (idType fld_id) ; return (idName fld_id, lcl_id, rhs) } add_field_binds [] expr = expr@@ -681,6 +686,9 @@ mk_alt upd_fld_env con = do { let (univ_tvs, ex_tvs, eq_spec, prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con+ arg_tys' = map (scaleScaled Many) arg_tys+ -- Record updates consume the source record with multiplicity+ -- Many. Therefore all the fields need to be scaled thus. user_tvs = binderVars $ conLikeUserTyVarBinders con in_subst = zipTvSubst univ_tvs in_inst_tys out_subst = zipTvSubst univ_tvs out_inst_tys@@ -688,7 +696,7 @@ -- I'm not bothering to clone the ex_tvs ; eqs_vars <- mapM newPredVarDs (substTheta in_subst (eqSpecPreds eq_spec)) ; theta_vars <- mapM newPredVarDs (substTheta in_subst prov_theta)- ; arg_ids <- newSysLocalsDs (substTysUnchecked in_subst arg_tys)+ ; arg_ids <- newSysLocalsDs (substScaledTysUnchecked in_subst arg_tys') ; let field_labels = conLikeFieldLabels con val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg field_labels arg_ids@@ -805,7 +813,7 @@ ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr ds_prag_expr (HsPragSCC _ _ cc) expr = do dflags <- getDynFlags- if gopt Opt_SccProfilingOn dflags+ if sccProfilingEnabled dflags then do mod_name <- getModule count <- goptM Opt_ProfCountEntries@@ -932,8 +940,9 @@ dsArithSeq expr (From from) = App <$> dsExpr expr <*> dsLExprNoLP from dsArithSeq expr (FromTo from to)- = do dflags <- getDynFlags- warnAboutEmptyEnumerations dflags from Nothing to+ = do fam_envs <- dsGetFamInstEnvs+ dflags <- getDynFlags+ warnAboutEmptyEnumerations fam_envs dflags from Nothing to expr' <- dsExpr expr from' <- dsLExprNoLP from to' <- dsLExprNoLP to@@ -941,8 +950,9 @@ dsArithSeq expr (FromThen from thn) = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn] dsArithSeq expr (FromThenTo from thn to)- = do dflags <- getDynFlags- warnAboutEmptyEnumerations dflags from (Just thn) to+ = do fam_envs <- dsGetFamInstEnvs+ dflags <- getDynFlags+ warnAboutEmptyEnumerations fam_envs dflags from (Just thn) to expr' <- dsExpr expr from' <- dsLExprNoLP from thn' <- dsLExprNoLP thn@@ -955,8 +965,8 @@ Haskell 98 report: -} -dsDo :: [ExprLStmt GhcTc] -> DsM CoreExpr-dsDo stmts+dsDo :: HsStmtContext GhcRn -> [ExprLStmt GhcTc] -> DsM CoreExpr+dsDo ctx stmts = goL stmts where goL [] = panic "dsDo"@@ -979,8 +989,8 @@ go _ (BindStmt xbs pat rhs) stmts = do { body <- goL stmts ; rhs' <- dsLExpr rhs- ; var <- selectSimpleMatchVarL pat- ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat+ ; var <- selectSimpleMatchVarL (xbstc_boundResultMult xbs) pat+ ; match <- matchSinglePatVar var (StmtCtxt ctx) pat (xbstc_boundResultType xbs) (cantFailMatchResult body) ; match_code <- dsHandleMonadicFailure pat match (xbstc_failOp xbs) ; dsSyntaxExpr (xbstc_bindOp xbs) [rhs', Lam var match_code] }@@ -992,16 +1002,16 @@ do_arg (ApplicativeArgOne fail_op pat expr _) = ((pat, fail_op), dsLExpr expr)- do_arg (ApplicativeArgMany _ stmts ret pat) =- ((pat, Nothing), dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))+ do_arg (ApplicativeArgMany _ stmts ret pat _) =+ ((pat, Nothing), dsDo ctx (stmts ++ [noLoc $ mkLastStmt (noLoc ret)])) ; rhss' <- sequence rhss - ; body' <- dsLExpr $ noLoc $ HsDo body_ty DoExpr (noLoc stmts)+ ; body' <- dsLExpr $ noLoc $ HsDo body_ty ctx (noLoc stmts) ; let match_args (pat, fail_op) (vs,body)- = do { var <- selectSimpleMatchVarL pat- ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat+ = do { var <- selectSimpleMatchVarL Many pat+ ; match <- matchSinglePatVar var (StmtCtxt ctx) pat body_ty (cantFailMatchResult body) ; match_code <- dsHandleMonadicFailure pat match fail_op ; return (var:vs, match_code)@@ -1028,6 +1038,7 @@ XBindStmtTc { xbstc_bindOp = bind_op , xbstc_boundResultType = bind_ty+ , xbstc_boundResultMult = Many , xbstc_failOp = Nothing -- Tuple cannot fail } (mkBigLHsPatTupId later_pats)@@ -1043,11 +1054,11 @@ (MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr [mfix_pat] body]- , mg_ext = MatchGroupTc [tup_ty] body_ty+ , mg_ext = MatchGroupTc [unrestricted tup_ty] body_ty , mg_origin = Generated }) mfix_pat = noLoc $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats body = noLoc $ HsDo body_ty- DoExpr (noLoc (rec_stmts ++ [ret_stmt]))+ ctx (noLoc (rec_stmts ++ [ret_stmt])) ret_app = nlHsSyntaxApps return_op [mkBigLHsTupId rets] ret_stmt = noLoc $ mkLastStmt ret_app -- This LastStmt will be desugared with dsDo,
compiler/GHC/HsToCore/Foreign/Call.hs view
@@ -37,6 +37,7 @@ import GHC.Tc.Utils.TcType import GHC.Core.Type+import GHC.Core.Multiplicity import GHC.Types.Id ( Id ) import GHC.Core.Coercion import GHC.Builtin.PrimOps@@ -58,7 +59,7 @@ desired. The state stuff just consists of adding in-@PrimIO (\ s -> case s of { S# s# -> ... })@ in an appropriate place.+@PrimIO (\ s -> case s of { State# s# -> ... })@ in an appropriate place. The unboxing is straightforward, as all information needed to unbox is available from the type. For each boxed-primitive argument, we@@ -125,7 +126,7 @@ mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args where arg_tys = map exprType val_args- body_ty = (mkVisFunTys arg_tys res_ty)+ body_ty = (mkVisFunTysMany arg_tys res_ty) tyvars = tyCoVarsOfTypeWellScoped body_ty ty = mkInfForAllTys tyvars body_ty the_fcall_id = mkFCallId dflags uniq the_fcall ty@@ -154,7 +155,7 @@ tc `hasKey` boolTyConKey = do dflags <- getDynFlags let platform = targetPlatform dflags- prim_arg <- newSysLocalDs intPrimTy+ prim_arg <- newSysLocalDs Many intPrimTy return (Var prim_arg, \ body -> Case (mkIfThenElse arg (mkIntLit platform 1) (mkIntLit platform 0)) prim_arg@@ -166,8 +167,8 @@ | is_product_type && data_con_arity == 1 = ASSERT2(isUnliftedType data_con_arg_ty1, pprType arg_ty) -- Typechecker ensures this- do case_bndr <- newSysLocalDs arg_ty- prim_arg <- newSysLocalDs data_con_arg_ty1+ do case_bndr <- newSysLocalDs Many arg_ty+ prim_arg <- newSysLocalDs Many data_con_arg_ty1 return (Var prim_arg, \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)] )@@ -181,8 +182,8 @@ isJust maybe_arg3_tycon && (arg3_tycon == byteArrayPrimTyCon || arg3_tycon == mutableByteArrayPrimTyCon)- = do case_bndr <- newSysLocalDs arg_ty- vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys+ = do case_bndr <- newSysLocalDs Many arg_ty+ vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs (map unrestricted data_con_arg_tys) return (Var arr_cts_var, \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)] )@@ -194,7 +195,8 @@ arg_ty = exprType arg maybe_product_type = splitDataProductType_maybe arg_ty is_product_type = isJust maybe_product_type- Just (_, _, data_con, data_con_arg_tys) = maybe_product_type+ Just (_, _, data_con, scaled_data_con_arg_tys) = maybe_product_type+ data_con_arg_tys = map scaledThing scaled_data_con_arg_tys data_con_arity = dataConSourceArity data_con (data_con_arg_ty1 : _) = data_con_arg_tys @@ -240,7 +242,7 @@ ; (ccall_res_ty, the_alt) <- mk_alt return_result res - ; state_id <- newSysLocalDs realWorldStatePrimTy+ ; state_id <- newSysLocalDs Many realWorldStatePrimTy ; let io_data_con = head (tyConDataCons io_tycon) toIOCon = dataConWrapId io_data_con @@ -249,12 +251,12 @@ [ Type io_res_ty, Lam state_id $ mkWildCase (App the_call (Var state_id))- ccall_res_ty+ (unrestricted ccall_res_ty) (coreAltType the_alt) [the_alt] ] - ; return (realWorldStatePrimTy `mkVisFunTy` ccall_res_ty, wrap) }+ ; return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap) } boxResult result_ty = do -- It isn't IO, so do unsafePerformIO@@ -263,10 +265,10 @@ (ccall_res_ty, the_alt) <- mk_alt return_result res let wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId))- ccall_res_ty+ (unrestricted ccall_res_ty) (coreAltType the_alt) [the_alt]- return (realWorldStatePrimTy `mkVisFunTy` ccall_res_ty, wrap)+ return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap) where return_result _ [ans] = ans return_result _ _ = panic "return_result: expected single result"@@ -277,7 +279,7 @@ -> DsM (Type, (AltCon, [Id], Expr Var)) mk_alt return_result (Nothing, wrap_result) = do -- The ccall returns ()- state_id <- newSysLocalDs realWorldStatePrimTy+ state_id <- newSysLocalDs Many realWorldStatePrimTy let the_rhs = return_result (Var state_id) [wrap_result (panic "boxResult")]@@ -291,8 +293,8 @@ = -- The ccall returns a non-() value ASSERT2( isPrimitiveType prim_res_ty, ppr prim_res_ty ) -- True because resultWrapper ensures it is so- do { result_id <- newSysLocalDs prim_res_ty- ; state_id <- newSysLocalDs realWorldStatePrimTy+ do { result_id <- newSysLocalDs Many prim_res_ty+ ; state_id <- newSysLocalDs Many realWorldStatePrimTy ; let the_rhs = return_result (Var state_id) [wrap_result (Var result_id)] ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty]@@ -322,7 +324,7 @@ -- Base case 2: the unit type () | Just (tc,_) <- maybe_tc_app , tc `hasKey` unitTyConKey- = return (Nothing, \_ -> Var unitDataConId)+ = return (Nothing, \_ -> unitExpr) -- Base case 3: the boolean type | Just (tc,_) <- maybe_tc_app@@ -330,7 +332,7 @@ = do { dflags <- getDynFlags ; let platform = targetPlatform dflags ; let marshal_bool e- = mkWildCase e intPrimTy boolTy+ = mkWildCase e (unrestricted intPrimTy) boolTy [ (DEFAULT ,[],Var trueDataConId ) , (LitAlt (mkLitInt platform 0),[],Var falseDataConId)] ; return (Just intPrimTy, marshal_bool) }@@ -350,7 +352,7 @@ -- This includes types like Ptr and ForeignPtr | Just (tycon, tycon_arg_tys) <- maybe_tc_app , Just data_con <- isDataProductTyCon_maybe tycon -- One constructor, no existentials- , [unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys -- One argument+ , [Scaled _ unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys -- One argument = do { dflags <- getDynFlags ; let platform = targetPlatform dflags ; (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty
compiler/GHC/HsToCore/Foreign/Decl.hs view
@@ -36,6 +36,7 @@ import GHC.Types.RepType import GHC.Core.TyCon import GHC.Core.Coercion+import GHC.Core.Multiplicity import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcType @@ -257,7 +258,7 @@ mHeadersArgTypeList = [ (header, cType <+> char 'a' <> int n) | (t, n) <- zip arg_tys [1..]- , let (header, cType) = toCType t ]+ , let (header, cType) = toCType (scaledThing t) ] (mHeaders, argTypeList) = unzip mHeadersArgTypeList argTypes = if null argTypeList then text "void"@@ -272,11 +273,11 @@ return (fcall, empty) let -- Build the worker- worker_ty = mkForAllTys tv_bndrs (mkVisFunTys (map idType work_arg_ids) ccall_result_ty)+ worker_ty = mkForAllTys tv_bndrs (mkVisFunTysMany (map idType work_arg_ids) ccall_result_ty) tvs = map binderVar tv_bndrs the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app)- work_id = mkSysLocal (fsLit "$wccall") work_uniq worker_ty+ work_id = mkSysLocal (fsLit "$wccall") work_uniq Many worker_ty -- Build the wrapper work_app = mkApps (mkVarApps (Var work_id) tvs) val_args@@ -428,14 +429,14 @@ (moduleStableString mod ++ "$" ++ toCName dflags id) -- Construct the label based on the passed id, don't use names -- depending on Unique. See #13807 and Note [Unique Determinism].- cback <- newSysLocalDs arg_ty+ cback <- newSysLocalDs arg_mult arg_ty newStablePtrId <- dsLookupGlobalId newStablePtrName stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName let stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]- export_ty = mkVisFunTy stable_ptr_ty arg_ty+ export_ty = mkVisFunTyMany stable_ptr_ty arg_ty bindIOId <- dsLookupGlobalId bindIOName- stbl_value <- newSysLocalDs stable_ptr_ty+ stbl_value <- newSysLocalDs Many stable_ptr_ty (h_code, c_code, typestring, args_size) <- dsFExport id (mkRepReflCo export_ty) fe_nm cconv True let {-@@ -482,7 +483,7 @@ where ty = coercionLKind co0 (tvs,sans_foralls) = tcSplitForAllTys ty- ([arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls+ ([Scaled arg_mult arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls Just (io_tc, res_ty) = tcSplitIOType_maybe fn_res_ty -- Must have an IO type; hence Just @@ -533,15 +534,36 @@ SDoc, -- C type Type, -- Haskell type CmmType)] -- the CmmType- arg_info = [ let stg_type = showStgType ty in- (arg_cname n stg_type,+ arg_info = [ let stg_type = showStgType ty+ cmm_type = typeCmmType platform (getPrimTyOf ty)+ stack_type+ = if int_promote (typeTyCon ty)+ then text "HsWord"+ else stg_type+ in+ (arg_cname n stg_type stack_type, stg_type, ty,- typeCmmType platform (getPrimTyOf ty))+ cmm_type) | (ty,n) <- zip arg_htys [1::Int ..] ] - arg_cname n stg_ty- | libffi = char '*' <> parens (stg_ty <> char '*') <>+ int_promote ty_con+ | ty_con `hasKey` int8TyConKey = True+ | ty_con `hasKey` int16TyConKey = True+ | ty_con `hasKey` int32TyConKey+ , platformWordSizeInBytes platform > 4+ = True+ | ty_con `hasKey` word8TyConKey = True+ | ty_con `hasKey` word16TyConKey = True+ | ty_con `hasKey` word32TyConKey+ , platformWordSizeInBytes platform > 4+ = True+ | otherwise = False+++ arg_cname n stg_ty stack_ty+ | libffi = parens (stg_ty) <> char '*' <>+ parens (stack_ty <> char '*') <> text "args" <> brackets (int (n-1)) | otherwise = text ('a':show n) @@ -792,7 +814,7 @@ -- with a single primitive-typed argument (see TcType.legalFEArgTyCon). | otherwise = case splitDataProductType_maybe rep_ty of- Just (_, _, data_con, [prim_ty]) ->+ Just (_, _, data_con, [Scaled _ prim_ty]) -> ASSERT(dataConSourceArity data_con == 1) ASSERT2(isUnliftedType prim_ty, ppr prim_ty) prim_ty
compiler/GHC/HsToCore/GuardedRHSs.hs view
@@ -30,6 +30,7 @@ import GHC.Utils.Misc import GHC.Types.SrcLoc import GHC.Utils.Outputable+import GHC.Core.Multiplicity import Control.Monad ( zipWithM ) import Data.List.NonEmpty ( NonEmpty, toList ) @@ -124,7 +125,10 @@ matchGuards (BindStmt _ pat bind_rhs : stmts) ctx rhs rhs_ty = do let upat = unLoc pat- match_var <- selectMatchVar upat+ match_var <- selectMatchVar Many upat+ -- We only allow unrestricted patterns in guard, hence the `Many`+ -- above. It isn't clear what linear patterns would mean, maybe we will+ -- figure it out in the future. match_result <- matchGuards stmts ctx rhs rhs_ty core_rhs <- dsLExpr bind_rhs
compiler/GHC/HsToCore/ListComp.hs view
@@ -278,11 +278,11 @@ let u2_ty = hsLPatType pat let res_ty = exprType core_list2- h_ty = u1_ty `mkVisFunTy` res_ty+ h_ty = u1_ty `mkVisFunTyMany` res_ty -- no levity polymorphism here, as list comprehensions don't work -- with RebindableSyntax. NB: These are *not* monad comps.- [h, u1, u2, u3] <- newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]+ [h, u1, u2, u3] <- newSysLocalsDs $ map unrestricted [h_ty, u1_ty, u2_ty, u3_ty] -- the "fail" value ... let@@ -371,8 +371,8 @@ let b_ty = idType n_id -- create some new local id's- b <- newSysLocalDs b_ty- x <- newSysLocalDs x_ty+ b <- newSysLocalDs Many b_ty+ x <- newSysLocalDs Many x_ty -- build rest of the comprehension core_rest <- dfListComp c_id b quals@@ -402,11 +402,11 @@ -- (a2:as'2) -> (a1, a2) : zip as'1 as'2)] mkZipBind elt_tys = do- ass <- mapM newSysLocalDs elt_list_tys- as' <- mapM newSysLocalDs elt_tys- as's <- mapM newSysLocalDs elt_list_tys+ ass <- mapM (newSysLocalDs Many) elt_list_tys+ as' <- mapM (newSysLocalDs Many) elt_tys+ as's <- mapM (newSysLocalDs Many) elt_list_tys - zip_fn <- newSysLocalDs zip_fn_ty+ zip_fn <- newSysLocalDs Many zip_fn_ty let inner_rhs = mkConsExpr elt_tuple_ty (mkBigCoreVarTup as')@@ -419,7 +419,7 @@ elt_tuple_ty = mkBigCoreTupTy elt_tys elt_tuple_list_ty = mkListTy elt_tuple_ty - zip_fn_ty = mkVisFunTys elt_list_tys elt_tuple_list_ty+ zip_fn_ty = mkVisFunTysMany elt_list_tys elt_tuple_list_ty mk_case (as, a', as') rest = Case (Var as) as elt_tuple_list_ty@@ -441,13 +441,13 @@ mkUnzipBind ThenForm _ = return Nothing -- No unzipping for ThenForm mkUnzipBind _ elt_tys- = do { ax <- newSysLocalDs elt_tuple_ty- ; axs <- newSysLocalDs elt_list_tuple_ty- ; ys <- newSysLocalDs elt_tuple_list_ty- ; xs <- mapM newSysLocalDs elt_tys- ; xss <- mapM newSysLocalDs elt_list_tys+ = do { ax <- newSysLocalDs Many elt_tuple_ty+ ; axs <- newSysLocalDs Many elt_list_tuple_ty+ ; ys <- newSysLocalDs Many elt_tuple_list_ty+ ; xs <- mapM (newSysLocalDs Many) elt_tys+ ; xss <- mapM (newSysLocalDs Many) elt_list_tys - ; unzip_fn <- newSysLocalDs unzip_fn_ty+ ; unzip_fn <- newSysLocalDs Many unzip_fn_ty ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply] @@ -467,7 +467,7 @@ elt_list_tys = map mkListTy elt_tys elt_list_tuple_ty = mkBigCoreTupTy elt_list_tys - unzip_fn_ty = elt_tuple_list_ty `mkVisFunTy` elt_list_tuple_ty+ unzip_fn_ty = elt_tuple_list_ty `mkVisFunTyMany` elt_list_tuple_ty mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail @@ -551,8 +551,8 @@ ; let tup_n_ty' = mkBigCoreVarTupTy to_bndrs ; body <- dsMcStmts stmts_rest- ; n_tup_var' <- newSysLocalDsNoLP n_tup_ty'- ; tup_n_var' <- newSysLocalDs tup_n_ty'+ ; n_tup_var' <- newSysLocalDsNoLP Many n_tup_ty'+ ; tup_n_var' <- newSysLocalDs Many tup_n_ty' ; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys ; us <- newUniqueSupply ; let rhs' = mkApps usingExpr' usingArgs'@@ -601,7 +601,7 @@ -- \x. case x of (a,b,c) -> body matchTuple ids body = do { us <- newUniqueSupply- ; tup_id <- newSysLocalDs (mkBigCoreVarTupTy ids)+ ; tup_id <- newSysLocalDs Many (mkBigCoreVarTupTy ids) ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) } -- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a@@ -615,8 +615,8 @@ -> DsM CoreExpr dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts = do { body <- dsMcStmts stmts- ; var <- selectSimpleMatchVarL pat- ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat+ ; var <- selectSimpleMatchVarL Many pat+ ; match <- matchSinglePatVar var (StmtCtxt (DoExpr Nothing)) pat res1_ty (cantFailMatchResult body) ; match_code <- dsHandleMonadicFailure pat match fail_op ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }@@ -647,7 +647,7 @@ -- , fmap (selN2 :: (t1, t2) -> t2) ys ) mkMcUnzipM :: TransForm- -> HsExpr GhcTcId -- fmap+ -> HsExpr GhcTc -- fmap -> Id -- Of type n (a,b,c) -> [Type] -- [a,b,c] (not levity-polymorphic) -> DsM CoreExpr -- Of type (n a, n b, n c)@@ -656,9 +656,9 @@ mkMcUnzipM _ fmap_op ys elt_tys = do { fmap_op' <- dsExpr fmap_op- ; xs <- mapM newSysLocalDs elt_tys+ ; xs <- mapM (newSysLocalDs Many) elt_tys ; let tup_ty = mkBigCoreTupTy elt_tys- ; tup_xs <- newSysLocalDs tup_ty+ ; tup_xs <- newSysLocalDs Many tup_ty ; let mk_elt i = mkApps fmap_op' -- fmap :: forall a b. (a -> b) -> n a -> n b [ Type tup_ty, Type (getNth elt_tys i)
compiler/GHC/HsToCore/Match.hs view
@@ -52,13 +52,14 @@ import GHC.Core.Type import GHC.Core.Coercion ( eqCoercion ) import GHC.Core.TyCon ( isNewTyCon )+import GHC.Core.Multiplicity import GHC.Builtin.Types import GHC.Types.SrcLoc import GHC.Data.Maybe import GHC.Utils.Misc import GHC.Types.Name import GHC.Utils.Outputable-import GHC.Types.Basic ( isGenerated, il_value, fl_value )+import GHC.Types.Basic ( isGenerated, il_value, fl_value, Boxity(..) ) import GHC.Data.FastString import GHC.Types.Unique import GHC.Types.Unique.DFM@@ -171,9 +172,14 @@ type MatchId = Id -- See Note [Match Ids] -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)+match :: [MatchId] -- ^ Variables rep\'ing the exprs we\'re matching with+ -- ^ See Note [Match Ids]+ --+ -- ^ Note that the Match Ids carry not only a name, but+ -- ^ also the multiplicity at which each column has been+ -- ^ type checked.+ -> Type -- ^ Type of the case expression+ -> [EquationInfo] -- ^ Info about patterns, etc. (type synonym below) -> DsM (MatchResult CoreExpr) -- ^ Desugared result! match [] ty eqns@@ -251,7 +257,7 @@ matchEmpty var res_ty = return [MR_Fallible mk_seq] where- mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty+ mk_seq fail = return $ mkWildCase (Var var) (idScaledType var) res_ty [(DEFAULT, [], fail)] matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)@@ -270,7 +276,7 @@ matchCoercion (var :| vars) ty (eqns@(eqn1 :| _)) = do { let XPat (CoPat co pat _) = firstPat eqn1 ; let pat_ty' = hsPatType pat- ; var' <- newUniqueId var pat_ty'+ ; var' <- newUniqueId var (idMult var) pat_ty' ; match_result <- match (var':vars) ty $ NEL.toList $ decomposeFirstPat getCoPat <$> eqns ; core_wrap <- dsHsWrapper co@@ -286,7 +292,7 @@ let ViewPat _ viewExpr (L _ pat) = firstPat eqn1 -- do the rest of the compilation ; let pat_ty' = hsPatType pat- ; var' <- newUniqueId var pat_ty'+ ; var' <- newUniqueId var (idMult var) pat_ty' ; match_result <- match (var':vars) ty $ NEL.toList $ decomposeFirstPat getViewPat <$> eqns -- compile the view expressions@@ -300,7 +306,7 @@ -- Since overloaded list patterns are treated as view patterns, -- the code is roughly the same as for matchView = do { let ListPat (ListPatTc elt_ty (Just (_,e))) _ = firstPat eqn1- ; var' <- newUniqueId var (mkListTy elt_ty) -- we construct the overall type by hand+ ; var' <- newUniqueId var (idMult var) (mkListTy elt_ty) -- we construct the overall type by hand ; match_result <- match (var':vars) ty $ NEL.toList $ decomposeFirstPat getOLPat <$> eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern ; e' <- dsSyntaxExpr e [Var var]@@ -469,12 +475,17 @@ = return (idDsWrapper, unLoc tuple_ConPat) where arity = length pats- tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys+ tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys'+ tys' = case boxity of+ Unboxed -> map getRuntimeRep tys ++ tys+ Boxed -> tys+ -- See Note [Unboxed tuple RuntimeRep vars] in TyCon tidy1 _ _ (SumPat tys pat alt arity) = return (idDsWrapper, unLoc sum_ConPat) where- sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] tys+ sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] (map getRuntimeRep tys ++ tys)+ -- See Note [Unboxed tuple RuntimeRep vars] in TyCon -- LitPats: we *might* be able to replace these w/ a simpler form tidy1 _ o (LitPat _ lit)@@ -532,7 +543,7 @@ -- Newtypes: push bang inwards (#9844) = if isNewTyCon (dataConTyCon dc)- then tidy1 v o (p { pat_args = push_bang_into_newtype_arg l ty args })+ then tidy1 v o (p { pat_args = push_bang_into_newtype_arg l (scaledThing ty) args }) else tidy1 v o p -- Data types: discard the bang where (ty:_) = dataConInstArgTys dc arg_tys@@ -745,8 +756,12 @@ ; locn <- getSrcSpanDs ; new_vars <- case matches of- [] -> mapM newSysLocalDsNoLP arg_tys- (m:_) -> selectMatchVars (map unLoc (hsLMatchPats m))+ [] -> newSysLocalsDsNoLP arg_tys+ (m:_) ->+ selectMatchVars (zipWithEqual "matchWrapper"+ (\a b -> (scaledMult a, unLoc b))+ arg_tys+ (hsLMatchPats m)) -- Pattern match check warnings for /this match-group/. -- @rhss_deltas@ is a flat list of covered Deltas for each RHS.@@ -846,7 +861,12 @@ = matchSinglePatVar var ctx pat ty match_result matchSinglePat scrut hs_ctx pat ty match_result- = do { var <- selectSimpleMatchVarL pat+ = do { var <- selectSimpleMatchVarL Many pat+ -- matchSinglePat is only used in matchSimply, which+ -- is used in list comprehension, arrow notation,+ -- and to create field selectors. All of which only+ -- bind unrestricted variables, hence the 'Many'+ -- above. ; match_result' <- matchSinglePatVar var hs_ctx pat ty match_result ; return $ bindNonRec var scrut <$> match_result' }@@ -1089,7 +1109,7 @@ --------- tup_arg (L _ (Present _ e1)) (L _ (Present _ e2)) = lexp e1 e2- tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2+ tup_arg (L _ (Missing (Scaled _ t1))) (L _ (Missing (Scaled _ t2))) = eqType t1 t2 tup_arg _ _ = False ---------
compiler/GHC/HsToCore/Match/Constructor.hs view
@@ -25,6 +25,7 @@ import GHC.Core.ConLike import GHC.Types.Basic ( Origin(..) ) import GHC.Tc.Utils.TcType+import GHC.Core.Multiplicity import GHC.HsToCore.Monad import GHC.HsToCore.Utils import GHC.Core ( CoreExpr )@@ -98,7 +99,13 @@ -> 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+ = do let mult = idMult var+ -- Each variable in the argument list correspond to one column in the+ -- pattern matching equations. Its multiplicity is the context+ -- multiplicity of the pattern. We extract that multiplicity, so that+ -- 'matchOneconLike' knows the context multiplicity, in case it needs+ -- to come up with new variables.+ alts <- mapM (fmap toRealAlt . matchOneConLike vars ty mult) groups return (mkCoAlgCaseMatchResult var ty alts) where toRealAlt alt = case alt_pat alt of@@ -110,7 +117,8 @@ -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) matchPatSyn (var :| vars) ty eqns- = do alt <- fmap toSynAlt $ matchOneConLike vars ty eqns+ = do let mult = idMult var+ alt <- fmap toSynAlt $ matchOneConLike vars ty mult eqns return (mkCoSynCaseMatchResult var ty alt) where toSynAlt alt = case alt_pat alt of@@ -121,9 +129,10 @@ matchOneConLike :: [Id] -> Type+ -> Mult -> NonEmpty EquationInfo -> DsM (CaseAlt ConLike)-matchOneConLike vars ty (eqn1 :| eqns) -- All eqns for a single constructor+matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single constructor = do { let inst_tys = ASSERT( all tcIsTcTyVar ex_tvs ) -- ex_tvs can only be tyvars as data types in source -- Haskell cannot mention covar yet (Aug 2018).@@ -163,8 +172,15 @@ , eqn_pats = conArgPats val_arg_tys args ++ pats } ) shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps)-- ; arg_vars <- selectConMatchVars val_arg_tys args1+ ; let scaled_arg_tys = map (scaleScaled mult) val_arg_tys+ -- The 'val_arg_tys' are taken from the data type definition, they+ -- do not take into account the context multiplicity, therefore we+ -- need to scale them back to get the correct context multiplicity+ -- to desugar the sub-pattern in each field. We need to know these+ -- multiplicity because of the invariant that, in Core, binders in a+ -- constructor pattern must be scaled by the multiplicity of the+ -- case. See Note [Case expression invariants].+ ; arg_vars <- selectConMatchVars scaled_arg_tys args1 -- Use the first equation as a source of -- suggestions for the new variables @@ -229,12 +245,15 @@ ------------------selectConMatchVars :: [Type] -> ConArgPats -> DsM [Id]-selectConMatchVars arg_tys (RecCon {}) = newSysLocalsDsNoLP arg_tys-selectConMatchVars _ (PrefixCon ps) = selectMatchVars (map unLoc ps)-selectConMatchVars _ (InfixCon p1 p2) = selectMatchVars [unLoc p1, unLoc p2]+selectConMatchVars :: [Scaled Type] -> ConArgPats -> DsM [Id]+selectConMatchVars arg_tys con = case con of+ (RecCon {}) -> newSysLocalsDsNoLP arg_tys+ (PrefixCon ps) -> selectMatchVars (zipMults arg_tys ps)+ (InfixCon p1 p2) -> selectMatchVars (zipMults arg_tys [p1, p2])+ where+ zipMults = zipWithEqual "selectConMatchVar" (\a b -> (scaledMult a, unLoc b)) -conArgPats :: [Type] -- Instantiated argument types+conArgPats :: [Scaled Type]-- Instantiated argument types -- Used only to fill in the types of WildPats, which -- are probably never looked at anyway -> ConArgPats@@ -242,7 +261,7 @@ conArgPats _arg_tys (PrefixCon ps) = map unLoc ps conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2] conArgPats arg_tys (RecCon (HsRecFields { rec_flds = rpats }))- | null rpats = map WildPat arg_tys+ | null rpats = map WildPat (map scaledThing arg_tys) -- Important special case for C {}, which can be used for a -- datacon that isn't declared to have fields at all | otherwise = map (unLoc . hsRecFieldArg . unLoc) rpats
compiler/GHC/HsToCore/Match/Literal.hs view
@@ -55,6 +55,7 @@ import GHC.Utils.Misc import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt+import GHC.Core.FamInstEnv ( FamInstEnvs, normaliseType ) import Control.Monad import Data.Int@@ -101,13 +102,13 @@ HsDoublePrim _ d -> return (Lit (LitDouble (fl_value d))) HsChar _ c -> return (mkCharExpr c) HsString _ str -> mkStringExprFS str- HsInteger _ i _ -> mkIntegerExpr i+ HsInteger _ i _ -> return (mkIntegerExpr i) HsInt _ i -> return (mkIntExpr platform (il_value i)) HsRat _ (FL _ _ val) ty -> do- num <- mkIntegerExpr (numerator val)- denom <- mkIntegerExpr (denominator val) return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom]) where+ num = mkIntegerExpr (numerator val)+ denom = mkIntegerExpr (denominator val) (ratio_data_con, integer_ty) = case tcSplitTyConApp ty of (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)@@ -148,7 +149,7 @@ warnAboutIdentities dflags (Var conv_fn) type_of_conv | wopt Opt_WarnIdentities dflags , idName conv_fn `elem` conversionNames- , Just (arg_ty, res_ty) <- splitFunTy_maybe type_of_conv+ , Just (_, arg_ty, res_ty) <- splitFunTy_maybe type_of_conv , arg_ty `eqType` res_ty -- So we are converting ty -> ty = warnDs (Reason Opt_WarnIdentities) (vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv@@ -169,14 +170,17 @@ warnAboutOverflowedOverLit :: HsOverLit GhcTc -> DsM () warnAboutOverflowedOverLit hsOverLit = do dflags <- getDynFlags- warnAboutOverflowedLiterals dflags (getIntegralLit hsOverLit)+ fam_envs <- dsGetFamInstEnvs+ warnAboutOverflowedLiterals dflags $+ getIntegralLit hsOverLit >>= getNormalisedTyconName fam_envs -- | Emit warnings on integral literals which overflow the bounds implied by -- their type. warnAboutOverflowedLit :: HsLit GhcTc -> DsM () warnAboutOverflowedLit hsLit = do dflags <- getDynFlags- warnAboutOverflowedLiterals dflags (getSimpleIntegralLit hsLit)+ warnAboutOverflowedLiterals dflags $+ getSimpleIntegralLit hsLit >>= getTyconName -- | Emit warnings on integral literals which overflow the bounds implied by -- their type.@@ -254,15 +258,17 @@ but perhaps that does not matter too much. -} -warnAboutEmptyEnumerations :: DynFlags -> LHsExpr GhcTc -> Maybe (LHsExpr GhcTc)+warnAboutEmptyEnumerations :: FamInstEnvs -> DynFlags -> LHsExpr GhcTc+ -> Maybe (LHsExpr GhcTc) -> LHsExpr GhcTc -> DsM () -- ^ Warns about @[2,3 .. 1]@ which returns the empty list. -- Only works for integral types, not floating point.-warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr+warnAboutEmptyEnumerations fam_envs dflags fromExpr mThnExpr toExpr | wopt Opt_WarnEmptyEnumerations dflags- , Just (from,tc) <- getLHsIntegralLit fromExpr- , Just mThn <- traverse getLHsIntegralLit mThnExpr- , Just (to,_) <- getLHsIntegralLit toExpr+ , Just from_ty@(from,_) <- getLHsIntegralLit fromExpr+ , Just (_, tc) <- getNormalisedTyconName fam_envs from_ty+ , Just mThn <- traverse getLHsIntegralLit mThnExpr+ , Just (to,_) <- getLHsIntegralLit toExpr , let check :: forall a. (Enum a, Num a) => Proxy a -> DsM () check _proxy = when (null enumeration) $@@ -292,7 +298,7 @@ | otherwise = return () -getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name)+getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Type) -- ^ See if the expression is an 'Integral' literal. -- Remember to look through automatically-added tick-boxes! (#8384) getLHsIntegralLit (L _ (HsPar _ e)) = getLHsIntegralLit e@@ -302,25 +308,55 @@ getLHsIntegralLit (L _ (HsLit _ lit)) = getSimpleIntegralLit lit getLHsIntegralLit _ = Nothing --- | If 'Integral', extract the value and type name of the overloaded literal.-getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Name)+-- | If 'Integral', extract the value and type of the overloaded literal.+-- See Note [Literals and the OverloadedLists extension]+getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Type) getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc _ ty })- | Just tc <- tyConAppTyCon_maybe ty- = Just (il_value i, tyConName tc)+ = Just (il_value i, ty) getIntegralLit _ = Nothing --- | If 'Integral', extract the value and type name of the non-overloaded--- literal.-getSimpleIntegralLit :: HsLit GhcTc -> Maybe (Integer, Name)-getSimpleIntegralLit (HsInt _ IL{ il_value = i }) = Just (i, intTyConName)-getSimpleIntegralLit (HsIntPrim _ i) = Just (i, intPrimTyConName)-getSimpleIntegralLit (HsWordPrim _ i) = Just (i, wordPrimTyConName)-getSimpleIntegralLit (HsInt64Prim _ i) = Just (i, int64PrimTyConName)-getSimpleIntegralLit (HsWord64Prim _ i) = Just (i, word64PrimTyConName)-getSimpleIntegralLit (HsInteger _ i ty)- | Just tc <- tyConAppTyCon_maybe ty- = Just (i, tyConName tc)+-- | If 'Integral', extract the value and type of the non-overloaded literal.+getSimpleIntegralLit :: HsLit GhcTc -> Maybe (Integer, Type)+getSimpleIntegralLit (HsInt _ IL{ il_value = i }) = Just (i, intTy)+getSimpleIntegralLit (HsIntPrim _ i) = Just (i, intPrimTy)+getSimpleIntegralLit (HsWordPrim _ i) = Just (i, wordPrimTy)+getSimpleIntegralLit (HsInt64Prim _ i) = Just (i, int64PrimTy)+getSimpleIntegralLit (HsWord64Prim _ i) = Just (i, word64PrimTy)+getSimpleIntegralLit (HsInteger _ i ty) = Just (i, ty) getSimpleIntegralLit _ = Nothing++-- | Convert a pair (Integer, Type) to (Integer, Name) after eventually+-- normalising the type+getNormalisedTyconName :: FamInstEnvs -> (Integer, Type) -> Maybe (Integer, Name)+getNormalisedTyconName fam_envs (i,ty)+ | Just tc <- tyConAppTyCon_maybe (normaliseNominal fam_envs ty)+ = Just (i, tyConName tc)+ | otherwise = Nothing+ where+ normaliseNominal :: FamInstEnvs -> Type -> Type+ normaliseNominal fam_envs ty = snd $ normaliseType fam_envs Nominal ty++-- | Convert a pair (Integer, Type) to (Integer, Name) without normalising+-- the type+getTyconName :: (Integer, Type) -> Maybe (Integer, Name)+getTyconName (i,ty)+ | Just tc <- tyConAppTyCon_maybe ty = Just (i, tyConName tc)+ | otherwise = Nothing++{-+Note [Literals and the OverloadedLists extension]+~~~~+Consider the Literal `[256] :: [Data.Word.Word8]`++When the `OverloadedLists` extension is not active, then the `ol_ext` field+in the `OverLitTc` record that is passed to the function `getIntegralLit`+contains the type `Word8`. This is a simple type, and we can use its+type constructor immediately for the `warnAboutOverflowedLiterals` function.++When the `OverloadedLists` extension is active, then the `ol_ext` field+contains the type family `Item [Word8]`. The function `nomaliseType` is used+to convert it to the needed type `Word8`.+-} {- ************************************************************************
compiler/GHC/HsToCore/Monad.hs view
@@ -79,6 +79,7 @@ import GHC.Utils.Outputable import GHC.Types.SrcLoc import GHC.Core.Type+import GHC.Core.Multiplicity import GHC.Types.Unique.Supply import GHC.Types.Name import GHC.Types.Name.Env@@ -111,7 +112,7 @@ -- ^ The patterns for an equation -- -- NB: We have /already/ applied 'decideBangHood' to- -- these patterns. See Note [decideBangHood] in GHC.HsToCore.Utils+ -- these patterns. See Note [decideBangHood] in "GHC.HsToCore.Utils" , eqn_orig :: Origin -- ^ Was this equation present in the user source?@@ -285,7 +286,7 @@ = let if_genv = IfGblEnv { if_doc = text "mkDsEnvs", if_rec_types = Just (mod, return type_env) } if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)- False -- not boot!+ NotBoot real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1) completeMatchMap = mkCompleteMatchMap complete_matches gbl_env = DsGblEnv { ds_mod = mod@@ -356,7 +357,7 @@ -} -- Make a new Id with the same print name, but different type, and new unique-newUniqueId :: Id -> Type -> DsM Id+newUniqueId :: Id -> Mult -> Type -> DsM Id newUniqueId id = mk_local (occNameFS (nameOccName (idName id))) duplicateLocalDs :: Id -> DsM Id@@ -366,9 +367,9 @@ newPredVarDs :: PredType -> DsM Var newPredVarDs- = mkSysLocalOrCoVarM (fsLit "ds") -- like newSysLocalDs, but we allow covars+ = mkSysLocalOrCoVarM (fsLit "ds") Many -- like newSysLocalDs, but we allow covars -newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Type -> DsM Id+newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Mult -> Type -> DsM Id newSysLocalDsNoLP = mk_local (fsLit "ds") -- this variant should be used when the caller can be sure that the variable type@@ -379,15 +380,15 @@ -- the fail variable is used only in a situation where we can tell that -- levity-polymorphism is impossible. -newSysLocalsDsNoLP, newSysLocalsDs :: [Type] -> DsM [Id]-newSysLocalsDsNoLP = mapM newSysLocalDsNoLP-newSysLocalsDs = mapM newSysLocalDs+newSysLocalsDsNoLP, newSysLocalsDs :: [Scaled Type] -> DsM [Id]+newSysLocalsDsNoLP = mapM (\(Scaled w t) -> newSysLocalDsNoLP w t)+newSysLocalsDs = mapM (\(Scaled w t) -> newSysLocalDs w t) -mk_local :: FastString -> Type -> DsM Id-mk_local fs ty = do { dsNoLevPoly ty (text "When trying to create a variable of type:" <+>- ppr ty) -- could improve the msg with another- -- parameter indicating context- ; mkSysLocalOrCoVarM fs ty }+mk_local :: FastString -> Mult -> Type -> DsM Id+mk_local fs w ty = do { dsNoLevPoly ty (text "When trying to create a variable of type:" <+>+ ppr ty) -- could improve the msg with another+ -- parameter indicating context+ ; mkSysLocalOrCoVarM fs w ty } {- We can also reach out and either set/grab location information from@@ -561,7 +562,7 @@ -- | Fail with an error message if the type is levity polymorphic. dsNoLevPoly :: Type -> SDoc -> DsM () -- See Note [Levity polymorphism checking]-dsNoLevPoly ty doc = checkForLevPolyX errDs doc ty+dsNoLevPoly ty doc = checkForLevPolyX failWithDs doc ty -- | Check an expression for levity polymorphism, failing if it is -- levity polymorphic.
compiler/GHC/HsToCore/PmCheck.hs view
@@ -27,7 +27,7 @@ import GHC.HsToCore.PmCheck.Types import GHC.HsToCore.PmCheck.Oracle import GHC.HsToCore.PmCheck.Ppr-import GHC.Types.Basic (Origin, isGenerated)+import GHC.Types.Basic (Origin(..), isGenerated) import GHC.Core (CoreExpr, Expr(Var,App)) import GHC.Data.FastString (unpackFS, lengthFS) import GHC.Driver.Session@@ -510,7 +510,7 @@ translateConPatOut fam_insts x con arg_tys ex_tvs dicts ps NPat ty (L _ olit) mb_neg _ -> do- -- See Note [Literal short cut] in GHC.HsToCore.Match.Literal.hs+ -- See Note [Literal short cut] in "GHC.HsToCore.Match.Literal" -- We inline the Literal short cut for @ty@ here, because @ty@ is more -- precise than the field of OverLitTc, which is all that dsOverLit (which -- normally does the literal short cut) can look at. Also @ty@ matches the@@ -553,7 +553,7 @@ -- | 'translatePat', but also select and return a new match var. translatePatV :: FamInstEnvs -> Pat GhcTc -> DsM (Id, GrdVec) translatePatV fam_insts pat = do- x <- selectMatchVar pat+ x <- selectMatchVar Many pat grds <- translatePat fam_insts x pat pure (x, grds) @@ -581,7 +581,7 @@ RecCon (HsRecFields fs _) -> go_field_pats (rec_field_ps fs) where -- The actual argument types (instantiated)- arg_tys = conLikeInstOrigArgTys con (univ_tys ++ mkTyVarTys ex_tvs)+ arg_tys = map scaledThing $ conLikeInstOrigArgTys con (univ_tys ++ mkTyVarTys ex_tvs) -- Extract record field patterns tagged by field index from a list of -- LHsRecField@@ -919,7 +919,7 @@ | otherwise = (Precise, new) -- | Matching on a newtype doesn't force anything.--- See Note [Divergence of Newtype matches] in Oracle.+-- See Note [Divergence of Newtype matches] in "GHC.HsToCore.PmCheck.Oracle". conMatchForces :: PmAltCon -> Bool conMatchForces (PmAltConLike (RealDataCon dc)) | isNewTyCon (dataConTyCon dc) = False
compiler/GHC/HsToCore/PmCheck/Oracle.hs view
@@ -96,7 +96,7 @@ mkPmId ty = getUniqueM >>= \unique -> let occname = mkVarOccFS $ fsLit "pm" name = mkInternalName unique occname noSrcSpan- in return (mkLocalIdOrCoVar name ty)+ in return (mkLocalIdOrCoVar name Many ty) ----------------------------------------------- -- * Caching possible matches of a COMPLETE set@@ -145,7 +145,7 @@ -- Instantiate fresh existentials as arguments to the constructor. This is -- important for instantiating the Thetas and field types. (subst, _) <- cloneTyVarBndrs subst_univ ex_tvs <$> getUniqueSupplyM- let field_tys' = substTys subst field_tys+ let field_tys' = substTys subst $ map scaledThing field_tys -- Instantiate fresh term variables (VAs) as arguments to the constructor vars <- mapM mkPmId field_tys' -- All constraints bound by the constructor (alpha-renamed), these are added@@ -199,7 +199,7 @@ -- together as they see fit. newtype SatisfiabilityCheck = SC (Delta -> DsM (Maybe Delta)) --- | Check the given 'Delta' for satisfiability by the the given+-- | Check the given 'Delta' for satisfiability by the given -- 'SatisfiabilityCheck'. Return 'Just' a new, potentially extended, 'Delta' if -- successful, and 'Nothing' otherwise. runSatisfiabilityCheck :: Delta -> SatisfiabilityCheck -> DsM (Maybe Delta)@@ -372,16 +372,9 @@ tyFamStepper :: FamInstEnvs -> NormaliseStepper ([Type] -> [Type], a -> a) tyFamStepper env rec_nts tc tys -- Try to step a type/data family- = let (_args_co, ntys, _res_co) = normaliseTcArgs env Representational tc tys in- -- NB: It's OK to use normaliseTcArgs here instead of- -- normalise_tc_args (which takes the LiftingContext described- -- in Note [Normalising types]) because the reduceTyFamApp below- -- works only at top level. We'll never recur in this function- -- after reducing the kind of a bound tyvar.-- case reduceTyFamApp_maybe env Representational tc ntys of- Just (_co, rhs) -> NS_Step rec_nts rhs ((rhs:), id)- _ -> NS_Done+ = case topReduceTyFamApp_maybe env tc tys of+ Just (_, rhs, _) -> NS_Step rec_nts rhs ((rhs:), id)+ _ -> NS_Done -- | Returns 'True' if the argument 'Type' is a fully saturated application of -- a closed type constructor.@@ -501,7 +494,7 @@ unique <- getUniqueM let occname = mkVarOccFS (fsLit ("pm_"++show unique)) idname = mkInternalName unique occname noSrcSpan- return (mkLocalIdOrCoVar idname pred_ty)+ return (mkLocalIdOrCoVar idname Many pred_ty) -- | Add some extra type constraints to the 'TyState'; return 'Nothing' if we -- find a contradiction (e.g. @Int ~ Bool@).@@ -982,7 +975,7 @@ -- | Guess the universal argument types of a ConLike from an instantiation of -- its result type. Rather easy for DataCons, but not so much for PatSynCons.--- See Note [Pattern synonym result type] in GHC.Core.PatSyn.+-- See Note [Pattern synonym result type] in "GHC.Core.PatSyn". guessConLikeUnivTyArgsFromResTy :: FamInstEnvs -> Type -> ConLike -> Maybe [Type] guessConLikeUnivTyArgsFromResTy env res_ty (RealDataCon _) = do (tc, tc_args) <- splitTyConApp_maybe res_ty@@ -1611,7 +1604,7 @@ instantiate_cons x ty xs n delta (cl:cls) = do env <- dsGetFamInstEnvs case guessConLikeUnivTyArgsFromResTy env ty cl of- Nothing -> pure [delta] -- No idea idea how to refine this one, so just finish off with a wildcard+ Nothing -> pure [delta] -- No idea how to refine this one, so just finish off with a wildcard Just arg_tys -> do (tvs, arg_vars, new_ty_cs, strict_arg_tys) <- mkOneConFull arg_tys cl let new_tm_cs = unitBag (TmConCt x (PmAltConLike cl) tvs arg_vars)
compiler/GHC/HsToCore/PmCheck/Ppr.hs view
@@ -31,7 +31,7 @@ -- | Pretty-print the guts of an uncovered value vector abstraction, i.e., its -- components and refutable shapes associated to any mentioned variables. ----- Example for @([Just p, q], [p :-> [3,4], q :-> [0,5]]):+-- Example for @([Just p, q], [p :-> [3,4], q :-> [0,5]])@: -- -- @ -- (Just p) q@@ -92,7 +92,7 @@ (it does not even substitute in HsExpr so they are even printed as wildcards). Additionally, the oracle returns a substitution if it succeeds so we apply this substitution to the vectors before printing them out (see function `pprOne' in-Check.hs) to be more precise.+"GHC.HsToCore.PmCheck") to be more precise. -} -- | Extract and assigns pretty names to constraint variables with refutable
compiler/GHC/HsToCore/Quote.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP, TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DataKinds #-}@@ -40,6 +41,7 @@ import GHC.HsToCore.Monad import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Syntax as TH import GHC.Hs import GHC.Builtin.Names@@ -52,6 +54,7 @@ import GHC.Tc.Utils.TcType import GHC.Core.TyCon import GHC.Builtin.Types+import GHC.Core.Multiplicity ( pattern Many ) import GHC.Core import GHC.Core.Make import GHC.Core.Utils@@ -112,8 +115,8 @@ -- the expected type tyvars = dataConUserTyVarBinders (classDataCon cls) expected_ty = mkInvisForAllTys tyvars $- mkInvisFunTy (mkClassPred cls (mkTyVarTys (binderVars tyvars)))- (mkClassPred monad_cls (mkTyVarTys (binderVars tyvars)))+ mkInvisFunTyMany (mkClassPred cls (mkTyVarTys (binderVars tyvars)))+ (mkClassPred monad_cls (mkTyVarTys (binderVars tyvars))) MASSERT2( idType monad_sel `eqType` expected_ty, ppr monad_sel $$ ppr expected_ty) @@ -329,7 +332,7 @@ = notHandledL loc "Haddock documentation" empty hsScopedTvBinders :: HsValBinds GhcRn -> [Name]--- See Note [Scoped type variables in bindings]+-- See Note [Scoped type variables in quotes] hsScopedTvBinders binds = concatMap get_scoped_tvs sigs where@@ -347,58 +350,60 @@ = get_scoped_tvs_from_sig sig | 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- -- here 'k' scopes too- | HsIB { hsib_ext = implicit_vars- , hsib_body = hs_ty } <- sig- , (explicit_vars, _) <- splitLHsForAllTyInvis hs_ty- = implicit_vars ++ hsLTyVarNames explicit_vars +get_scoped_tvs_from_sig :: LHsSigType GhcRn -> [Name]+get_scoped_tvs_from_sig sig+ -- Collect both implicit and explicit quantified variables, since+ -- the types in instance heads, as well as `via` types in DerivingVia, can+ -- bring implicitly quantified type variables into scope, e.g.,+ --+ -- instance Foo [a] where+ -- m = n @a+ --+ -- See also Note [Scoped type variables in quotes]+ | HsIB { hsib_ext = implicit_vars+ , hsib_body = hs_ty } <- sig+ , (explicit_vars, _) <- splitLHsForAllTyInvis hs_ty+ = implicit_vars ++ hsLTyVarNames explicit_vars+ {- Notes -Note [Scoped type variables in bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider- f :: forall a. a -> a- f x = x::a-Here the 'forall a' brings 'a' into scope over the binding group.-To achieve this we+Note [Scoped type variables in quotes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Quoting declarations with scoped type variables requires some care. Consider: - a) Gensym a binding for 'a' at the same time as we do one for 'f'- collecting the relevant binders with hsScopedTvBinders+ $([d| f :: forall a. a -> a+ f x = x::a+ |]) - b) When processing the 'forall', don't gensym+Here, the `forall a` brings `a` into scope over the binding group. This has+ramifications when desugaring the quote, as we must ensure that that the+desugared code binds `a` with `Language.Haskell.TH.newName` and refers to the+bound `a` type variable in the type signature and in the body of `f`. As a+result, the call to `newName` must occur before any part of the declaration for+`f` is processed. To achieve this, we: -The relevant places are signposted with references to this Note+ (a) Gensym a binding for `a` at the same time as we do one for `f`,+ collecting the relevant binders with the hsScopedTvBinders family of+ functions. -Note [Scoped type variables in class and instance declarations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Scoped type variables may occur in default methods and default-signatures. We need to bring the type variables in 'foralls'-into the scope of the method bindings.+ (b) Use `addBinds` to bring these gensymmed bindings into scope over any+ part of the code where the type variables scope. In the `f` example,+ above, that means the type signature and the body of `f`. -Consider- class Foo a where- foo :: forall (b :: k). a -> Proxy b -> Proxy b- foo _ x = (x :: Proxy b)+ (c) When processing the `forall`, /don't/ gensym the type variables. We have+ already brought the type variables into scope in part (b), after all, so+ gensymming them again would lead to shadowing. We use the rep_ty_sig+ family of functions for processing types without gensymming the type+ variables again. -We want to ensure that the 'b' in the type signature and the default-implementation are the same, so we do the following:+ (d) Finally, we use wrapGenSyms to generate the Core for these scoped type+ variables: - a) Before desugaring the signature and binding of 'foo', use- get_scoped_tvs to collect type variables in 'forall' and- create symbols for them.- b) Use 'addBinds' to bring these symbols into the scope of the type- signatures and bindings.- c) Use these symbols to generate Core for the class/instance declaration.+ newName "a" >>= \a ->+ ... -- process the type signature and body of `f` -Note that when desugaring the signatures, we lookup the type variables-from the scope rather than recreate symbols for them. See more details-in "rep_ty_sig" and in Trac#14885.+The relevant places are signposted with references to this Note. Note [Binders and occurrences] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -426,16 +431,16 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If you're not careful, it's surprisingly easy to take this quoted declaration: - [d| idProxy :: forall proxy (b :: k). proxy b -> proxy b- idProxy x = x+ [d| id :: a -> a+ id x = x |] and have Template Haskell turn it into this: - idProxy :: forall k proxy (b :: k). proxy b -> proxy b- idProxy x = x+ id :: forall a. a -> a+ id x = x -Notice that we explicitly quantified the variable `k`! The latter declaration+Notice that we explicitly quantified the variable `a`! The latter declaration isn't what the user wrote in the first place. Usually, the culprit behind these bugs is taking implicitly quantified type@@ -471,8 +476,8 @@ = do { cls1 <- lookupLOcc cls -- See note [Binders and occurrences] ; dec <- addQTyVarBinds tvs $ \bndrs -> do { cxt1 <- repLContext cxt- -- See Note [Scoped type variables in class and instance declarations]- ; (ss, sigs_binds) <- rep_sigs_binds sigs meth_binds+ -- See Note [Scoped type variables in quotes]+ ; (ss, sigs_binds) <- rep_meth_sigs_binds sigs meth_binds ; fds1 <- repLFunDeps fds ; ats1 <- repFamilyDecls ats ; atds1 <- mapM (repAssocTyFamDefaultD . unLoc) atds@@ -647,8 +652,8 @@ -- do { cxt1 <- repLContext cxt ; inst_ty1 <- repLTy inst_ty- -- See Note [Scoped type variables in class and instance declarations]- ; (ss, sigs_binds) <- rep_sigs_binds sigs binds+ -- See Note [Scoped type variables in quotes]+ ; (ss, sigs_binds) <- rep_meth_sigs_binds sigs binds ; ats1 <- mapM (repTyFamInstD . unLoc) ats ; adts1 <- mapM (repDataFamInstD . unLoc) adts ; decls1 <- coreListM decTyConName (ats1 ++ adts1 ++ sigs_binds)@@ -661,9 +666,9 @@ repStandaloneDerivD :: LDerivDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat , deriv_type = ty }))- = do { dec <- addSimpleTyVarBinds tvs $+ = do { dec <- repDerivStrategy strat $ \strat' ->+ addSimpleTyVarBinds tvs $ do { cxt' <- repLContext cxt- ; strat' <- repDerivStrategy strat ; inst_ty' <- repLTy inst_ty ; repDeriv strat' cxt' inst_ty' } ; return (loc, dec) }@@ -940,23 +945,23 @@ repDerivClause (L _ (HsDerivingClause { deriv_clause_strategy = dcs , deriv_clause_tys = L _ dct }))- = do MkC dcs' <- repDerivStrategy dcs- MkC dct' <- repListM typeTyConName (rep_deriv_ty . hsSigType) dct+ = repDerivStrategy dcs $ \(MkC dcs') ->+ do MkC dct' <- repListM typeTyConName (rep_deriv_ty . hsSigType) dct rep2 derivClauseName [dcs',dct'] where rep_deriv_ty :: LHsType GhcRn -> MetaM (Core (M TH.Type)) rep_deriv_ty ty = repLTy ty -rep_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn- -> MetaM ([GenSymBind], [Core (M TH.Dec)])+rep_meth_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn+ -> MetaM ([GenSymBind], [Core (M TH.Dec)]) -- Represent signatures and methods in class/instance declarations.--- See Note [Scoped type variables in class and instance declarations]+-- See Note [Scoped type variables in quotes] -- -- Why not use 'repBinds': we have already created symbols for methods in -- 'repTopDs' via 'hsGroupBinders'. However in 'repBinds', we recreate -- these fun_id via 'collectHsValBinders decs', which would lead to the -- instance declarations failing in TH.-rep_sigs_binds sigs binds+rep_meth_sigs_binds sigs binds = do { let tvs = concatMap get_scoped_tvs sigs ; ss <- mkGenSyms tvs ; sigs1 <- addBinds ss $ rep_sigs sigs@@ -990,50 +995,62 @@ rep_sig (L loc (CompleteMatchSig _ _st cls mty)) = rep_complete_sig cls mty loc +-- Desugar the explicit type variable binders in an 'LHsSigType', making+-- sure not to gensym them.+-- See Note [Scoped type variables in quotes]+-- and Note [Don't quantify implicit type variables in quotes]+rep_ty_sig_tvs :: [LHsTyVarBndr Specificity GhcRn]+ -> MetaM (Core [M TH.TyVarBndrSpec])+rep_ty_sig_tvs explicit_tvs+ = let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)+ ; repTyVarBndrWithKind tv name } in+ repListM tyVarBndrSpecTyConName rep_in_scope_tv+ explicit_tvs+ -- NB: Don't pass any implicit type variables to repList above+ -- See Note [Don't quantify implicit type variables in quotes]++-- Desugar a top-level type signature. Unlike 'repHsSigType', this+-- deliberately avoids gensymming the type variables.+-- See Note [Scoped type variables in quotes]+-- and Note [Don't quantify implicit type variables in quotes] rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name -> MetaM (SrcSpan, Core (M TH.Dec))--- Don't create the implicit and explicit variables when desugaring signatures,--- see Note [Scoped type variables in class and instance declarations].--- and Note [Don't quantify implicit type variables in quotes] rep_ty_sig mk_sig loc sig_ty nm- | HsIB { hsib_body = hs_ty } <- sig_ty- , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis hs_ty = do { nm1 <- lookupLOcc nm- ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)- ; repTyVarBndrWithKind tv name }- ; th_explicit_tvs <- repListM tyVarBndrSpecTyConName rep_in_scope_tv- explicit_tvs-- -- NB: Don't pass any implicit type variables to repList above- -- See Note [Don't quantify implicit type variables in quotes]+ ; ty1 <- rep_ty_sig' sig_ty+ ; sig <- repProto mk_sig nm1 ty1+ ; return (loc, sig) } +-- Desugar an 'LHsSigType', making sure not to gensym the type variables at+-- the front of the type signature.+-- See Note [Scoped type variables in quotes]+-- and Note [Don't quantify implicit type variables in quotes]+rep_ty_sig' :: LHsSigType GhcRn+ -> MetaM (Core (M TH.Type))+rep_ty_sig' sig_ty+ | HsIB { hsib_body = hs_ty } <- sig_ty+ , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis hs_ty+ = do { th_explicit_tvs <- rep_ty_sig_tvs explicit_tvs ; th_ctxt <- repLContext ctxt ; th_ty <- repLTy ty- ; ty1 <- if null explicit_tvs && null (unLoc ctxt)- then return th_ty- else repTForall th_explicit_tvs th_ctxt th_ty- ; sig <- repProto mk_sig nm1 ty1- ; return (loc, sig) }+ ; if null explicit_tvs && null (unLoc ctxt)+ then return th_ty+ else repTForall th_explicit_tvs th_ctxt th_ty } rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name -> MetaM (SrcSpan, Core (M TH.Dec)) -- represents a pattern synonym type signature;--- see Note [Pattern synonym type signatures and Template Haskell] in Convert+-- see Note [Pattern synonym type signatures and Template Haskell] in "GHC.ThToHs" -- -- Don't create the implicit and explicit variables when desugaring signatures,--- see Note [Scoped type variables in class and instance declarations]+-- see Note [Scoped type variables in quotes] -- and Note [Don't quantify implicit type variables in quotes] rep_patsyn_ty_sig loc sig_ty nm | HsIB { hsib_body = hs_ty } <- sig_ty , (univs, reqs, exis, provs, ty) <- splitLHsPatSynTy hs_ty = do { nm1 <- lookupLOcc nm- ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)- ; repTyVarBndrWithKind tv name }- ; th_univs <- repListM tyVarBndrSpecTyConName rep_in_scope_tv univs- ; th_exis <- repListM tyVarBndrSpecTyConName rep_in_scope_tv exis-- -- NB: Don't pass any implicit type variables to repList above- -- See Note [Don't quantify implicit type variables in quotes]+ ; th_univs <- rep_ty_sig_tvs univs+ ; th_exis <- rep_ty_sig_tvs exis ; th_reqs <- repLContext reqs ; th_provs <- repLContext provs@@ -1250,10 +1267,6 @@ then return th_ty else repTForall th_explicit_tvs th_ctxt th_ty } -repHsSigWcType :: LHsSigWcType GhcRn -> MetaM (Core (M TH.Type))-repHsSigWcType (HsWC { hswc_body = sig1 })- = repHsSigType sig1- -- yield the representation of a list of types repLTys :: [LHsType GhcRn] -> MetaM [Core (M TH.Type)] repLTys tys = mapM repLTy tys@@ -1265,7 +1278,7 @@ -- Desugar a type headed by an invisible forall (e.g., @forall a. a@) or -- a context (e.g., @Show a => a@) into a ForallT from L.H.TH.Syntax. -- In other words, the argument to this function is always an--- @HsForAllTy ForallInvis@ or @HsQualTy@.+-- @HsForAllTy HsForAllInvis{}@ or @HsQualTy@. -- Types headed by visible foralls (which are desugared to ForallVisT) are -- handled separately in repTy. repForallT :: HsType GhcRn -> MetaM (Core (M TH.Type))@@ -1278,20 +1291,20 @@ } repTy :: HsType GhcRn -> MetaM (Core (M TH.Type))-repTy ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = body }) =- case fvf of- ForallInvis -> repForallT ty- ForallVis -> let tvs' = map ((<$>) (setHsTyVarBndrFlag ())) tvs- -- see Note [Specificity in HsForAllTy] in GHC.Hs.Type- in addHsTyVarBinds tvs' $ \bndrs ->- do body1 <- repLTy body- repTForallVis bndrs body1+repTy ty@(HsForAllTy { hst_tele = tele, hst_body = body }) =+ case tele of+ HsForAllInvis{} -> repForallT ty+ HsForAllVis { hsf_vis_bndrs = tvs } ->+ addHsTyVarBinds tvs $ \bndrs ->+ do body1 <- repLTy body+ repTForallVis bndrs body1 repTy ty@(HsQualTy {}) = repForallT ty repTy (HsTyVar _ _ (L _ n))- | isLiftedTypeKindTyConName n = repTStar- | n `hasKey` constraintKindTyConKey = repTConstraint- | n `hasKey` funTyConKey = repArrowTyCon+ | isLiftedTypeKindTyConName n = repTStar+ | n `hasKey` constraintKindTyConKey = repTConstraint+ | n `hasKey` unrestrictedFunTyConKey = repArrowTyCon+ | n `hasKey` funTyConKey = repMulArrowTyCon | isTvOcc occ = do tv1 <- lookupOcc n repTvar tv1 | isDataOcc occ = do tc1 <- lookupOcc n@@ -1310,11 +1323,16 @@ ty1 <- repLTy ty ki1 <- repLTy ki repTappKind ty1 ki1-repTy (HsFunTy _ f a) = do+repTy (HsFunTy _ w f a) | isUnrestricted w = do f1 <- repLTy f a1 <- repLTy a tcon <- repArrowTyCon repTapps tcon [f1, a1]+repTy (HsFunTy _ w f a) = do w1 <- repLTy (arrowToHsType w)+ f1 <- repLTy f+ a1 <- repLTy a+ tcon <- repMulArrowTyCon+ repTapps tcon [w1, f1, a1] repTy (HsListTy _ t) = do t1 <- repLTy t tcon <- repListTyCon@@ -1357,8 +1375,7 @@ repTy ty = notHandled "Exotic form of type" (ppr ty) repTyLit :: HsTyLit -> MetaM (Core (M TH.TyLit))-repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i- rep2 numTyLitName [iExpr]+repTyLit (HsNumTy _ i) = rep2 numTyLitName [mkIntegerExpr i] repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s ; rep2 strTyLitName [s'] }@@ -1473,9 +1490,10 @@ -- FIXME: I haven't got the types here right yet repE e@(HsDo _ ctxt (L _ sts))- | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }+ | Just maybeModuleName <- case ctxt of+ { DoExpr m -> Just m; GhciStmtCtxt -> Just Nothing; _ -> Nothing } = do { (ss,zs) <- repLSts sts;- e' <- repDoE (nonEmptyCoreList zs);+ e' <- repDoE maybeModuleName (nonEmptyCoreList zs); wrapGenSyms ss e' } | ListComp <- ctxt@@ -1483,9 +1501,9 @@ e' <- repComp (nonEmptyCoreList zs); wrapGenSyms ss e' } - | MDoExpr <- ctxt+ | MDoExpr maybeModuleName <- ctxt = do { (ss,zs) <- repLSts sts;- e' <- repMDoE (nonEmptyCoreList zs);+ e' <- repMDoE maybeModuleName (nonEmptyCoreList zs); wrapGenSyms ss e' } | otherwise@@ -1520,10 +1538,13 @@ fs <- repUpdFields flds; repRecUpd x fs } -repE (ExprWithTySig _ e ty)- = do { e1 <- repLE e- ; t1 <- repHsSigWcType ty+repE (ExprWithTySig _ e wc_ty)+ = addSimpleTyVarBinds (get_scoped_tvs_from_sig sig_ty) $+ do { e1 <- repLE e+ ; t1 <- rep_ty_sig' sig_ty ; repSigExp e1 t1 }+ where+ sig_ty = dropWildCards wc_ty repE (ArithSeq _ _ aseq) = case aseq of@@ -1634,7 +1655,8 @@ -- -- do { x'1 <- gensym "x" -- ; x'2 <- gensym "x"--- ; doE [ BindSt (pvar x'1) [| f 1 |]+-- ; doE Nothing+-- [ BindSt (pvar x'1) [| f 1 |] -- , BindSt (pvar x'2) [| f x |] -- , NoBindSt [| g x |] -- ]@@ -1725,7 +1747,7 @@ -- the binding group, because we are talking Names -- here, so we can safely treat it as a mutually -- recursive group- -- For hsScopedTvBinders see Note [Scoped type variables in bindings]+ -- For hsScopedTvBinders see Note [Scoped type variables in quotes] ; ss <- mkGenSyms bndrs ; prs <- addBinds ss (rep_val_binds decs) ; core_list <- coreListM decTyConName@@ -2011,7 +2033,7 @@ -- -- Nevertheless, it's monadic because we have to generate nameTy mkGenSyms ns = do { var_ty <- lookupType nameTyConName- ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }+ ; return [(nm, mkLocalId (localiseName nm) Many var_ty) | nm <- ns] } addBinds :: [GenSymBind] -> MetaM a -> MetaM a@@ -2272,12 +2294,25 @@ repCaseE :: Core (M TH.Exp) -> Core [(M TH.Match)] -> MetaM (Core (M TH.Exp)) repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms] -repDoE :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))-repDoE (MkC ss) = rep2 doEName [ss]+repDoE :: Maybe ModuleName -> Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))+repDoE = repDoBlock doEName -repMDoE :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))-repMDoE (MkC ss) = rep2 mdoEName [ss]+repMDoE :: Maybe ModuleName -> Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))+repMDoE = repDoBlock mdoEName +repDoBlock :: Name -> Maybe ModuleName -> Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))+repDoBlock doName maybeModName (MkC ss) = do+ MkC coreModName <- coreModNameM+ rep2 doName [coreModName, ss]+ where+ coreModNameM :: MetaM (Core (Maybe TH.ModName))+ coreModNameM = case maybeModName of+ Just m -> do+ MkC s <- coreStringLit (moduleNameString m)+ mName <- rep2_nw mkModNameName [s]+ coreJust modNameTyConName mName+ _ -> coreNothing modNameTyConName+ repComp :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp)) repComp (MkC ss) = rep2 compEName [ss] @@ -2405,18 +2440,21 @@ [o, cxt, ty, ds] repDerivStrategy :: Maybe (LDerivStrategy GhcRn)- -> MetaM (Core (Maybe (M TH.DerivStrategy)))-repDerivStrategy mds =+ -> (Core (Maybe (M TH.DerivStrategy)) -> MetaM (Core (M a)))+ -> MetaM (Core (M a))+repDerivStrategy mds thing_inside = case mds of- Nothing -> nothing+ Nothing -> thing_inside =<< nothing Just ds -> case unLoc ds of- StockStrategy -> just =<< repStockStrategy- AnyclassStrategy -> just =<< repAnyclassStrategy- NewtypeStrategy -> just =<< repNewtypeStrategy- ViaStrategy ty -> do ty' <- repLTy (hsSigType ty)+ StockStrategy -> thing_inside =<< just =<< repStockStrategy+ AnyclassStrategy -> thing_inside =<< just =<< repAnyclassStrategy+ NewtypeStrategy -> thing_inside =<< just =<< repNewtypeStrategy+ ViaStrategy ty -> addSimpleTyVarBinds (get_scoped_tvs_from_sig ty) $+ do ty' <- rep_ty_sig' ty via_strat <- repViaStrategy ty'- just via_strat+ m_via_strat <- just via_strat+ thing_inside m_via_strat where nothing = coreNothingM derivStrategyTyConName just = coreJustM derivStrategyTyConName@@ -2562,11 +2600,11 @@ -> [Core TH.Name] -> MetaM (Core (M TH.Con)) repConstr (PrefixCon ps) Nothing [con]- = do arg_tys <- repListM bangTypeTyConName repBangTy ps+ = do arg_tys <- repListM bangTypeTyConName repBangTy (map hsScaledThing ps) rep2 normalCName [unC con, unC arg_tys] repConstr (PrefixCon ps) (Just res_ty) cons- = do arg_tys <- repListM bangTypeTyConName repBangTy ps+ = do arg_tys <- repListM bangTypeTyConName repBangTy (map hsScaledThing ps) res_ty' <- repLTy res_ty rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty'] @@ -2589,8 +2627,8 @@ ; rep2 varBangTypeName [v,ty] } repConstr (InfixCon st1 st2) Nothing [con]- = do arg1 <- repBangTy st1- arg2 <- repBangTy st2+ = do arg1 <- repBangTy (hsScaledThing st1)+ arg2 <- repBangTy (hsScaledThing st2) rep2 infixCName [unC arg1, unC con, unC arg2] repConstr (InfixCon {}) (Just _) _ =@@ -2678,6 +2716,9 @@ repArrowTyCon :: MetaM (Core (M TH.Type)) repArrowTyCon = rep2 arrowTName [] +repMulArrowTyCon :: MetaM (Core (M TH.Type))+repMulArrowTyCon = rep2 mulArrowTName []+ repListTyCon :: MetaM (Core (M TH.Type)) repListTyCon = rep2 listTName [] @@ -2745,8 +2786,7 @@ _ -> Nothing mk_integer :: Integer -> MetaM (HsLit GhcRn)-mk_integer i = do integer_ty <- lookupType integerTyConName- return $ HsInteger NoSourceText i integer_ty+mk_integer i = return $ HsInteger NoSourceText i integerTy mk_rational :: FractionalLit -> MetaM (HsLit GhcRn) mk_rational r = do rat_ty <- lookupType rationalTyConName@@ -2903,7 +2943,7 @@ return (MkC (mkIntExprInt platform i)) coreIntegerLit :: MonadThings m => Integer -> m (Core Integer)-coreIntegerLit i = fmap MkC (mkIntegerExpr i)+coreIntegerLit i = pure (MkC (mkIntegerExpr i)) coreVar :: Id -> Core TH.Name -- The Id has type Name coreVar id = MkC (Var id)
compiler/GHC/HsToCore/Usage.hs view
@@ -86,7 +86,7 @@ raw_pkgs = foldr Set.insert (imp_dep_pkgs imports) plugin_dep_pkgs - pkgs | th_used = Set.insert (toUnitId thUnitId) raw_pkgs+ pkgs | th_used = Set.insert thUnitId raw_pkgs | otherwise = raw_pkgs -- Set the packages required to be Safe according to Safe Haskell.@@ -169,7 +169,7 @@ -} mkPluginUsage :: HscEnv -> ModIface -> IO [Usage] mkPluginUsage hsc_env pluginModule- = case lookupPluginModuleWithSuggestions dflags pNm Nothing of+ = case lookupPluginModuleWithSuggestions pkgs pNm Nothing of LookupFound _ pkg -> do -- The plugin is from an external package: -- search for the library files containing the plugin.@@ -186,7 +186,7 @@ if useDyn then libLocs else- let dflags' = updateWays (addWay' WayDyn dflags)+ let dflags' = addWay' WayDyn dflags dlibLocs = [ searchPath </> mkHsSOName platform dlibLoc | searchPath <- searchPaths , dlibLoc <- packageHsLibs dflags' pkg@@ -215,9 +215,11 @@ where dflags = hsc_dflags hsc_env platform = targetPlatform dflags- pNm = moduleName (mi_module pluginModule)- pPkg = moduleUnit (mi_module pluginModule)- deps = map fst (dep_mods (mi_deps pluginModule))+ pkgs = unitState dflags+ pNm = moduleName $ mi_module pluginModule+ pPkg = moduleUnit $ mi_module pluginModule+ deps = map gwib_mod $+ dep_mods $ mi_deps pluginModule -- Lookup object file for a plugin dependency, -- from the same package as the plugin.@@ -249,7 +251,7 @@ where hpt = hsc_HPT hsc_env dflags = hsc_dflags hsc_env- this_pkg = thisPackage dflags+ this_pkg = homeUnit dflags used_mods = moduleEnvKeys ent_map dir_imp_mods = moduleEnvKeys direct_imports@@ -375,3 +377,19 @@ from generating many of these usages (at least in one-shot mode), but that's even more bogus! -}++{-+Note [Internal used_names]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Most of the used_names are External Names, but we can have System+Names too. Two examples:++* Names arising from Language.Haskell.TH.newName.+ See Note [Binders in Template Haskell] in GHC.ThToHs (and #5362).+* The names of auxiliary bindings in derived instances.+ See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate.++Such Names are always for locally-defined things, for which we don't gather+usage info, so we can just ignore them in ent_map. Moreover, they are always+System Names, hence the assert, just as a double check.+-}
compiler/GHC/HsToCore/Utils.hs view
@@ -100,12 +100,13 @@ We're about to match against some patterns. We want to make some @Ids@ to use as match variables. If a pattern has an @Id@ readily at hand, which should indeed be bound to the pattern as a whole, then use it;-otherwise, make one up.+otherwise, make one up. The multiplicity argument is chosen as the multiplicity+of the variable if it is made up. -} -selectSimpleMatchVarL :: LPat GhcTc -> DsM Id+selectSimpleMatchVarL :: Mult -> LPat GhcTc -> DsM Id -- Postcondition: the returned Id has an Internal Name-selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)+selectSimpleMatchVarL w pat = selectMatchVar w (unLoc pat) -- (selectMatchVars ps tys) chooses variables of type tys -- to use for matching ps against. If the pattern is a variable,@@ -123,20 +124,25 @@ -- Then we must not choose (x::Int) as the matching variable! -- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat -selectMatchVars :: [Pat GhcTc] -> DsM [Id]+selectMatchVars :: [(Mult, Pat GhcTc)] -> DsM [Id] -- Postcondition: the returned Ids have Internal Names-selectMatchVars ps = mapM selectMatchVar ps+selectMatchVars ps = mapM (uncurry selectMatchVar) ps -selectMatchVar :: Pat GhcTc -> DsM Id+selectMatchVar :: Mult -> Pat GhcTc -> DsM Id -- Postcondition: the returned Id has an Internal Name-selectMatchVar (BangPat _ pat) = selectMatchVar (unLoc pat)-selectMatchVar (LazyPat _ pat) = selectMatchVar (unLoc pat)-selectMatchVar (ParPat _ pat) = selectMatchVar (unLoc pat)-selectMatchVar (VarPat _ var) = return (localiseId (unLoc var))+selectMatchVar w (BangPat _ pat) = selectMatchVar w (unLoc pat)+selectMatchVar w (LazyPat _ pat) = selectMatchVar w (unLoc pat)+selectMatchVar w (ParPat _ pat) = selectMatchVar w (unLoc pat)+selectMatchVar _w (VarPat _ var) = return (localiseId (unLoc var)) -- Note [Localise pattern binders]-selectMatchVar (AsPat _ var _) = return (unLoc var)-selectMatchVar other_pat = newSysLocalDsNoLP (hsPatType other_pat)- -- OK, better make up one...+ --+ -- Remark: when the pattern is a variable (or+ -- an @-pattern), then w is the same as the+ -- multiplicity stored within the variable+ -- itself. It's easier to pull it from the+ -- variable, so we ignore the multiplicity.+selectMatchVar _w (AsPat _ var _) = ASSERT( isManyDataConTy _w ) (return (unLoc var))+selectMatchVar w other_pat = newSysLocalDsNoLP w (hsPatType other_pat) {- Note [Localise pattern binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -217,7 +223,7 @@ combineMatchResults match_result1@(MR_Infallible _) _ = match_result1 combineMatchResults match_result1 match_result2 =- -- if the first pattern needs a failure handler (i.e. if it is is fallible),+ -- if the first pattern needs a failure handler (i.e. if it is fallible), -- make it let-bind it bind it with `shareFailureHandler`. case shareFailureHandler match_result1 of MR_Infallible _ -> match_result1@@ -348,7 +354,7 @@ -- (not that splitTyConApp does, these days) mk_case :: Maybe CoreAlt -> [CoreAlt] -> CoreExpr- mk_case def alts = mkWildCase (Var var) (idType var) ty $+ mk_case def alts = mkWildCase (Var var) (idScaledType var) ty $ maybeToList def ++ alts mk_alts :: MatchResult [CoreAlt]@@ -364,7 +370,11 @@ Just (DCB boxer) -> do us <- newUniqueSupply let (rep_ids, binds) = initUs_ us (boxer ty_args args)- return (DataAlt con, rep_ids, mkLets binds body)+ let rep_ids' = map (scaleVarBy (idMult var)) rep_ids+ -- Upholds the invariant that the binders of a case expression+ -- must be scaled by the case multiplicity. See Note [Case+ -- expression invariants] in CoreSyn.+ return (DataAlt con, rep_ids', mkLets binds body) mk_default :: MatchResult (Maybe CoreAlt) mk_default@@ -481,7 +491,8 @@ case_bndr = case arg1 of Var v1 | isInternalName (idName v1) -> v1 -- Note [Desugaring seq], points (2) and (3)- _ -> mkWildValBinder ty1+ _ -> mkWildValBinder Many ty1+ mkCoreAppDs s fun arg = mkCoreApp s fun arg -- The rest is done in GHC.Core.Make -- NB: No argument can be levity polymorphic@@ -654,13 +665,14 @@ ; y = case v of K x y -> y } which is better. -}-+-- Remark: pattern selectors only occur in unrestricted patterns so we are free+-- to select Many as the multiplicity of every let-expression introduced. mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly -> LPat GhcTc -- ^ The pattern -> CoreExpr -- ^ Expression to which the pattern is bound -> DsM (Id,[(Id,CoreExpr)]) -- ^ Id the rhs is bound to, for desugaring strict- -- binds (see Note [Desugar Strict binds] in GHC.HsToCore.Binds)+ -- binds (see Note [Desugar Strict binds] in "GHC.HsToCore.Binds") -- and all the desugared binds mkSelectorBinds ticks pat val_expr@@ -669,7 +681,7 @@ | is_flat_prod_lpat pat' -- Special case (B) = do { let pat_ty = hsLPatType pat'- ; val_var <- newSysLocalDsNoLP pat_ty+ ; val_var <- newSysLocalDsNoLP Many pat_ty ; let mk_bind tick bndr_var -- (mk_bind sv bv) generates bv = case sv of { pat -> bv }@@ -687,7 +699,7 @@ ; return ( val_var, (val_var, val_expr) : binds) } | otherwise -- General case (C)- = do { tuple_var <- newSysLocalDs tuple_ty+ = do { tuple_var <- newSysLocalDs Many tuple_ty ; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr pat') ; tuple_expr <- matchSimply val_expr PatBindRhs pat local_tuple error_expr@@ -841,8 +853,8 @@ CoreExpr) -- Fail variable applied to realWorld# -- See Note [Failure thunks and CPR] mkFailurePair expr- = do { fail_fun_var <- newFailLocalDs (voidPrimTy `mkVisFunTy` ty)- ; fail_fun_arg <- newSysLocalDs voidPrimTy+ = do { fail_fun_var <- newFailLocalDs Many (voidPrimTy `mkVisFunTyMany` ty)+ ; fail_fun_arg <- newSysLocalDs Many voidPrimTy ; let real_arg = setOneShotLambda fail_fun_arg ; return (NonRec fail_fun_var (Lam real_arg expr), App (Var fail_fun_var) (Var voidPrimId)) }@@ -899,7 +911,9 @@ mkBinaryTickBox ixT ixF e = do uq <- newUnique this_mod <- getModule- let bndr1 = mkSysLocal (fsLit "t1") uq boolTy+ let bndr1 = mkSysLocal (fsLit "t1") uq One boolTy+ -- It's always sufficient to pattern-match on a boolean with+ -- multiplicity 'One'. let falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId) trueBox = Tick (HpcTick this_mod ixT) (Var trueDataConId)
compiler/GHC/Iface/Binary.hs view
@@ -13,6 +13,7 @@ -- * Public API for interface file serialisation writeBinIface, readBinIface,+ readBinIface_, getSymtabName, getDictFastString, CheckHiWay(..),@@ -42,6 +43,7 @@ import GHC.Unit import GHC.Types.Name import GHC.Driver.Session+import GHC.Driver.Ways import GHC.Types.Unique.FM import GHC.Types.Unique.Supply import GHC.Utils.Panic@@ -57,6 +59,7 @@ import GHC.Settings.Constants import GHC.Utils.Misc +import Data.Set (Set) import Data.Array import Data.Array.ST import Data.Array.Unsafe@@ -88,6 +91,7 @@ dflags <- getDynFlags liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu +-- | Read an interface file in 'IO'. readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath -> NameCacheUpdater -> IO ModIface@@ -134,7 +138,7 @@ errorOnMismatch "mismatched interface file versions" our_ver check_ver check_way <- get bh- let way_descr = getWayDescr dflags+ let way_descr = getWayDescr platform (ways dflags) wantedGot "Way" way_descr check_way ppr when (checkHiWay == CheckHiWay) $ errorOnMismatch "mismatched interface file ways" way_descr check_way@@ -189,7 +193,7 @@ -- The version and way descriptor go next put_ bh (show hiVersion)- let way_descr = getWayDescr dflags+ let way_descr = getWayDescr platform (ways dflags) put_ bh way_descr extFields_p_p <- tellBin bh@@ -426,10 +430,10 @@ -- indexed by FastString } -getWayDescr :: DynFlags -> String-getWayDescr dflags- | platformUnregisterised (targetPlatform dflags) = 'u':tag- | otherwise = tag- where tag = buildTag dflags+getWayDescr :: Platform -> Set Way -> String+getWayDescr platform ws+ | platformUnregisterised platform = 'u':tag+ | otherwise = tag+ where tag = waysBuildTag ws -- if this is an unregisterised build, make sure our interfaces -- can't be used by a registerised build.
compiler/GHC/Iface/Env.hs view
@@ -54,9 +54,9 @@ newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name -- Used for source code and interface files, to make the -- Name for a thing, given its Module and OccName--- See Note [The Name Cache]+-- See Note [The Name Cache] in GHC.Types.Name.Cache ----- The cache may already already have a binding for this thing,+-- The cache may already have a binding for this thing, -- because we may have seen an occurrence before, but now is the -- moment when we know its Module and SrcLoc in their full glory @@ -79,7 +79,7 @@ :: NameCache -> Module -> OccName -> SrcSpan -> (NameCache, Name)--- See Note [The Name Cache]+-- See Note [The Name Cache] in GHC.Types.Name.Cache allocateGlobalBinder name_supply mod occ loc = case lookupOrigNameCache (nsNames name_supply) mod occ of -- A hit in the cache! We are at the binding site of the name.@@ -251,7 +251,7 @@ ; return (lookupFsEnv (if_tv_env lcl) occ) } lookupIfaceVar :: IfaceBndr -> IfL (Maybe TyCoVar)-lookupIfaceVar (IfaceIdBndr (occ, _))+lookupIfaceVar (IfaceIdBndr (_, occ, _)) = do { lcl <- getLclEnv ; return (lookupFsEnv (if_id_env lcl) occ) } lookupIfaceVar (IfaceTvBndr (occ, _))
compiler/GHC/Iface/Ext/Ast.hs view
@@ -31,15 +31,17 @@ import GHC.Data.BooleanFormula import GHC.Core.Class ( FunDep, className, classSCSelIds ) import GHC.Core.Utils ( exprType )-import GHC.Core.ConLike ( conLikeName )+import GHC.Core.ConLike ( conLikeName, ConLike(RealDataCon) ) import GHC.Core.TyCon ( TyCon, tyConClass_maybe ) import GHC.Core.FVs+import GHC.Core.DataCon ( dataConNonlinearType ) import GHC.HsToCore ( deSugarExpr ) import GHC.Types.FieldLabel import GHC.Hs import GHC.Driver.Types import GHC.Unit.Module ( ModuleName, ml_hs_file ) import GHC.Utils.Monad ( concatMapM, liftIO )+import GHC.Types.Id ( isDataConId_maybe ) import GHC.Types.Name ( Name, nameSrcSpan, setNameLoc, nameUnique ) import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv ) import GHC.Types.SrcLoc@@ -606,11 +608,14 @@ let name = case lookupNameEnv m (varName name') of Just var -> var Nothing-> name'+ ty = case isDataConId_maybe name' of+ Nothing -> varType name'+ Just dc -> dataConNonlinearType dc pure [Node (mkSourcedNodeInfo org $ NodeInfo S.empty [] $ M.singleton (Right $ varName name)- (IdentifierDetails (Just $ varType name')+ (IdentifierDetails (Just ty) (S.singleton context))) span []]@@ -646,7 +651,7 @@ case ev of EvTypeableTyCon _ e -> concatMap evVarsOfTermList e EvTypeableTyApp e1 e2 -> concatMap evVarsOfTermList [e1,e2]- EvTypeableTrFun e1 e2 -> concatMap evVarsOfTermList [e1,e2]+ EvTypeableTrFun e1 e2 e3 -> concatMap evVarsOfTermList [e1,e2,e3] EvTypeableTyLit e -> evVarsOfTermList e evVarsOfTermList (EvFun{}) = [] @@ -718,6 +723,8 @@ HsLit _ l -> Just (hsLitType l) HsOverLit _ o -> Just (overLitType o) + HsConLikeOut _ (RealDataCon con) -> Just (dataConNonlinearType con)+ HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy)@@ -1303,7 +1310,7 @@ [ toHie $ PS Nothing sc NoScope pat , toHie expr ]- toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM+ toHie (RS sc (ApplicativeArgMany _ stmts _ pat _)) = concatM [ toHie $ listScopes NoScope stmts , toHie $ PS Nothing sc NoScope pat ]@@ -1514,6 +1521,9 @@ instance ToHie (Located OverlapMode) where toHie (L span _) = locOnly span +instance ToHie a => ToHie (HsScaled GhcRn a) where+ toHie (HsScaled w t) = concatM [toHie (arrowToHsType w), toHie t]+ instance ToHie (LConDecl GhcRn) where toHie (L span decl) = concatM $ makeNode decl span : case decl of ConDeclGADT { con_names = names, con_qvars = exp_vars, con_g_ext = imp_vars@@ -1543,9 +1553,11 @@ rhsScope = combineScopes ctxScope argsScope ctxScope = maybe NoScope mkLScope ctx argsScope = condecl_scope dets- where condecl_scope args = case args of- PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs- InfixCon a b -> combineScopes (mkLScope a) (mkLScope b)+ where condecl_scope :: HsConDeclDetails p -> Scope+ condecl_scope args = case args of+ PrefixCon xs -> foldr combineScopes NoScope $ map (mkLScope . hsScaledThing) xs+ InfixCon a b -> combineScopes (mkLScope (hsScaledThing a))+ (mkLScope (hsScaledThing b)) RecCon x -> mkLScope x instance ToHie (Located [LConDeclField GhcRn]) where@@ -1633,8 +1645,13 @@ instance ToHie (TScoped (LHsType GhcRn)) where toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of- HsForAllTy _ _ bndrs body ->- [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs+ HsForAllTy _ tele body ->+ let scope = mkScope $ getLoc body in+ [ case tele of+ HsForAllVis { hsf_vis_bndrs = bndrs } ->+ toHie $ tvScopes tsc scope bndrs+ HsForAllInvis { hsf_invis_bndrs = bndrs } ->+ toHie $ tvScopes tsc scope bndrs , toHie body ] HsQualTy _ ctx body ->@@ -1652,8 +1669,9 @@ [ toHie ty , toHie $ TS (ResolvedScopes []) ki ]- HsFunTy _ a b ->- [ toHie a+ HsFunTy _ w a b ->+ [ toHie (arrowToHsType w)+ , toHie a , toHie b ] HsListTy _ a ->
compiler/GHC/Iface/Ext/Binary.hs view
@@ -59,7 +59,7 @@ initBinMemSize :: Int initBinMemSize = 1024*1024 --- | The header for HIE files - Capital ASCII letters "HIE".+-- | The header for HIE files - Capital ASCII letters \"HIE\". hieMagic :: [Word8] hieMagic = [72,73,69]
compiler/GHC/Iface/Ext/Types.hs view
@@ -141,7 +141,7 @@ | HAppTy a (HieArgs a) | HTyConApp IfaceTyCon (HieArgs a) | HForAllTy ((Name, a),ArgFlag) a- | HFunTy a a+ | HFunTy a a a | HQualTy a a -- ^ type with constraint: @t1 => t2@ (see 'IfaceDFunTy') | HLitTy IfaceTyLit | HCastTy a@@ -169,8 +169,9 @@ putByte bh 3 put_ bh bndr put_ bh a- put_ bh (HFunTy a b) = do+ put_ bh (HFunTy w a b) = do putByte bh 4+ put_ bh w put_ bh a put_ bh b put_ bh (HQualTy a b) = do@@ -192,7 +193,7 @@ 1 -> HAppTy <$> get bh <*> get bh 2 -> HTyConApp <$> get bh <*> get bh 3 -> HForAllTy <$> get bh <*> get bh- 4 -> HFunTy <$> get bh <*> get bh+ 4 -> HFunTy <$> get bh <*> get bh <*> get bh 5 -> HQualTy <$> get bh <*> get bh 6 -> HLitTy <$> get bh 7 -> HCastTy <$> get bh
compiler/GHC/Iface/Ext/Utils.hs view
@@ -12,6 +12,7 @@ import GHC.Driver.Session ( DynFlags ) import GHC.Data.FastString ( FastString, mkFastString ) import GHC.Iface.Type+import GHC.Core.Multiplicity import GHC.Types.Name hiding (varName) import GHC.Types.Name.Set import GHC.Utils.Outputable hiding ( (<>) )@@ -156,8 +157,8 @@ go (HLitTy l) = IfaceLitTy l go (HForAllTy ((n,k),af) t) = let b = (occNameFS $ getOccName n, k) in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t- go (HFunTy a b) = IfaceFunTy VisArg a b- go (HQualTy pred b) = IfaceFunTy InvisArg pred b+ go (HFunTy w a b) = IfaceFunTy VisArg w a b+ go (HQualTy pred b) = IfaceFunTy InvisArg many_ty pred b go (HCastTy a) = a go HCoercionTy = IfaceTyVar "<coercion type>" go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs)@@ -233,12 +234,13 @@ k <- getTypeIndex (varType v) i <- getTypeIndex t return $ HForAllTy ((varName v,k),a) i- go (FunTy { ft_af = af, ft_arg = a, ft_res = b }) = do+ go (FunTy { ft_af = af, ft_mult = w, ft_arg = a, ft_res = b }) = do ai <- getTypeIndex a bi <- getTypeIndex b+ wi <- getTypeIndex w return $ case af of- InvisArg -> HQualTy ai bi- VisArg -> HFunTy ai bi+ InvisArg -> case w of Many -> HQualTy ai bi; _ -> error "Unexpected non-unrestricted predicate"+ VisArg -> HFunTy wi ai bi go (LitTy a) = return $ HLitTy $ toIfaceTyLit a go (CastTy t _) = do i <- getTypeIndex t
compiler/GHC/Iface/Load.hs view
@@ -53,8 +53,7 @@ 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.Types.Id.Make ( seqId, EnableBignumRules(..) ) import GHC.Core.Rules import GHC.Core.TyCon import GHC.Types.Annotations@@ -64,6 +63,7 @@ import GHC.Types.Name.Env import GHC.Types.Avail import GHC.Unit.Module+import GHC.Unit.State import GHC.Data.Maybe import GHC.Utils.Error import GHC.Driver.Finder@@ -366,7 +366,7 @@ ------------------ -- | Loads a user interface and throws an exception if it fails. The first parameter indicates -- whether we should import the boot variant of the module-loadUserInterface :: Bool -> SDoc -> Module -> IfM lcl ModIface+loadUserInterface :: IsBootInterface -> SDoc -> Module -> IfM lcl ModIface loadUserInterface is_boot doc mod_name = loadInterfaceWithException doc mod_name (ImportByUser is_boot) @@ -401,7 +401,7 @@ -- Hole modules get special treatment = do dflags <- getDynFlags -- Redo search for our local hole module- loadInterface doc_str (mkModule (thisPackage dflags) (moduleName mod)) from+ loadInterface doc_str (mkHomeModule dflags (moduleName mod)) from | otherwise = withTimingSilentD (text "loading interface") (pure ()) $ do { -- Read the state@@ -485,8 +485,8 @@ } } - ; let bad_boot = mi_boot iface && fmap fst (if_rec_types gbl_env) == Just mod- -- Warn warn against an EPS-updating import+ ; let bad_boot = mi_boot iface == IsBoot && fmap fst (if_rec_types gbl_env) == Just mod+ -- Warn against an EPS-updating import -- of one's own boot file! (one-shot only) -- See Note [Loading your own hi-boot file] @@ -529,7 +529,7 @@ ; -- invoke plugins with *full* interface, not final_iface, to ensure -- that plugins have access to declarations, etc.- res <- withPlugins dflags interfaceLoadAction iface+ res <- withPlugins dflags (\p -> interfaceLoadAction p) iface ; return (Succeeded res) }}}} @@ -558,7 +558,7 @@ instance in M itself. Hence the strange business of just updateing the eps_PTE. -This really happens in practice. The module HsExpr.hs gets+This really happens in practice. The module "GHC.Hs.Expr" gets "duplicate instance" errors if this hack is not present. This is a mess.@@ -619,7 +619,7 @@ -- It's a signature iface... mi_semantic_module iface /= mi_module iface && -- and it's not from the local package- moduleUnit (mi_module iface) /= thisPackage dflags+ moduleUnit (mi_module iface) /= homeUnit dflags -- | This is an improved version of 'findAndReadIface' which can also -- handle the case when a user requests @p[A=<B>]:M@ but we only@@ -642,7 +642,7 @@ MASSERT( not (isHoleModule mod0) ) dflags <- getDynFlags case getModuleInstantiation mod0 of- (imod, Just indef) | not (unitIsDefinite (thisPackage dflags)) -> do+ (imod, Just indef) | homeUnitIsIndefinite dflags -> do r <- findAndReadIface doc_str imod mod0 hi_boot_file case r of Succeeded (iface0, path) -> do@@ -660,12 +660,12 @@ -- | Compute the signatures which must be compiled in order to -- load the interface for a 'Module'. The output of this function -- is always a subset of 'moduleFreeHoles'; it is more precise--- because in signature @p[A=<A>,B=<B>]:B@, although the free holes+-- because in signature @p[A=\<A>,B=\<B>]:B@, although the free holes -- are A and B, B might not depend on A at all! -- -- If this is invoked on a signature, this does NOT include the -- signature itself; e.g. precise free module holes of--- @p[A=<A>,B=<B>]:B@ never includes B.+-- @p[A=\<A>,B=\<B>]:B@ never includes B. moduleFreeHolesPrecise :: SDoc -> Module -> TcRnIf gbl lcl (MaybeErr MsgDoc (UniqDSet ModuleName))@@ -690,7 +690,7 @@ Just ifhs -> Just (renameFreeHoles ifhs insts) _otherwise -> Nothing readAndCache imod insts = do- mb_iface <- findAndReadIface (text "moduleFreeHolesPrecise" <+> doc_str) imod mod False+ mb_iface <- findAndReadIface (text "moduleFreeHolesPrecise" <+> doc_str) imod mod NotBoot case mb_iface of Succeeded (iface, _) -> do let ifhs = mi_free_holes iface@@ -706,27 +706,29 @@ wantHiBootFile dflags eps mod from = case from of ImportByUser usr_boot- | usr_boot && not this_package+ | usr_boot == IsBoot && not this_package -> Failed (badSourceImport mod) | otherwise -> Succeeded usr_boot ImportByPlugin- -> Succeeded False+ -> Succeeded NotBoot ImportBySystem | not this_package -- If the module to be imported is not from this package- -> Succeeded False -- don't look it up in eps_is_boot, because that is keyed+ -> Succeeded NotBoot -- don't look it up in eps_is_boot, because that is keyed -- on the ModuleName of *home-package* modules only. -- We never import boot modules from other packages! | otherwise -> case lookupUFM (eps_is_boot eps) (moduleName mod) of- Just (_, is_boot) -> Succeeded is_boot- Nothing -> Succeeded False+ Just (GWIB { gwib_isBoot = is_boot }) ->+ Succeeded is_boot+ Nothing ->+ Succeeded NotBoot -- The boot-ness of the requested interface, -- based on the dependencies in directly-imported modules where- this_package = thisPackage dflags == moduleUnit mod+ this_package = homeUnit dflags == moduleUnit mod badSourceImport :: Module -> SDoc badSourceImport mod@@ -899,7 +901,7 @@ -- sometimes it's ok to fail... see notes with loadInterface findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file = do traceIf (sep [hsep [text "Reading",- if hi_boot_file+ if hi_boot_file == IsBoot then text "[boot]" else Outputable.empty, text "interface for",@@ -925,7 +927,7 @@ (ml_hi_file loc) -- See Note [Home module load error]- if moduleUnit mod `unitIdEq` thisPackage dflags &&+ if moduleUnit mod `unitIdEq` homeUnit dflags && not (isOneShot (ghcMode dflags)) then return (Failed (homeModError mod loc)) else do r <- read_file file_path@@ -946,7 +948,7 @@ case getModuleInstantiation wanted_mod_with_insts of (_, Nothing) -> wanted_mod_with_insts (_, Just indef_mod) ->- instModuleToModule (pkgState dflags)+ instModuleToModule (unitState dflags) (uninstantiateInstantiatedModule indef_mod) read_result <- readIface wanted_mod file_path case read_result of@@ -1014,8 +1016,8 @@ ********************************************************* -} -initExternalPackageState :: ExternalPackageState-initExternalPackageState+initExternalPackageState :: DynFlags -> ExternalPackageState+initExternalPackageState dflags = EPS { eps_is_boot = emptyUFM, eps_PIT = emptyPackageIfaceTable,@@ -1023,7 +1025,7 @@ eps_PTE = emptyTypeEnv, eps_inst_env = emptyInstEnv, eps_fam_inst_env = emptyFamInstEnv,- eps_rule_base = mkRuleBase builtinRules,+ eps_rule_base = mkRuleBase builtinRules', -- Initialise the EPS rule pool with the built-in rules eps_mod_fam_inst_env = emptyModuleEnv,@@ -1031,8 +1033,14 @@ eps_ann_env = emptyAnnEnv, eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0 , n_insts_in = 0, n_insts_out = 0- , n_rules_in = length builtinRules, n_rules_out = 0 }+ , n_rules_in = length builtinRules', n_rules_out = 0 } }+ where+ enableBignumRules+ | homeUnitId dflags == primUnitId = EnableBignumRules False+ | homeUnitId dflags == bignumUnitId = EnableBignumRules False+ | otherwise = EnableBignumRules True+ builtinRules' = builtinRules enableBignumRules {- *********************************************************@@ -1057,7 +1065,6 @@ -- The fixities listed here for @`seq`@ or @->@ should match -- those in primops.txt.pp (from which Haddock docs are generated). fixities = (getOccName seqId, Fixity NoSourceText 0 InfixR)- : (occName funTyConName, funTyFixity) -- trac #10145 : mapMaybe mkFixity allThePrimOps mkFixity op = (,) (primOpOcc op) <$> primOpFixity op @@ -1219,11 +1226,11 @@ text "family instance modules:" <+> fsep (map ppr finsts) ] where- ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot+ ppr_mod (GWIB { gwib_mod = mod_name, gwib_isBoot = boot }) = ppr mod_name <+> ppr_boot boot ppr_pkg (pkg,trust_req) = ppr pkg <> (if trust_req then text "*" else Outputable.empty)- ppr_boot True = text "[boot]"- ppr_boot False = Outputable.empty+ ppr_boot IsBoot = text "[boot]"+ ppr_boot NotBoot = Outputable.empty pprFixities :: [(OccName, Fixity)] -> SDoc pprFixities [] = Outputable.empty
compiler/GHC/Iface/Make.hs view
@@ -38,6 +38,8 @@ import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.Type+import GHC.Core.Multiplicity+import GHC.StgToCmm.Types (CgInfos (..)) import GHC.Tc.Utils.TcType import GHC.Core.InstEnv import GHC.Core.FamInstEnv@@ -98,15 +100,19 @@ = mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust safe_mode usages doc_hdr decl_docs arg_docs mod_details --- | Fully instantiate a interface--- Adds fingerprints and potentially code generator produced information.-mkFullIface :: HscEnv -> PartialModIface -> Maybe NonCaffySet -> IO ModIface-mkFullIface hsc_env partial_iface mb_non_cafs = do+-- | Fully instantiate an interface. Adds fingerprints and potentially code+-- generator produced information.+--+-- CgInfos is not available when not generating code (-fno-code), or when not+-- generating interface pragmas (-fomit-interface-pragmas). See also+-- Note [Conveying CAF-info and LFInfo between modules] in GHC.StgToCmm.Types.+mkFullIface :: HscEnv -> PartialModIface -> Maybe CgInfos -> IO ModIface+mkFullIface hsc_env partial_iface mb_cg_infos = do let decls | gopt Opt_OmitInterfacePragmas (hsc_dflags hsc_env) = mi_decls partial_iface | otherwise- = updateDeclCafInfos (mi_decls partial_iface) mb_non_cafs+ = updateDecl (mi_decls partial_iface) mb_cg_infos full_iface <- {-# SCC "addFingerprints" #-}@@ -117,15 +123,23 @@ return full_iface -updateDeclCafInfos :: [IfaceDecl] -> Maybe NonCaffySet -> [IfaceDecl]-updateDeclCafInfos decls Nothing = decls-updateDeclCafInfos decls (Just (NonCaffySet non_cafs)) = map update_decl decls+updateDecl :: [IfaceDecl] -> Maybe CgInfos -> [IfaceDecl]+updateDecl decls Nothing = decls+updateDecl decls (Just CgInfos{ cgNonCafs = NonCaffySet non_cafs, cgLFInfos = lf_infos }) = map update_decl decls where+ update_decl (IfaceId nm ty details infos)+ | let not_caffy = elemNameSet nm non_cafs+ , let mb_lf_info = lookupNameEnv lf_infos nm+ , WARN( isNothing mb_lf_info, text "Name without LFInfo:" <+> ppr nm ) True+ -- Only allocate a new IfaceId if we're going to update the infos+ , isJust mb_lf_info || not_caffy+ = IfaceId nm ty details $+ (if not_caffy then (HsNoCafRefs :) else id)+ (case mb_lf_info of+ Nothing -> infos -- LFInfos not available when building .cmm files+ Just lf_info -> HsLFInfo (toIfaceLFInfo nm lf_info) : infos)+ update_decl decl- | IfaceId nm ty details infos <- decl- , elemNameSet nm non_cafs- = IfaceId nm ty details (HsNoCafRefs : infos)- | otherwise = decl -- | Make an interface from the results of typechecking only. Useful@@ -153,7 +167,7 @@ let pluginModules = map lpModule (cachedPlugins (hsc_dflags hsc_env)) deps <- mkDependencies- (thisUnitId (hsc_dflags hsc_env))+ (homeUnitId (hsc_dflags hsc_env)) (map mi_module pluginModules) tc_result let hpc_info = emptyHpcInfo other_hpc_info used_th <- readIORef tc_splice_used@@ -210,7 +224,7 @@ = do let semantic_mod = canonicalizeHomeModule (hsc_dflags hsc_env) (moduleName this_mod) entities = typeEnvElts type_env- decls = [ tyThingToIfaceDecl entity+ decls = [ tyThingToIfaceDecl (hsc_dflags hsc_env) entity | entity <- entities, let name = getName entity, not (isImplicitTyThing entity),@@ -350,16 +364,6 @@ In the result of mkIfaceExports, the names are grouped by defining module, so we may need to split up a single Avail into multiple ones.--Note [Internal used_names]-~~~~~~~~~~~~~~~~~~~~~~~~~~-Most of the used_names are External Names, but we can have Internal-Names too: see Note [Binders in Template Haskell] in Convert, and-#5362 for an example. Such Names are always- - Such Names are always for locally-defined things, for which we- don't gather usage info, so we can just ignore them in ent_map- - They are always System Names, hence the assert, just as a double check.- -} @@ -371,12 +375,12 @@ ************************************************************************ -} -tyThingToIfaceDecl :: TyThing -> IfaceDecl-tyThingToIfaceDecl (AnId id) = idToIfaceDecl id-tyThingToIfaceDecl (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon)-tyThingToIfaceDecl (ACoAxiom ax) = coAxiomToIfaceDecl ax-tyThingToIfaceDecl (AConLike cl) = case cl of- RealDataCon dc -> dataConToIfaceDecl dc -- for ppr purposes only+tyThingToIfaceDecl :: DynFlags -> TyThing -> IfaceDecl+tyThingToIfaceDecl _ (AnId id) = idToIfaceDecl id+tyThingToIfaceDecl _ (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon)+tyThingToIfaceDecl _ (ACoAxiom ax) = coAxiomToIfaceDecl ax+tyThingToIfaceDecl dflags (AConLike cl) = case cl of+ RealDataCon dc -> dataConToIfaceDecl dflags dc -- for ppr purposes only PatSynCon ps -> patSynToIfaceDecl ps --------------------------@@ -392,10 +396,10 @@ ifIdInfo = toIfaceIdInfo (idInfo id) } ---------------------------dataConToIfaceDecl :: DataCon -> IfaceDecl-dataConToIfaceDecl dataCon+dataConToIfaceDecl :: DynFlags -> DataCon -> IfaceDecl+dataConToIfaceDecl dflags dataCon = IfaceId { ifName = getName dataCon,- ifType = toIfaceType (dataConUserType dataCon),+ ifType = toIfaceType (dataConDisplayType dflags dataCon), ifIdDetails = IfVanillaId, ifIdInfo = [] } @@ -542,7 +546,9 @@ ifConUserTvBinders = map toIfaceForAllBndr user_bndrs', ifConEqSpec = map (to_eq_spec . eqSpecPair) eq_spec, ifConCtxt = tidyToIfaceContext con_env2 theta,- ifConArgTys = map (tidyToIfaceType con_env2) arg_tys,+ ifConArgTys =+ map (\(Scaled w t) -> (tidyToIfaceType con_env2 w+ , (tidyToIfaceType con_env2 t))) arg_tys, ifConFields = dataConFieldLabels data_con, ifConStricts = map (toIfaceBang con_env2) (dataConImplBangs data_con),
compiler/GHC/Iface/Recomp.hs view
@@ -212,7 +212,7 @@ -- readIface will have verified that the UnitId matches, -- but we ALSO must make sure the instantiation matches up. See -- test case bkpcabal04!- ; if moduleUnit (mi_module iface) /= thisPackage (hsc_dflags hsc_env)+ ; if moduleUnit (mi_module iface) /= homeUnit (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 {@@ -250,9 +250,9 @@ ; return (recomp, Just iface) }}}}}}}}}} where- this_pkg = thisPackage (hsc_dflags hsc_env)+ this_pkg = homeUnit (hsc_dflags hsc_env) -- This is a bit of a hack really- mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface)+ mod_deps :: ModuleNameEnv ModuleNameWithIsBoot mod_deps = mkModDeps (dep_mods (mi_deps iface)) -- | Check if any plugins are requesting recompilation@@ -303,7 +303,7 @@ -- time or when we go from one recompilation strategy to another: (force -> -- no-force, maybe-recomp -> no-force, no-force -> maybe-recomp etc.) --- -- For example when we go from from ForceRecomp to NoForceRecomp+ -- For example when we go from ForceRecomp to NoForceRecomp -- recompilation is triggered since the old impure plugins could have -- changed the build output which is now back to normal. = RecompBecause "Plugins changed"@@ -332,7 +332,7 @@ dflags <- getDynFlags let outer_mod = ms_mod mod_summary inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod)- MASSERT( moduleUnit outer_mod == thisPackage dflags )+ MASSERT( moduleUnit outer_mod == homeUnit dflags ) case inner_mod == mi_semantic_module iface of True -> up_to_date (text "implementing module unchanged") False -> return (RecompBecause "implementing module changed")@@ -403,9 +403,9 @@ dflags <- getDynFlags let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ] new_merged = case Map.lookup (ms_mod_name mod_summary)- (requirementContext (pkgState dflags)) of+ (requirementContext (unitState dflags)) of Nothing -> []- Just r -> sort $ map (instModuleToModule (pkgState dflags)) r+ Just r -> sort $ map (instModuleToModule (unitState 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")@@ -447,7 +447,7 @@ prev_dep_plgn = dep_plgins (mi_deps iface) prev_dep_pkgs = dep_pkgs (mi_deps iface) - this_pkg = thisPackage (hsc_dflags hsc_env)+ this_pkg = homeUnit (hsc_dflags hsc_env) dep_missing (mb_pkg, L _ mod) = do find_res <- liftIO $ findImportedModule hsc_env mod (mb_pkg)@@ -455,7 +455,7 @@ case find_res of Found _ mod | pkg == this_pkg- -> if moduleName mod `notElem` map fst prev_dep_mods ++ prev_dep_plgn+ -> if moduleName mod `notElem` map gwib_mod prev_dep_mods ++ prev_dep_plgn then do traceHiDiffs $ text "imported module " <> quotes (ppr mod) <> text " not among previous dependencies"@@ -474,7 +474,9 @@ where pkg = moduleUnit mod _otherwise -> return (RecompBecause reason) - old_deps = Set.fromList $ map fst $ filter (not . snd) prev_dep_mods+ projectNonBootNames = map gwib_mod . filter ((== NotBoot) . gwib_isBoot)+ old_deps = Set.fromList+ $ projectNonBootNames prev_dep_mods isOldHomeDeps = flip Set.member old_deps checkForNewHomeDependency (L _ mname) = do let@@ -489,7 +491,7 @@ then return (UpToDate, []) else do mb_result <- getFromModIface "need mi_deps for" mod $ \imported_iface -> do- let mnames = mname:(map fst $ filter (not . snd) $+ let mnames = mname:(map gwib_mod $ filter ((== NotBoot) . gwib_isBoot) $ dep_mods $ mi_deps imported_iface) case find (not . isOldHomeDeps) mnames of Nothing -> return (UpToDate, mnames)@@ -1073,7 +1075,7 @@ sortDependencies :: Dependencies -> Dependencies sortDependencies d- = Deps { dep_mods = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d),+ = Deps { dep_mods = sortBy (compare `on` (moduleNameFS . gwib_mod)) (dep_mods d), dep_pkgs = sortBy (compare `on` fst) (dep_pkgs d), dep_orphs = sortBy stableModuleCmp (dep_orphs d), dep_finsts = sortBy stableModuleCmp (dep_finsts d),@@ -1346,7 +1348,7 @@ -> (Name -> IO Fingerprint) mkHashFun hsc_env eps name | isHoleModule orig_mod- = lookup (mkModule (thisPackage dflags) (moduleName orig_mod))+ = lookup (mkHomeModule dflags (moduleName orig_mod)) | otherwise = lookup orig_mod where
compiler/GHC/Iface/Recomp/Flags.hs view
@@ -36,7 +36,7 @@ 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)+ -- pkgopts = (homeUnit dflags, sort $ packageFlags dflags) safeHs = setSafeMode safeHaskell -- oflags = sort $ filter filterOFlags $ flags dflags @@ -55,7 +55,7 @@ paths = [ hcSuf ] -- -fprof-auto etc.- prof = if gopt Opt_SccProfilingOn dflags then fromEnum profAuto else 0+ prof = if sccProfilingEnabled dflags then fromEnum profAuto else 0 -- Ticky ticky =
compiler/GHC/Iface/Rename.hs view
@@ -76,18 +76,18 @@ failM -- | What we have is a generalized ModIface, which corresponds to--- a module that looks like p[A=<A>]:B. We need a *specific* ModIface, e.g.--- p[A=q():A]:B (or maybe even p[A=<B>]:B) which we load+-- a module that looks like p[A=\<A>]:B. We need a *specific* ModIface, e.g.+-- p[A=q():A]:B (or maybe even p[A=\<B>]:B) which we load -- up (either to merge it, or to just use during typechecking). -- -- Suppose we have: ----- p[A=<A>]:M ==> p[A=q():A]:M+-- p[A=\<A>]:M ==> p[A=q():A]:M ----- Substitute all occurrences of <A> with q():A (renameHoleModule).+-- Substitute all occurrences of \<A> with q():A (renameHoleModule). -- Then, for any Name of form {A.T}, replace the Name with -- the Name according to the exports of the implementing module.--- This works even for p[A=<B>]:M, since we just read in the+-- This works even for p[A=\<B>]:M, since we just read in the -- exports of B.hi, which is assumed to be ready now. -- -- This function takes an optional 'NameShape', which can be used@@ -148,7 +148,7 @@ -- -- However, we MUST NOT do this for regular modules. -- First, for efficiency reasons, doing this- -- bloats the the dep_finsts list, because we *already* had+ -- bloats the dep_finsts list, because we *already* had -- those modules in the list (it wasn't a hole module, after -- all). But there's a second, more important correctness -- consideration: we perform module renaming when running@@ -158,13 +158,13 @@ -- --abi-hash is just to get a hash of the on-disk interfaces -- for this *specific* package. If we go off and tug on the -- interface for /everything/ in dep_finsts, we're gonna have a- -- bad time. (It's safe to do do this for hole modules, though,+ -- bad time. (It's safe to do this for hole modules, though, -- because the hmap for --abi-hash is always trivial, so the -- interface we request is local. Though, maybe we ought -- not to do it in this case either...) -- -- This mistake was bug #15594.- let mod' = renameHoleModule (pkgState dflags) hmap mod+ let mod' = renameHoleModule (unitState 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 (pkgState dflags) hsubst+ rn_mod = renameHoleModule (unitState dflags) hsubst env = ShIfEnv { sh_if_module = rn_mod (mi_module iface), sh_if_semantic_module = rn_mod (mi_semantic_module iface),@@ -233,7 +233,7 @@ rnModule mod = do hmap <- getHoleSubst dflags <- getDynFlags- return (renameHoleModule (pkgState dflags) hmap mod)+ return (renameHoleModule (unitState dflags) hmap mod) rnAvailInfo :: Rename AvailInfo rnAvailInfo (Avail n) = Avail <$> rnIfaceGlobal n@@ -261,9 +261,9 @@ -- | The key function. This gets called on every Name embedded -- inside a ModIface. Our job is to take a Name from some--- generalized unit ID p[A=<A>, B=<B>], and change+-- generalized unit ID p[A=\<A>, B=\<B>], and change -- it to the correct name for a (partially) instantiated unit--- ID, e.g. p[A=q[]:A, B=<B>].+-- ID, e.g. p[A=q[]:A, B=\<B>]. -- -- There are two important things to do: --@@ -278,12 +278,12 @@ -- interface precisely to "merge it in". -- -- External case:--- p[A=<B>]:A (and thisUnitId is something else)+-- p[A=\<B>]:A (and thisUnitId is something else) -- We are loading this in order to determine B.hi! So -- don't load B.hi to find the exports. -- -- Local case:--- p[A=<A>]:A (and thisUnitId is p[A=<A>])+-- p[A=\<A>]:A (and thisUnitId is p[A=\<A>]) -- This should not happen, because the rename is not necessary -- in this case, but if it does we shouldn't load A.hi! --@@ -302,7 +302,7 @@ mb_nsubst <- fmap sh_if_shape getGblEnv hmap <- getHoleSubst let m = nameModule n- m' = renameHoleModule (pkgState dflags) hmap m+ m' = renameHoleModule (unitState dflags) hmap m case () of -- Did we encounter {A.T} while renaming p[A=<B>]:A? If so, -- do NOT assume B.hi is available.@@ -341,7 +341,7 @@ -- went from <A> to <B>. let m'' = if isHoleModule m' -- Pull out the local guy!!- then mkModule (thisPackage dflags) (moduleName m')+ then mkHomeModule dflags (moduleName m') else m' iface <- liftIO . initIfaceCheck (text "rnIfaceGlobal") hsc_env $ loadSysInterface (text "rnIfaceGlobal") m''@@ -363,7 +363,7 @@ hmap <- getHoleSubst dflags <- getDynFlags iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv- let m = renameHoleModule (pkgState dflags) hmap $ nameModule name+ let m = renameHoleModule (unitState 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@@ -557,7 +557,7 @@ let rnIfConEqSpec (n,t) = (,) n <$> rnIfaceType t con_eq_spec <- mapM rnIfConEqSpec (ifConEqSpec d) con_ctxt <- mapM rnIfaceType (ifConCtxt d)- con_arg_tys <- mapM rnIfaceType (ifConArgTys d)+ con_arg_tys <- mapM rnIfaceScaledType (ifConArgTys d) con_fields <- mapM rnFieldLabel (ifConFields d) let rnIfaceBang (IfUnpackCo co) = IfUnpackCo <$> rnIfaceCo co rnIfaceBang bang = pure bang@@ -644,7 +644,7 @@ rnIfaceBndrs = mapM rnIfaceBndr rnIfaceBndr :: Rename IfaceBndr-rnIfaceBndr (IfaceIdBndr (fs, ty)) = IfaceIdBndr <$> ((,) fs <$> rnIfaceType ty)+rnIfaceBndr (IfaceIdBndr (w, fs, ty)) = IfaceIdBndr <$> ((,,) w fs <$> rnIfaceType ty) rnIfaceBndr (IfaceTvBndr tv_bndr) = IfaceTvBndr <$> rnIfaceTvBndr tv_bndr rnIfaceTvBndr :: Rename IfaceTvBndr@@ -676,8 +676,8 @@ rnIfaceCo (IfaceReflCo ty) = IfaceReflCo <$> rnIfaceType ty rnIfaceCo (IfaceGReflCo role ty mco) = IfaceGReflCo role <$> rnIfaceType ty <*> rnIfaceMCo mco-rnIfaceCo (IfaceFunCo role co1 co2)- = IfaceFunCo role <$> rnIfaceCo co1 <*> rnIfaceCo co2+rnIfaceCo (IfaceFunCo role w co1 co2)+ = IfaceFunCo role <$> rnIfaceCo w <*> rnIfaceCo co1 <*> rnIfaceCo co2 rnIfaceCo (IfaceTyConAppCo role tc cos) = IfaceTyConAppCo role <$> rnIfaceTyCon tc <*> mapM rnIfaceCo cos rnIfaceCo (IfaceAppCo co1 co2)@@ -722,8 +722,8 @@ rnIfaceType (IfaceAppTy t1 t2) = IfaceAppTy <$> rnIfaceType t1 <*> rnIfaceAppArgs t2 rnIfaceType (IfaceLitTy l) = return (IfaceLitTy l)-rnIfaceType (IfaceFunTy af t1 t2)- = IfaceFunTy af <$> rnIfaceType t1 <*> rnIfaceType t2+rnIfaceType (IfaceFunTy af w t1 t2)+ = IfaceFunTy af <$> rnIfaceType w <*> rnIfaceType t1 <*> rnIfaceType t2 rnIfaceType (IfaceTupleTy s i tks) = IfaceTupleTy s i <$> rnIfaceAppArgs tks rnIfaceType (IfaceTyConApp tc tks)@@ -734,6 +734,9 @@ = IfaceCoercionTy <$> rnIfaceCo co rnIfaceType (IfaceCastTy ty co) = IfaceCastTy <$> rnIfaceType ty <*> rnIfaceCo co++rnIfaceScaledType :: Rename (IfaceMult, IfaceType)+rnIfaceScaledType (m, t) = (,) <$> rnIfaceType m <*> rnIfaceType t rnIfaceForAllBndr :: Rename (VarBndr IfaceBndr flag) rnIfaceForAllBndr (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis
compiler/GHC/Iface/Tidy.hs view
@@ -217,7 +217,7 @@ -- * VanillaIdInfo (makes a conservative assumption about arity) -- * BootUnfolding (see Note [Inlining and hs-boot files] in GHC.CoreToIface) globaliseAndTidyBootId id- = globaliseId id `setIdType` tidyTopType (idType id)+ = updateIdTypeAndMult tidyTopType (globaliseId id) `setIdUnfolding` BootUnfolding {-@@ -571,7 +571,7 @@ There is one sort of implicit binding that is injected still later, namely those for data constructor workers. Reason (I think): it's really just a code generation trick.... binding itself makes no sense.-See Note [Data constructor workers] in CorePrep.+See Note [Data constructor workers] in "GHC.CoreToStg.Prep". -} getImplicitBinds :: TyCon -> [CoreBind]
compiler/GHC/Iface/Tidy/StaticPtrTable.hs view
@@ -3,7 +3,7 @@ -- (c) 2014 I/O Tweag -- -- Each module that uses 'static' keyword declares an initialization function of--- the form hs_spt_init_<module>() which is emitted into the _stub.c file and+-- the form hs_spt_init_\<module>() which is emitted into the _stub.c file and -- annotated with __attribute__((constructor)) so that it gets executed at -- startup time. --@@ -28,7 +28,7 @@ -- -- The linker must find the definitions matching the @extern StgPtr <name>@ -- declarations. For this to work, the identifiers of static pointers need to be--- exported. This is done in GHC.Core.Opt.SetLevels.newLvlVar.+-- exported. This is done in 'GHC.Core.Opt.SetLevels.newLvlVar'. -- -- There is also a finalization function for the time when the module is -- unloaded.
− compiler/GHC/Iface/UpdateCafInfos.hs
@@ -1,148 +0,0 @@-{-# 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 "GhclibHsVersions.h"---- | Update CafInfos of all occurences (in rules, unfoldings, class instances)-updateModDetailsCafInfos- :: DynFlags- -> NonCaffySet -- ^ 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 _ (NonCaffySet 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
+ compiler/GHC/Iface/UpdateIdInfos.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE CPP, BangPatterns, Strict, RecordWildCards #-}++module GHC.Iface.UpdateIdInfos+ ( updateModDetailsIdInfos+ ) where++import GHC.Prelude++import GHC.Core+import GHC.Core.InstEnv+import GHC.Driver.Session+import GHC.Driver.Types+import GHC.StgToCmm.Types (CgInfos (..))+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Name.Env+import GHC.Types.Name.Set+import GHC.Types.Var+import GHC.Utils.Misc+import GHC.Utils.Outputable++#include "GhclibHsVersions.h"++-- | Update CafInfos and LFInfos of all occurences (in rules, unfoldings, class+-- instances).+--+-- See Note [Conveying CAF-info and LFInfo between modules] in+-- GHC.StgToCmm.Types.+updateModDetailsIdInfos+ :: DynFlags+ -> CgInfos+ -> ModDetails -- ^ ModDetails to update+ -> ModDetails++updateModDetailsIdInfos dflags _ mod_details+ | gopt Opt_OmitInterfacePragmas dflags+ = mod_details++updateModDetailsIdInfos _ cg_infos mod_details =+ let+ ModDetails{ md_types = type_env -- for unfoldings+ , md_insts = insts+ , md_rules = rules+ } = mod_details++ -- type TypeEnv = NameEnv TyThing+ ~type_env' = mapNameEnv (updateTyThingIdInfos type_env' cg_infos) type_env+ -- Not strict!++ !insts' = strictMap (updateInstIdInfos type_env' cg_infos) insts+ !rules' = strictMap (updateRuleIdInfos type_env') rules+ in+ mod_details{ md_types = type_env'+ , md_insts = insts'+ , md_rules = rules'+ }++--------------------------------------------------------------------------------+-- Rules+--------------------------------------------------------------------------------++updateRuleIdInfos :: TypeEnv -> CoreRule -> CoreRule+updateRuleIdInfos _ rule@BuiltinRule{} = rule+updateRuleIdInfos type_env Rule{ .. } = Rule { ru_rhs = updateGlobalIds type_env ru_rhs, .. }++--------------------------------------------------------------------------------+-- Instances+--------------------------------------------------------------------------------++updateInstIdInfos :: TypeEnv -> CgInfos -> ClsInst -> ClsInst+updateInstIdInfos type_env cg_infos =+ updateClsInstDFun (updateIdUnfolding type_env . updateIdInfo cg_infos)++--------------------------------------------------------------------------------+-- TyThings+--------------------------------------------------------------------------------++updateTyThingIdInfos :: TypeEnv -> CgInfos -> TyThing -> TyThing++updateTyThingIdInfos type_env cg_infos (AnId id) =+ AnId (updateIdUnfolding type_env (updateIdInfo cg_infos id))++updateTyThingIdInfos _ _ 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+--------------------------------------------------------------------------------++updateIdInfo :: CgInfos -> Id -> Id+updateIdInfo CgInfos{ cgNonCafs = NonCaffySet non_cafs, cgLFInfos = lf_infos } id =+ let+ not_caffy = elemNameSet (idName id) non_cafs+ mb_lf_info = lookupNameEnv lf_infos (idName id)++ id1 = if not_caffy then setIdCafInfo id NoCafRefs else id+ id2 = case mb_lf_info of+ Nothing -> id1+ Just lf_info -> setIdLFInfo id1 lf_info+ in+ id2++--------------------------------------------------------------------------------++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 "UpdateIdInfos.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
compiler/GHC/IfaceToCore.hs view
@@ -19,7 +19,8 @@ tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules, tcIfaceAnnotations, tcIfaceCompleteSigs, tcIfaceExpr, -- Desired by HERMIT (#7683)- tcIfaceGlobal+ tcIfaceGlobal,+ tcIfaceOneShot ) where #include "GhclibHsVersions.h"@@ -30,6 +31,7 @@ import GHC.Iface.Syntax import GHC.Iface.Load import GHC.Iface.Env+import GHC.StgToCmm.Types import GHC.Tc.TyCl.Build import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType@@ -55,7 +57,6 @@ import GHC.Core.TyCon import GHC.Core.ConLike import GHC.Core.DataCon-import GHC.Builtin.Names import GHC.Builtin.Types import GHC.Types.Literal import GHC.Types.Var as Var@@ -354,7 +355,7 @@ typecheckIfacesForMerging :: Module -> [ModIface] -> IORef TypeEnv -> IfM lcl (TypeEnv, [ModDetails]) typecheckIfacesForMerging mod ifaces tc_env_var = -- cannot be boot (False)- initIfaceLcl mod (text "typecheckIfacesForMerging") False $ do+ initIfaceLcl mod (text "typecheckIfacesForMerging") NotBoot $ do ignore_prags <- goptM Opt_IgnoreInterfacePragmas -- Build the initial environment -- NB: Don't include dfuns here, because we don't want to@@ -506,7 +507,7 @@ -- it's been compiled once, and we don't need to check the boot iface then do { hpt <- getHpt ; case lookupHpt hpt (moduleName mod) of- Just info | mi_boot (hm_iface info)+ Just info | mi_boot (hm_iface info) == IsBoot -> mkSelfBootInfo (hm_iface info) (hm_details info) _ -> return NoSelfBoot } else do@@ -517,7 +518,7 @@ -- that an hi-boot is necessary due to a circular import. { read_result <- findAndReadIface need (fst (getModuleInstantiation mod)) mod- True -- Hi-boot file+ IsBoot -- Hi-boot file ; case read_result of { Succeeded (iface, _path) -> do { tc_iface <- initIfaceTcRn $ typecheckIface iface@@ -533,14 +534,15 @@ -- disappeared. do { eps <- getEps ; case lookupUFM (eps_is_boot eps) (moduleName mod) of- Nothing -> return NoSelfBoot -- The typical case-- Just (_, False) -> failWithTc moduleLoop- -- Someone below us imported us!- -- This is a loop with no hi-boot in the way-- Just (_mod, True) -> failWithTc (elaborate err)- -- The hi-boot file has mysteriously disappeared.+ -- The typical case+ Nothing -> return NoSelfBoot+ -- error cases+ Just (GWIB { gwib_isBoot = is_boot }) -> case is_boot of+ IsBoot -> failWithTc (elaborate err)+ -- The hi-boot file has mysteriously disappeared.+ NotBoot -> failWithTc moduleLoop+ -- Someone below us imported us!+ -- This is a loop with no hi-boot in the way }}}} where need = text "Need the hi-boot interface for" <+> ppr mod@@ -921,7 +923,7 @@ -- below is always guaranteed to succeed. ; user_tv_bndrs <- mapM (\(Bndr bd vis) -> case bd of- IfaceIdBndr (name, _) ->+ IfaceIdBndr (_, name, _) -> Bndr <$> tcIfaceLclId name <*> pure vis IfaceTvBndr (name, _) -> Bndr <$> tcIfaceTyVar name <*> pure vis)@@ -942,7 +944,7 @@ -- the argument types was recursively defined. -- See also Note [Tying the knot] ; arg_tys <- forkM (mk_doc dc_name <+> text "arg_tys")- $ mapM tcIfaceType args+ $ mapM (\(w, ty) -> mkScaled <$> tcIfaceType w <*> tcIfaceType ty) args ; stricts <- mapM tc_strict if_stricts -- The IfBang field can mention -- the type itself; hence inside forkM@@ -1161,11 +1163,11 @@ tcIfaceType :: IfaceType -> IfL Type tcIfaceType = go where- go (IfaceTyVar n) = TyVarTy <$> tcIfaceTyVar n- go (IfaceFreeTyVar n) = pprPanic "tcIfaceType:IfaceFreeTyVar" (ppr n)- go (IfaceLitTy l) = LitTy <$> tcIfaceTyLit l- go (IfaceFunTy flag t1 t2) = FunTy flag <$> go t1 <*> go t2- go (IfaceTupleTy s i tks) = tcIfaceTupleTy s i tks+ go (IfaceTyVar n) = TyVarTy <$> tcIfaceTyVar n+ go (IfaceFreeTyVar n) = pprPanic "tcIfaceType:IfaceFreeTyVar" (ppr n)+ go (IfaceLitTy l) = LitTy <$> tcIfaceTyLit l+ go (IfaceFunTy flag w t1 t2) = FunTy flag <$> tcIfaceType w <*> go t1 <*> go t2+ go (IfaceTupleTy s i tks) = tcIfaceTupleTy s i tks go (IfaceAppTy t ts) = do { t' <- go t ; ts' <- traverse go (appArgsIfaceTypes ts)@@ -1237,7 +1239,7 @@ go (IfaceReflCo t) = Refl <$> tcIfaceType t go (IfaceGReflCo r t mco) = GRefl r <$> tcIfaceType t <*> go_mco mco- go (IfaceFunCo r c1 c2) = mkFunCo r <$> go c1 <*> go c2+ go (IfaceFunCo r w c1 c2) = mkFunCo r <$> go w <*> go c1 <*> go c2 go (IfaceTyConAppCo r tc cs) = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs go (IfaceAppCo c1 c2) = AppCo <$> go c1 <*> go c2@@ -1339,7 +1341,8 @@ case_bndr_name <- newIfaceName (mkVarOccFS case_bndr) let scrut_ty = exprType scrut'- case_bndr' = mkLocalIdOrCoVar case_bndr_name scrut_ty+ case_mult = Many+ case_bndr' = mkLocalIdOrCoVar case_bndr_name case_mult scrut_ty -- "OrCoVar" since a coercion can be a scrutinee with -fdefer-type-errors -- (e.g. see test T15695). Ticket #17291 covers fixing this problem. tc_app = splitTyConApp scrut_ty@@ -1350,7 +1353,7 @@ -- corresponds to the datacon in this case alternative extendIfaceIdEnv [case_bndr'] $ do- alts' <- mapM (tcIfaceAlt scrut' tc_app) alts+ alts' <- mapM (tcIfaceAlt scrut' case_mult tc_app) alts return (Case scrut' case_bndr' (coreAltsType alts') alts') tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body)@@ -1358,7 +1361,7 @@ ; ty' <- tcIfaceType ty ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -} NotTopLevel name ty' info- ; let id = mkLocalIdWithInfo name ty' id_info+ ; let id = mkLocalIdWithInfo name Many ty' id_info `asJoinId_maybe` tcJoinInfo ji ; rhs' <- tcIfaceExpr rhs ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)@@ -1374,7 +1377,7 @@ tc_rec_bndr (IfLetBndr fs ty _ ji) = do { name <- newIfaceName (mkVarOccFS fs) ; ty' <- tcIfaceType ty- ; return (mkLocalId name ty' `asJoinId_maybe` tcJoinInfo ji) }+ ; return (mkLocalId name Many ty' `asJoinId_maybe` tcJoinInfo ji) } tc_pair (IfLetBndr _ _ info _, rhs) id = do { rhs' <- tcIfaceExpr rhs ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}@@ -1400,30 +1403,18 @@ ------------------------- tcIfaceLit :: Literal -> IfL Literal--- Integer literals deserialise to (LitInteger i <error thunk>)--- so tcIfaceLit just fills in the type.--- See Note [Integer literals] in GHC.Types.Literal-tcIfaceLit (LitNumber LitNumInteger i _)- = do t <- tcIfaceTyConByName integerTyConName- return (mkLitInteger i (mkTyConTy t))--- Natural literals deserialise to (LitNatural i <error thunk>)--- so tcIfaceLit just fills in the type.--- See Note [Natural literals] in GHC.Types.Literal-tcIfaceLit (LitNumber LitNumNatural i _)- = do t <- tcIfaceTyConByName naturalTyConName- return (mkLitNatural i (mkTyConTy t)) tcIfaceLit lit = return lit --------------------------tcIfaceAlt :: CoreExpr -> (TyCon, [Type])+tcIfaceAlt :: CoreExpr -> Mult -> (TyCon, [Type]) -> (IfaceConAlt, [FastString], IfaceExpr) -> IfL (AltCon, [TyVar], CoreExpr)-tcIfaceAlt _ _ (IfaceDefault, names, rhs)+tcIfaceAlt _ _ _ (IfaceDefault, names, rhs) = ASSERT( null names ) do rhs' <- tcIfaceExpr rhs return (DEFAULT, [], rhs') -tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs)+tcIfaceAlt _ _ _ (IfaceLitAlt lit, names, rhs) = ASSERT( null names ) do lit' <- tcIfaceLit lit rhs' <- tcIfaceExpr rhs@@ -1432,19 +1423,19 @@ -- A case alternative is made quite a bit more complicated -- by the fact that we omit type annotations because we can -- work them out. True enough, but its not that easy!-tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs)+tcIfaceAlt scrut mult (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs) = do { con <- tcIfaceDataCon data_occ ; when (debugIsOn && not (con `elem` tyConDataCons tycon)) (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))- ; tcIfaceDataAlt con inst_tys arg_strs rhs }+ ; tcIfaceDataAlt mult con inst_tys arg_strs rhs } -tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr+tcIfaceDataAlt :: Mult -> DataCon -> [Type] -> [FastString] -> IfaceExpr -> IfL (AltCon, [TyVar], CoreExpr)-tcIfaceDataAlt con inst_tys arg_strs rhs+tcIfaceDataAlt mult con inst_tys arg_strs rhs = do { us <- newUniqueSupply ; let uniqs = uniqsFromSupply us ; let (ex_tvs, arg_ids)- = dataConRepFSInstPat arg_strs uniqs con inst_tys+ = dataConRepFSInstPat arg_strs uniqs mult con inst_tys ; rhs' <- extendIfaceEnvs ex_tvs $ extendIfaceIdEnv arg_ids $@@ -1480,11 +1471,11 @@ lcl_env <- getLclEnv -- Set the CgInfo to something sensible but uninformative before -- we start; default assumption is that it has CAFs- let init_info | if_boot lcl_env = vanillaIdInfo `setUnfoldingInfo` BootUnfolding- | otherwise = vanillaIdInfo+ let init_info = if if_boot lcl_env == IsBoot+ then vanillaIdInfo `setUnfoldingInfo` BootUnfolding+ else vanillaIdInfo - let needed = needed_prags info- foldlM tcPrag init_info needed+ foldlM tcPrag init_info (needed_prags info) where needed_prags :: [IfaceInfoItem] -> [IfaceInfoItem] needed_prags items@@ -1504,6 +1495,9 @@ tcPrag info (HsCpr cpr) = return (info `setCprInfo` cpr) tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag) tcPrag info HsLevity = return (info `setNeverLevPoly` ty)+ tcPrag info (HsLFInfo lf_info) = do+ lf_info <- tcLFInfo lf_info+ return (info `setLFInfo` lf_info) -- The next two are lazy, so they don't transitively suck stuff in tcPrag info (HsUnfold lb if_unf)@@ -1516,6 +1510,38 @@ tcJoinInfo (IfaceJoinPoint ar) = Just ar tcJoinInfo IfaceNotJoinPoint = Nothing +tcLFInfo :: IfaceLFInfo -> IfL LambdaFormInfo+tcLFInfo lfi = case lfi of+ IfLFReEntrant rep_arity ->+ -- LFReEntrant closures in interface files are guaranteed to+ --+ -- - Be top-level, as only top-level closures are exported.+ -- - Have no free variables, as only non-top-level closures have free+ -- variables+ -- - Don't have ArgDescrs, as ArgDescr is used when generating code for+ -- the closure+ --+ -- These invariants are checked when generating LFInfos in toIfaceLFInfo.+ return (LFReEntrant TopLevel rep_arity True ArgUnknown)++ IfLFThunk updatable mb_fun ->+ -- LFThunk closure in interface files are guaranteed to+ --+ -- - Be top-level+ -- - No have free variables+ --+ -- These invariants are checked when generating LFInfos in toIfaceLFInfo.+ return (LFThunk TopLevel True updatable NonStandardThunk mb_fun)++ IfLFUnlifted ->+ return LFUnlifted++ IfLFCon con_name ->+ LFCon <$!> tcIfaceDataCon con_name++ IfLFUnknown fun_flag ->+ return (LFUnknown fun_flag)+ tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr) = do { dflags <- getDynFlags@@ -1527,7 +1553,7 @@ Just expr -> mkFinalUnfolding dflags unf_src strict_sig expr } where- -- Strictness should occur before unfolding!+ -- Strictness should occur before unfolding! strict_sig = strictnessInfo info tcUnfolding toplvl name _ _ (IfCompulsory if_expr)@@ -1602,6 +1628,10 @@ -- It's OK to use nonDetEltsUFM here because we immediately forget -- the ordering by creating a set +tcIfaceOneShot :: IfaceOneShot -> OneShotInfo+tcIfaceOneShot IfaceNoOneShot = NoOneShotInfo+tcIfaceOneShot IfaceOneShot = OneShotLam+ {- ************************************************************************ * *@@ -1704,11 +1734,6 @@ -- the constructor (A and B) means that GHC will always typecheck -- this expression *after* typechecking T. -tcIfaceTyConByName :: IfExtName -> IfL TyCon-tcIfaceTyConByName name- = do { thing <- tcIfaceGlobal name- ; return (tyThingTyCon thing) }- tcIfaceTyCon :: IfaceTyCon -> IfL TyCon tcIfaceTyCon (IfaceTyCon name info) = do { thing <- tcIfaceGlobal name@@ -1762,10 +1787,11 @@ -} bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a-bindIfaceId (fs, ty) thing_inside+bindIfaceId (w, fs, ty) thing_inside = do { name <- newIfaceName (mkVarOccFS fs) ; ty' <- tcIfaceType ty- ; let id = mkLocalIdOrCoVar name ty'+ ; w' <- tcIfaceType w+ ; let id = mkLocalIdOrCoVar name w' ty' -- We should not have "OrCoVar" here, this is a bug (#17545) ; extendIfaceIdEnv [id] (thing_inside id) }
compiler/GHC/Llvm.hs view
@@ -6,10 +6,12 @@ -- LLVM binding library in Haskell, but enough to generate code for GHC. -- -- This code is derived from code taken from the Essential Haskell Compiler--- (EHC) project (<http://www.cs.uu.nl/wiki/Ehc/WebHome>).+-- (EHC) project. -- module GHC.Llvm (+ LlvmOpts (..),+ initLlvmOpts, -- * Modules, Functions and Blocks LlvmModule(..),@@ -50,7 +52,7 @@ pLift, pLower, isInt, isFloat, isPointer, isVector, llvmWidthInBits, -- * Pretty Printing- ppLit, ppName, ppPlainName,+ ppVar, ppLit, ppTypeLit, ppName, ppPlainName, ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmGlobals, ppLlvmGlobal, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions, ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, ppLlvmMetas, ppLlvmMeta,
compiler/GHC/Llvm/MetaData.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-} module GHC.Llvm.MetaData where @@ -11,8 +12,8 @@ -- -- The LLVM metadata feature is poorly documented but roughly follows the -- following design:--- * Metadata can be constructed in a few different ways (See below).--- * After which it can either be attached to LLVM statements to pass along+-- - Metadata can be constructed in a few different ways (See below).+-- - After which it can either be attached to LLVM statements to pass along -- extra information to the optimizer and code generator OR specifically named -- metadata has an affect on the whole module (i.e., linking behaviour). --@@ -20,18 +21,18 @@ -- # Constructing metadata -- Metadata comes largely in three forms: ----- * Metadata expressions -- these are the raw metadata values that encode+-- - Metadata expressions -- these are the raw metadata values that encode -- information. They consist of metadata strings, metadata nodes, regular -- LLVM values (both literals and references to global variables) and -- metadata expressions (i.e., recursive data type). Some examples: -- !{ !"hello", !0, i32 0 } -- !{ !1, !{ i32 0 } } ----- * Metadata nodes -- global metadata variables that attach a metadata+-- - Metadata nodes -- global metadata variables that attach a metadata -- expression to a number. For example: -- !0 = !{ [<metadata expressions>] !} ----- * Named metadata -- global metadata variables that attach a metadata nodes+-- - Named metadata -- global metadata variables that attach a metadata nodes -- to a name. Used ONLY to communicated module level information to LLVM -- through a meaningful name. For example: -- !llvm.module.linkage = !{ !0, !1 }@@ -40,7 +41,7 @@ -- # Using Metadata -- Using metadata depends on the form it is in: ----- * Attach to instructions -- metadata can be attached to LLVM instructions+-- - Attach to instructions -- metadata can be attached to LLVM instructions -- using a specific reference as follows: -- %l = load i32* @glob, !nontemporal !10 -- %m = load i32* @glob, !nontemporal !{ i32 0, !{ i32 0 } }@@ -48,12 +49,12 @@ -- Refer to LLVM documentation for which instructions take metadata and its -- meaning. ----- * As arguments -- llvm functions can take metadata as arguments, for+-- - As arguments -- llvm functions can take metadata as arguments, for -- example: -- call void @llvm.dbg.value(metadata !{ i32 0 }, i64 0, metadata !1) -- As with instructions, only metadata nodes or expressions can be attached. ----- * As a named metadata -- Here the metadata is simply declared in global+-- - As a named metadata -- Here the metadata is simply declared in global -- scope using a specific name to communicate module level information to LLVM. -- For example: -- !llvm.module.linkage = !{ !0, !1 }@@ -73,13 +74,6 @@ | MetaStruct [MetaExpr] deriving (Eq) -instance Outputable MetaExpr where- ppr (MetaVar (LMLitVar (LMNullLit _))) = text "null"- ppr (MetaStr s ) = char '!' <> doubleQuotes (ftext s)- ppr (MetaNode n ) = ppr n- ppr (MetaVar v ) = ppr v- ppr (MetaStruct es) = char '!' <> braces (ppCommaJoin es)- -- | Associates some metadata with a specific label for attaching to an -- instruction. data MetaAnnot = MetaAnnot LMString MetaExpr@@ -88,8 +82,8 @@ -- | Metadata declarations. Metadata can only be declared in global scope. data MetaDecl -- | Named metadata. Only used for communicating module information to- -- LLVM. ('!name = !{ [!<n>] }' form).+ -- LLVM. ('!name = !{ [!\<n>] }' form). = MetaNamed !LMString [MetaId] -- | Metadata node declaration.- -- ('!0 = metadata !{ <metadata expression> }' form).+ -- ('!0 = metadata !{ \<metadata expression> }' form). | MetaUnnamed !MetaId !MetaExpr
compiler/GHC/Llvm/Ppr.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} -------------------------------------------------------------------------------- -- | Pretty print LLVM IR Code.@@ -21,6 +22,12 @@ ppLlvmFunctions, ppLlvmFunction, + ppVar,+ ppLit,+ ppTypeLit,+ ppName,+ ppPlainName+ ) where #include "GhclibHsVersions.h"@@ -30,26 +37,26 @@ import GHC.Llvm.Syntax import GHC.Llvm.MetaData import GHC.Llvm.Types-import GHC.Platform +import Data.Int import Data.List ( intersperse ) import GHC.Utils.Outputable import GHC.Types.Unique-import GHC.Data.FastString ( sLit )+import GHC.Data.FastString -------------------------------------------------------------------------------- -- * Top Level Print functions -------------------------------------------------------------------------------- -- | Print out a whole LLVM module.-ppLlvmModule :: Platform -> LlvmModule -> SDoc-ppLlvmModule platform (LlvmModule comments aliases meta globals decls funcs)+ppLlvmModule :: LlvmOpts -> LlvmModule -> SDoc+ppLlvmModule opts (LlvmModule comments aliases meta globals decls funcs) = ppLlvmComments comments $+$ newLine $+$ ppLlvmAliases aliases $+$ newLine- $+$ ppLlvmMetas meta $+$ newLine- $+$ ppLlvmGlobals globals $+$ newLine+ $+$ ppLlvmMetas opts meta $+$ newLine+ $+$ ppLlvmGlobals opts globals $+$ newLine $+$ ppLlvmFunctionDecls decls $+$ newLine- $+$ ppLlvmFunctions platform funcs+ $+$ ppLlvmFunctions opts funcs -- | Print out a multi-line comment, can be inside a function or on its own ppLlvmComments :: [LMString] -> SDoc@@ -61,12 +68,12 @@ -- | Print out a list of global mutable variable definitions-ppLlvmGlobals :: [LMGlobal] -> SDoc-ppLlvmGlobals ls = vcat $ map ppLlvmGlobal ls+ppLlvmGlobals :: LlvmOpts -> [LMGlobal] -> SDoc+ppLlvmGlobals opts ls = vcat $ map (ppLlvmGlobal opts) ls -- | Print out a global mutable variable definition-ppLlvmGlobal :: LMGlobal -> SDoc-ppLlvmGlobal (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) =+ppLlvmGlobal :: LlvmOpts -> LMGlobal -> SDoc+ppLlvmGlobal opts (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) = let sect = case x of Just x' -> text ", section" <+> doubleQuotes (ftext x') Nothing -> empty@@ -76,7 +83,7 @@ Nothing -> empty rhs = case dat of- Just stat -> pprSpecialStatic stat+ Just stat -> pprSpecialStatic opts stat Nothing -> ppr (pLower $ getVarType var) -- Position of linkage is different for aliases.@@ -85,11 +92,11 @@ Constant -> "constant" Alias -> "alias" - in ppAssignment var $ ppr link <+> text const <+> rhs <> sect <> align+ in ppAssignment opts var $ ppr link <+> text const <+> rhs <> sect <> align $+$ newLine -ppLlvmGlobal (LMGlobal var val) = pprPanic "ppLlvmGlobal" $- text "Non Global var ppr as global! " <> ppr var <> text "=" <> ppr val+ppLlvmGlobal opts (LMGlobal var val) = pprPanic "ppLlvmGlobal" $+ text "Non Global var ppr as global! " <> ppVar opts var <> text "=" <> ppr (fmap (ppStatic opts) val) -- | Print out a list of LLVM type aliases.@@ -103,38 +110,38 @@ -- | Print out a list of LLVM metadata.-ppLlvmMetas :: [MetaDecl] -> SDoc-ppLlvmMetas metas = vcat $ map ppLlvmMeta metas+ppLlvmMetas :: LlvmOpts -> [MetaDecl] -> SDoc+ppLlvmMetas opts metas = vcat $ map (ppLlvmMeta opts) metas -- | Print out an LLVM metadata definition.-ppLlvmMeta :: MetaDecl -> SDoc-ppLlvmMeta (MetaUnnamed n m)- = ppr n <+> equals <+> ppr m+ppLlvmMeta :: LlvmOpts -> MetaDecl -> SDoc+ppLlvmMeta opts (MetaUnnamed n m)+ = ppr n <+> equals <+> ppMetaExpr opts m -ppLlvmMeta (MetaNamed n m)+ppLlvmMeta _opts (MetaNamed n m) = exclamation <> ftext n <+> equals <+> exclamation <> braces nodes where nodes = hcat $ intersperse comma $ map ppr m -- | Print out a list of function definitions.-ppLlvmFunctions :: Platform -> LlvmFunctions -> SDoc-ppLlvmFunctions platform funcs = vcat $ map (ppLlvmFunction platform) funcs+ppLlvmFunctions :: LlvmOpts -> LlvmFunctions -> SDoc+ppLlvmFunctions opts funcs = vcat $ map (ppLlvmFunction opts) funcs -- | Print out a function definition.-ppLlvmFunction :: Platform -> LlvmFunction -> SDoc-ppLlvmFunction platform fun =+ppLlvmFunction :: LlvmOpts -> LlvmFunction -> SDoc+ppLlvmFunction opts fun = let attrDoc = ppSpaceJoin (funcAttrs fun) secDoc = case funcSect fun of Just s' -> text "section" <+> (doubleQuotes $ ftext s') Nothing -> empty prefixDoc = case funcPrefix fun of- Just v -> text "prefix" <+> ppr v+ Just v -> text "prefix" <+> ppStatic opts v Nothing -> empty in text "define" <+> ppLlvmFunctionHeader (funcDecl fun) (funcArgs fun) <+> attrDoc <+> secDoc <+> prefixDoc $+$ lbrace- $+$ ppLlvmBlocks platform (funcBody fun)+ $+$ ppLlvmBlocks opts (funcBody fun) $+$ rbrace $+$ newLine $+$ newLine@@ -178,21 +185,21 @@ -- | Print out a list of LLVM blocks.-ppLlvmBlocks :: Platform -> LlvmBlocks -> SDoc-ppLlvmBlocks platform blocks = vcat $ map (ppLlvmBlock platform) blocks+ppLlvmBlocks :: LlvmOpts -> LlvmBlocks -> SDoc+ppLlvmBlocks opts blocks = vcat $ map (ppLlvmBlock opts) blocks -- | Print out an LLVM block. -- It must be part of a function definition.-ppLlvmBlock :: Platform -> LlvmBlock -> SDoc-ppLlvmBlock platform (LlvmBlock blockId stmts) =+ppLlvmBlock :: LlvmOpts -> LlvmBlock -> SDoc+ppLlvmBlock opts (LlvmBlock blockId stmts) = let isLabel (MkLabel _) = True isLabel _ = False (block, rest) = break isLabel stmts ppRest = case rest of- MkLabel id:xs -> ppLlvmBlock platform (LlvmBlock id xs)+ MkLabel id:xs -> ppLlvmBlock opts (LlvmBlock id xs) _ -> empty in ppLlvmBlockLabel blockId- $+$ (vcat $ map (ppLlvmStatement platform) block)+ $+$ (vcat $ map (ppLlvmStatement opts) block) $+$ newLine $+$ ppRest @@ -202,57 +209,65 @@ -- | Print out an LLVM statement.-ppLlvmStatement :: Platform -> LlvmStatement -> SDoc-ppLlvmStatement platform stmt =+ppLlvmStatement :: LlvmOpts -> LlvmStatement -> SDoc+ppLlvmStatement opts stmt = let ind = (text " " <>) in case stmt of- Assignment dst expr -> ind $ ppAssignment dst (ppLlvmExpression platform expr)+ Assignment dst expr -> ind $ ppAssignment opts dst (ppLlvmExpression opts expr) Fence st ord -> ind $ ppFence st ord- Branch target -> ind $ ppBranch target- BranchIf cond ifT ifF -> ind $ ppBranchIf cond ifT ifF+ Branch target -> ind $ ppBranch opts target+ BranchIf cond ifT ifF -> ind $ ppBranchIf opts cond ifT ifF Comment comments -> ind $ ppLlvmComments comments MkLabel label -> ppLlvmBlockLabel label- Store value ptr -> ind $ ppStore value ptr- Switch scrut def tgs -> ind $ ppSwitch scrut def tgs- Return result -> ind $ ppReturn result- Expr expr -> ind $ ppLlvmExpression platform expr+ Store value ptr -> ind $ ppStore opts value ptr+ Switch scrut def tgs -> ind $ ppSwitch opts scrut def tgs+ Return result -> ind $ ppReturn opts result+ Expr expr -> ind $ ppLlvmExpression opts expr Unreachable -> ind $ text "unreachable" Nop -> empty- MetaStmt meta s -> ppMetaStatement platform meta s+ MetaStmt meta s -> ppMetaStatement opts meta s -- | Print out an LLVM expression.-ppLlvmExpression :: Platform -> LlvmExpression -> SDoc-ppLlvmExpression platform expr+ppLlvmExpression :: LlvmOpts -> LlvmExpression -> SDoc+ppLlvmExpression opts expr = case expr of- Alloca tp amount -> ppAlloca tp amount- LlvmOp op left right -> ppMachOp op left right- Call tp fp args attrs -> ppCall tp fp (map MetaVar args) attrs- CallM tp fp args attrs -> ppCall tp fp args attrs- Cast op from to -> ppCast op from to- Compare op left right -> ppCmpOp op left right- Extract vec idx -> ppExtract vec idx- ExtractV struct idx -> ppExtractV struct idx- Insert vec elt idx -> ppInsert vec elt idx- GetElemPtr inb ptr indexes -> ppGetElementPtr inb ptr indexes- Load ptr -> ppLoad ptr- ALoad ord st ptr -> ppALoad platform ord st ptr- Malloc tp amount -> ppMalloc tp amount- AtomicRMW aop tgt src ordering -> ppAtomicRMW aop tgt src ordering- CmpXChg addr old new s_ord f_ord -> ppCmpXChg addr old new s_ord f_ord- Phi tp predecessors -> ppPhi tp predecessors- Asm asm c ty v se sk -> ppAsm asm c ty v se sk- MExpr meta expr -> ppMetaExpr platform meta expr+ Alloca tp amount -> ppAlloca opts tp amount+ LlvmOp op left right -> ppMachOp opts op left right+ Call tp fp args attrs -> ppCall opts tp fp (map MetaVar args) attrs+ CallM tp fp args attrs -> ppCall opts tp fp args attrs+ Cast op from to -> ppCast opts op from to+ Compare op left right -> ppCmpOp opts op left right+ Extract vec idx -> ppExtract opts vec idx+ ExtractV struct idx -> ppExtractV opts struct idx+ Insert vec elt idx -> ppInsert opts vec elt idx+ GetElemPtr inb ptr indexes -> ppGetElementPtr opts inb ptr indexes+ Load ptr -> ppLoad opts ptr+ ALoad ord st ptr -> ppALoad opts ord st ptr+ Malloc tp amount -> ppMalloc opts tp amount+ AtomicRMW aop tgt src ordering -> ppAtomicRMW opts aop tgt src ordering+ CmpXChg addr old new s_ord f_ord -> ppCmpXChg opts addr old new s_ord f_ord+ Phi tp predecessors -> ppPhi opts tp predecessors+ Asm asm c ty v se sk -> ppAsm opts asm c ty v se sk+ MExpr meta expr -> ppMetaAnnotExpr opts meta expr +ppMetaExpr :: LlvmOpts -> MetaExpr -> SDoc+ppMetaExpr opts = \case+ MetaVar (LMLitVar (LMNullLit _)) -> text "null"+ MetaStr s -> char '!' <> doubleQuotes (ftext s)+ MetaNode n -> ppr n+ MetaVar v -> ppVar opts v+ MetaStruct es -> char '!' <> braces (ppCommaJoin (map (ppMetaExpr opts) es)) + -------------------------------------------------------------------------------- -- * Individual print functions -------------------------------------------------------------------------------- -- | Should always be a function pointer. So a global var of function type -- (since globals are always pointers) or a local var of pointer function type.-ppCall :: LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc-ppCall ct fptr args attrs = case fptr of+ppCall :: LlvmOpts -> LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc+ppCall opts ct fptr args attrs = case fptr of -- -- if local var function pointer, unwrap LMLocalVar _ (LMPointer (LMFunction d)) -> ppCall' d@@ -269,29 +284,29 @@ ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) = let tc = if ct == TailCall then text "tail " else empty ppValues = hsep $ punctuate comma $ map ppCallMetaExpr args- ppArgTy = (ppCommaJoin $ map fst params) <>+ ppArgTy = (ppCommaJoin $ map (ppr . fst) params) <> (case argTy of VarArgs -> text ", ..." FixedArgs -> empty) fnty = space <> lparen <> ppArgTy <> rparen attrDoc = ppSpaceJoin attrs in tc <> text "call" <+> ppr cc <+> ppr ret- <> fnty <+> ppName fptr <> lparen <+> ppValues+ <> fnty <+> ppName opts fptr <> lparen <+> ppValues <+> rparen <+> attrDoc -- Metadata needs to be marked as having the `metadata` type when used -- in a call argument- ppCallMetaExpr (MetaVar v) = ppr v- ppCallMetaExpr v = text "metadata" <+> ppr v+ ppCallMetaExpr (MetaVar v) = ppVar opts v+ ppCallMetaExpr v = text "metadata" <+> ppMetaExpr opts v -ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc-ppMachOp op left right =- (ppr op) <+> (ppr (getVarType left)) <+> ppName left- <> comma <+> ppName right+ppMachOp :: LlvmOpts -> LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc+ppMachOp opts op left right =+ (ppr op) <+> (ppr (getVarType left)) <+> ppName opts left+ <> comma <+> ppName opts right -ppCmpOp :: LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc-ppCmpOp op left right =+ppCmpOp :: LlvmOpts -> LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc+ppCmpOp opts op left right = let cmpOp | isInt (getVarType left) && isInt (getVarType right) = text "icmp" | isFloat (getVarType left) && isFloat (getVarType right) = text "fcmp"@@ -302,11 +317,11 @@ ++ (show $ getVarType right)) -} in cmpOp <+> ppr op <+> ppr (getVarType left)- <+> ppName left <> comma <+> ppName right+ <+> ppName opts left <> comma <+> ppName opts right -ppAssignment :: LlvmVar -> SDoc -> SDoc-ppAssignment var expr = ppName var <+> equals <+> expr+ppAssignment :: LlvmOpts -> LlvmVar -> SDoc -> SDoc+ppAssignment opts var expr = ppName opts var <+> equals <+> expr ppFence :: Bool -> LlvmSyncOrdering -> SDoc ppFence st ord =@@ -335,15 +350,15 @@ ppAtomicOp LAO_Umax = text "umax" ppAtomicOp LAO_Umin = text "umin" -ppAtomicRMW :: LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc-ppAtomicRMW aop tgt src ordering =- text "atomicrmw" <+> ppAtomicOp aop <+> ppr tgt <> comma- <+> ppr src <+> ppSyncOrdering ordering+ppAtomicRMW :: LlvmOpts -> LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc+ppAtomicRMW opts aop tgt src ordering =+ text "atomicrmw" <+> ppAtomicOp aop <+> ppVar opts tgt <> comma+ <+> ppVar opts src <+> ppSyncOrdering ordering -ppCmpXChg :: LlvmVar -> LlvmVar -> LlvmVar+ppCmpXChg :: LlvmOpts -> LlvmVar -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> LlvmSyncOrdering -> SDoc-ppCmpXChg addr old new s_ord f_ord =- text "cmpxchg" <+> ppr addr <> comma <+> ppr old <> comma <+> ppr new+ppCmpXChg opts addr old new s_ord f_ord =+ text "cmpxchg" <+> ppVar opts addr <> comma <+> ppVar opts old <> comma <+> ppVar opts new <+> ppSyncOrdering s_ord <+> ppSyncOrdering f_ord -- XXX: On x86, vector types need to be 16-byte aligned for aligned access, but@@ -354,138 +369,228 @@ -- access patterns are aligned, in which case we will need a more granular way -- of specifying alignment. -ppLoad :: LlvmVar -> SDoc-ppLoad var = text "load" <+> ppr derefType <> comma <+> ppr var <> align+ppLoad :: LlvmOpts -> LlvmVar -> SDoc+ppLoad opts var = text "load" <+> ppr derefType <> comma <+> ppVar opts var <> align where derefType = pLower $ getVarType var align | isVector . pLower . getVarType $ var = text ", align 1" | otherwise = empty -ppALoad :: Platform -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc-ppALoad platform ord st var =- let alignment = (llvmWidthInBits platform $ getVarType var) `quot` 8+ppALoad :: LlvmOpts -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc+ppALoad opts ord st var =+ let alignment = (llvmWidthInBits (llvmOptsPlatform opts) $ getVarType var) `quot` 8 align = text ", align" <+> ppr alignment sThreaded | st = text " singlethread" | otherwise = empty derefType = pLower $ getVarType var- in text "load atomic" <+> ppr derefType <> comma <+> ppr var <> sThreaded+ in text "load atomic" <+> ppr derefType <> comma <+> ppVar opts var <> sThreaded <+> ppSyncOrdering ord <> align -ppStore :: LlvmVar -> LlvmVar -> SDoc-ppStore val dst- | isVecPtrVar dst = text "store" <+> ppr val <> comma <+> ppr dst <>+ppStore :: LlvmOpts -> LlvmVar -> LlvmVar -> SDoc+ppStore opts val dst+ | isVecPtrVar dst = text "store" <+> ppVar opts val <> comma <+> ppVar opts dst <> comma <+> text "align 1"- | otherwise = text "store" <+> ppr val <> comma <+> ppr dst+ | otherwise = text "store" <+> ppVar opts val <> comma <+> ppVar opts dst where isVecPtrVar :: LlvmVar -> Bool isVecPtrVar = isVector . pLower . getVarType -ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> SDoc-ppCast op from to+ppCast :: LlvmOpts -> LlvmCastOp -> LlvmVar -> LlvmType -> SDoc+ppCast opts op from to = ppr op- <+> ppr (getVarType from) <+> ppName from+ <+> ppr (getVarType from) <+> ppName opts from <+> text "to" <+> ppr to -ppMalloc :: LlvmType -> Int -> SDoc-ppMalloc tp amount =+ppMalloc :: LlvmOpts -> LlvmType -> Int -> SDoc+ppMalloc opts tp amount = let amount' = LMLitVar $ LMIntLit (toInteger amount) i32- in text "malloc" <+> ppr tp <> comma <+> ppr amount'+ in text "malloc" <+> ppr tp <> comma <+> ppVar opts amount' -ppAlloca :: LlvmType -> Int -> SDoc-ppAlloca tp amount =+ppAlloca :: LlvmOpts -> LlvmType -> Int -> SDoc+ppAlloca opts tp amount = let amount' = LMLitVar $ LMIntLit (toInteger amount) i32- in text "alloca" <+> ppr tp <> comma <+> ppr amount'+ in text "alloca" <+> ppr tp <> comma <+> ppVar opts amount' -ppGetElementPtr :: Bool -> LlvmVar -> [LlvmVar] -> SDoc-ppGetElementPtr inb ptr idx =- let indexes = comma <+> ppCommaJoin idx+ppGetElementPtr :: LlvmOpts -> Bool -> LlvmVar -> [LlvmVar] -> SDoc+ppGetElementPtr opts inb ptr idx =+ let indexes = comma <+> ppCommaJoin (map (ppVar opts) idx) inbound = if inb then text "inbounds" else empty derefType = pLower $ getVarType ptr- in text "getelementptr" <+> inbound <+> ppr derefType <> comma <+> ppr ptr+ in text "getelementptr" <+> inbound <+> ppr derefType <> comma <+> ppVar opts ptr <> indexes -ppReturn :: Maybe LlvmVar -> SDoc-ppReturn (Just var) = text "ret" <+> ppr var-ppReturn Nothing = text "ret" <+> ppr LMVoid+ppReturn :: LlvmOpts -> Maybe LlvmVar -> SDoc+ppReturn opts (Just var) = text "ret" <+> ppVar opts var+ppReturn _ Nothing = text "ret" <+> ppr LMVoid -ppBranch :: LlvmVar -> SDoc-ppBranch var = text "br" <+> ppr var+ppBranch :: LlvmOpts -> LlvmVar -> SDoc+ppBranch opts var = text "br" <+> ppVar opts var -ppBranchIf :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc-ppBranchIf cond trueT falseT- = text "br" <+> ppr cond <> comma <+> ppr trueT <> comma <+> ppr falseT+ppBranchIf :: LlvmOpts -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc+ppBranchIf opts cond trueT falseT+ = text "br" <+> ppVar opts cond <> comma <+> ppVar opts trueT <> comma <+> ppVar opts falseT -ppPhi :: LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc-ppPhi tp preds =- let ppPreds (val, label) = brackets $ ppName val <> comma <+> ppName label+ppPhi :: LlvmOpts -> LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc+ppPhi opts tp preds =+ let ppPreds (val, label) = brackets $ ppName opts val <> comma <+> ppName opts label in text "phi" <+> ppr tp <+> hsep (punctuate comma $ map ppPreds preds) -ppSwitch :: LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc-ppSwitch scrut dflt targets =- let ppTarget (val, lab) = ppr val <> comma <+> ppr lab+ppSwitch :: LlvmOpts -> LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc+ppSwitch opts scrut dflt targets =+ let ppTarget (val, lab) = ppVar opts val <> comma <+> ppVar opts lab ppTargets xs = brackets $ vcat (map ppTarget xs)- in text "switch" <+> ppr scrut <> comma <+> ppr dflt+ in text "switch" <+> ppVar opts scrut <> comma <+> ppVar opts dflt <+> ppTargets targets -ppAsm :: LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc-ppAsm asm constraints rty vars sideeffect alignstack =+ppAsm :: LlvmOpts -> LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc+ppAsm opts asm constraints rty vars sideeffect alignstack = let asm' = doubleQuotes $ ftext asm cons = doubleQuotes $ ftext constraints rty' = ppr rty- vars' = lparen <+> ppCommaJoin vars <+> rparen+ vars' = lparen <+> ppCommaJoin (map (ppVar opts) vars) <+> rparen side = if sideeffect then text "sideeffect" else empty align = if alignstack then text "alignstack" else empty in text "call" <+> rty' <+> text "asm" <+> side <+> align <+> asm' <> comma <+> cons <> vars' -ppExtract :: LlvmVar -> LlvmVar -> SDoc-ppExtract vec idx =+ppExtract :: LlvmOpts -> LlvmVar -> LlvmVar -> SDoc+ppExtract opts vec idx = text "extractelement"- <+> ppr (getVarType vec) <+> ppName vec <> comma- <+> ppr idx+ <+> ppr (getVarType vec) <+> ppName opts vec <> comma+ <+> ppVar opts idx -ppExtractV :: LlvmVar -> Int -> SDoc-ppExtractV struct idx =+ppExtractV :: LlvmOpts -> LlvmVar -> Int -> SDoc+ppExtractV opts struct idx = text "extractvalue"- <+> ppr (getVarType struct) <+> ppName struct <> comma+ <+> ppr (getVarType struct) <+> ppName opts struct <> comma <+> ppr idx -ppInsert :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc-ppInsert vec elt idx =+ppInsert :: LlvmOpts -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc+ppInsert opts vec elt idx = text "insertelement"- <+> ppr (getVarType vec) <+> ppName vec <> comma- <+> ppr (getVarType elt) <+> ppName elt <> comma- <+> ppr idx+ <+> ppr (getVarType vec) <+> ppName opts vec <> comma+ <+> ppr (getVarType elt) <+> ppName opts elt <> comma+ <+> ppVar opts idx -ppMetaStatement :: Platform -> [MetaAnnot] -> LlvmStatement -> SDoc-ppMetaStatement platform meta stmt =- ppLlvmStatement platform stmt <> ppMetaAnnots meta+ppMetaStatement :: LlvmOpts -> [MetaAnnot] -> LlvmStatement -> SDoc+ppMetaStatement opts meta stmt =+ ppLlvmStatement opts stmt <> ppMetaAnnots opts meta -ppMetaExpr :: Platform -> [MetaAnnot] -> LlvmExpression -> SDoc-ppMetaExpr platform meta expr =- ppLlvmExpression platform expr <> ppMetaAnnots meta+ppMetaAnnotExpr :: LlvmOpts -> [MetaAnnot] -> LlvmExpression -> SDoc+ppMetaAnnotExpr opts meta expr =+ ppLlvmExpression opts expr <> ppMetaAnnots opts meta -ppMetaAnnots :: [MetaAnnot] -> SDoc-ppMetaAnnots meta = hcat $ map ppMeta meta+ppMetaAnnots :: LlvmOpts -> [MetaAnnot] -> SDoc+ppMetaAnnots opts meta = hcat $ map ppMeta meta where ppMeta (MetaAnnot name e) = comma <+> exclamation <> ftext name <+> case e of MetaNode n -> ppr n- MetaStruct ms -> exclamation <> braces (ppCommaJoin ms)- other -> exclamation <> braces (ppr other) -- possible?+ MetaStruct ms -> exclamation <> braces (ppCommaJoin (map (ppMetaExpr opts) ms))+ other -> exclamation <> braces (ppMetaExpr opts other) -- possible?++-- | Return the variable name or value of the 'LlvmVar'+-- in Llvm IR textual representation (e.g. @\@x@, @%y@ or @42@).+ppName :: LlvmOpts -> LlvmVar -> SDoc+ppName opts v = case v of+ LMGlobalVar {} -> char '@' <> ppPlainName opts v+ LMLocalVar {} -> char '%' <> ppPlainName opts v+ LMNLocalVar {} -> char '%' <> ppPlainName opts v+ LMLitVar {} -> ppPlainName opts v++-- | Return the variable name or value of the 'LlvmVar'+-- in a plain textual representation (e.g. @x@, @y@ or @42@).+ppPlainName :: LlvmOpts -> LlvmVar -> SDoc+ppPlainName opts v = case v of+ (LMGlobalVar x _ _ _ _ _) -> ftext x+ (LMLocalVar x LMLabel ) -> text (show x)+ (LMLocalVar x _ ) -> text ('l' : show x)+ (LMNLocalVar x _ ) -> ftext x+ (LMLitVar x ) -> ppLit opts x++-- | Print a literal value. No type.+ppLit :: LlvmOpts -> LlvmLit -> SDoc+ppLit opts l = case l of+ (LMIntLit i (LMInt 32)) -> ppr (fromInteger i :: Int32)+ (LMIntLit i (LMInt 64)) -> ppr (fromInteger i :: Int64)+ (LMIntLit i _ ) -> ppr ((fromInteger i)::Int)+ (LMFloatLit r LMFloat ) -> ppFloat (llvmOptsPlatform opts) $ narrowFp r+ (LMFloatLit r LMDouble) -> ppDouble (llvmOptsPlatform opts) r+ f@(LMFloatLit _ _) -> pprPanic "ppLit" (text "Can't print this float literal: " <> ppTypeLit opts f)+ (LMVectorLit ls ) -> char '<' <+> ppCommaJoin (map (ppTypeLit opts) ls) <+> char '>'+ (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 )+ | llvmOptsFillUndefWithGarbage opts+ , Just lit <- garbageLit t -> ppLit opts lit+ | otherwise -> text "undef"++ppVar :: LlvmOpts -> LlvmVar -> SDoc+ppVar opts v = case v of+ LMLitVar x -> ppTypeLit opts x+ x -> ppr (getVarType x) <+> ppName opts x++ppTypeLit :: LlvmOpts -> LlvmLit -> SDoc+ppTypeLit opts l = case l of+ LMVectorLit {} -> ppLit opts l+ _ -> ppr (getLitType l) <+> ppLit opts l++ppStatic :: LlvmOpts -> LlvmStatic -> SDoc+ppStatic opts st = case st of+ LMComment s -> text "; " <> ftext s+ LMStaticLit l -> ppTypeLit opts l+ LMUninitType t -> ppr t <> text " undef"+ LMStaticStr s t -> ppr t <> text " c\"" <> ftext s <> text "\\00\""+ LMStaticArray d t -> ppr t <> text " [" <> ppCommaJoin (map (ppStatic opts) d) <> char ']'+ LMStaticStruc d t -> ppr t <> text "<{" <> ppCommaJoin (map (ppStatic opts) d) <> text "}>"+ LMStaticPointer v -> ppVar opts v+ LMTrunc v t -> ppr t <> text " trunc (" <> ppStatic opts v <> text " to " <> ppr t <> char ')'+ LMBitc v t -> ppr t <> text " bitcast (" <> ppStatic opts v <> text " to " <> ppr t <> char ')'+ LMPtoI v t -> ppr t <> text " ptrtoint (" <> ppStatic opts v <> text " to " <> ppr t <> char ')'+ LMAdd s1 s2 -> pprStaticArith opts s1 s2 (sLit "add") (sLit "fadd") "LMAdd"+ LMSub s1 s2 -> pprStaticArith opts s1 s2 (sLit "sub") (sLit "fsub") "LMSub"+++pprSpecialStatic :: LlvmOpts -> LlvmStatic -> SDoc+pprSpecialStatic opts stat = case stat of+ LMBitc v t -> ppr (pLower t)+ <> text ", bitcast ("+ <> ppStatic opts v <> text " to " <> ppr t+ <> char ')'+ LMStaticPointer x -> ppr (pLower $ getVarType x)+ <> comma <+> ppStatic opts stat+ _ -> ppStatic opts stat+++pprStaticArith :: LlvmOpts -> LlvmStatic -> LlvmStatic -> PtrString -> PtrString+ -> String -> SDoc+pprStaticArith opts s1 s2 int_op float_op op_name =+ let ty1 = getStatType s1+ op = if isFloat ty1 then float_op else int_op+ in if ty1 == getStatType s2+ then ppr ty1 <+> ptext op <+> lparen <> ppStatic opts s1 <> comma <> ppStatic opts s2 <> rparen+ else pprPanic "pprStaticArith" $+ text op_name <> text " with different types! s1: " <> ppStatic opts s1+ <> text", s2: " <> ppStatic opts s2 --------------------------------------------------------------------------------
compiler/GHC/Llvm/Types.hs view
@@ -12,7 +12,6 @@ import GHC.Prelude import Data.Char-import Data.Int import Numeric import GHC.Platform@@ -64,24 +63,26 @@ deriving (Eq) instance Outputable LlvmType where- ppr (LMInt size ) = char 'i' <> ppr size- ppr (LMFloat ) = text "float"- ppr (LMDouble ) = text "double"- ppr (LMFloat80 ) = text "x86_fp80"- ppr (LMFloat128 ) = text "fp128"- ppr (LMPointer x ) = ppr x <> char '*'- ppr (LMArray nr tp ) = char '[' <> ppr nr <> text " x " <> ppr tp <> char ']'- ppr (LMVector nr tp ) = char '<' <> ppr nr <> text " x " <> ppr tp <> char '>'- ppr (LMLabel ) = text "label"- ppr (LMVoid ) = text "void"- ppr (LMStruct tys ) = text "<{" <> ppCommaJoin tys <> text "}>"- ppr (LMStructU tys ) = text "{" <> ppCommaJoin tys <> text "}"- ppr (LMMetadata ) = text "metadata"-- ppr (LMFunction (LlvmFunctionDecl _ _ _ r varg p _))- = ppr r <+> lparen <> ppParams varg p <> rparen+ ppr = ppType - ppr (LMAlias (s,_)) = char '%' <> ftext s+ppType :: LlvmType -> SDoc+ppType t = case t of+ LMInt size -> char 'i' <> ppr size+ LMFloat -> text "float"+ LMDouble -> text "double"+ LMFloat80 -> text "x86_fp80"+ LMFloat128 -> text "fp128"+ LMPointer x -> ppr x <> char '*'+ LMArray nr tp -> char '[' <> ppr nr <> text " x " <> ppr tp <> char ']'+ LMVector nr tp -> char '<' <> ppr nr <> text " x " <> ppr tp <> char '>'+ LMLabel -> text "label"+ LMVoid -> text "void"+ LMStruct tys -> text "<{" <> ppCommaJoin tys <> text "}>"+ LMStructU tys -> text "{" <> ppCommaJoin tys <> text "}"+ LMMetadata -> text "metadata"+ LMAlias (s,_) -> char '%' <> ftext s+ LMFunction (LlvmFunctionDecl _ _ _ r varg p _)+ -> ppr r <+> lparen <> ppParams varg p <> rparen ppParams :: LlvmParameterListType -> [LlvmParameter] -> SDoc ppParams varg p@@ -115,11 +116,6 @@ | LMLitVar LlvmLit deriving (Eq) -instance Outputable LlvmVar where- ppr (LMLitVar x) = ppr x- ppr (x ) = ppr (getVarType x) <+> ppName x-- -- | Llvm Literal Data. -- -- These can be used inline in expressions.@@ -136,11 +132,6 @@ | LMUndefLit LlvmType deriving (Eq) -instance Outputable LlvmLit where- ppr l@(LMVectorLit {}) = ppLit l- ppr l = ppr (getLitType l) <+> ppLit l-- -- | Llvm Static Data. -- -- These represent the possible global level variables and constants.@@ -162,89 +153,24 @@ | LMAdd LlvmStatic LlvmStatic -- ^ Constant addition operation | LMSub LlvmStatic LlvmStatic -- ^ Constant subtraction operation -instance Outputable LlvmStatic where- ppr (LMComment s) = text "; " <> ftext s- ppr (LMStaticLit l ) = ppr l- ppr (LMUninitType t) = ppr t <> text " undef"- ppr (LMStaticStr s t) = ppr t <> text " c\"" <> ftext s <> text "\\00\""- ppr (LMStaticArray d t) = ppr t <> text " [" <> ppCommaJoin d <> char ']'- ppr (LMStaticStruc d t) = ppr t <> text "<{" <> ppCommaJoin d <> text "}>"- ppr (LMStaticPointer v) = ppr v- ppr (LMTrunc v t)- = ppr t <> text " trunc (" <> ppr v <> text " to " <> ppr t <> char ')'- ppr (LMBitc v t)- = ppr t <> text " bitcast (" <> ppr v <> text " to " <> ppr t <> char ')'- ppr (LMPtoI v t)- = ppr t <> text " ptrtoint (" <> ppr v <> text " to " <> ppr t <> char ')'-- ppr (LMAdd s1 s2)- = pprStaticArith s1 s2 (sLit "add") (sLit "fadd") "LMAdd"- ppr (LMSub s1 s2)- = pprStaticArith s1 s2 (sLit "sub") (sLit "fsub") "LMSub"---pprSpecialStatic :: LlvmStatic -> SDoc-pprSpecialStatic (LMBitc v t) =- ppr (pLower t) <> text ", bitcast (" <> ppr v <> text " to " <> ppr t- <> char ')'-pprSpecialStatic v@(LMStaticPointer x) = ppr (pLower $ getVarType x) <> comma <+> ppr v-pprSpecialStatic stat = ppr stat---pprStaticArith :: LlvmStatic -> LlvmStatic -> PtrString -> PtrString- -> String -> SDoc-pprStaticArith s1 s2 int_op float_op op_name =- let ty1 = getStatType s1- op = if isFloat ty1 then float_op else int_op- in if ty1 == getStatType s2- then ppr ty1 <+> ptext op <+> lparen <> ppr s1 <> comma <> ppr s2 <> rparen- else pprPanic "pprStaticArith" $- text op_name <> text " with different types! s1: " <> ppr s1- <> text", s2: " <> ppr s2- -- ----------------------------------------------------------------------------- -- ** Operations on LLVM Basic Types and Variables -- --- | Return the variable name or value of the 'LlvmVar'--- in Llvm IR textual representation (e.g. @\@x@, @%y@ or @42@).-ppName :: LlvmVar -> SDoc-ppName v@(LMGlobalVar {}) = char '@' <> ppPlainName v-ppName v@(LMLocalVar {}) = char '%' <> ppPlainName v-ppName v@(LMNLocalVar {}) = char '%' <> ppPlainName v-ppName v@(LMLitVar {}) = ppPlainName v---- | Return the variable name or value of the 'LlvmVar'--- in a plain textual representation (e.g. @x@, @y@ or @42@).-ppPlainName :: LlvmVar -> SDoc-ppPlainName (LMGlobalVar x _ _ _ _ _) = ftext x-ppPlainName (LMLocalVar x LMLabel ) = text (show x)-ppPlainName (LMLocalVar x _ ) = text ('l' : show x)-ppPlainName (LMNLocalVar x _ ) = ftext x-ppPlainName (LMLitVar x ) = ppLit x+-- | LLVM code generator options+data LlvmOpts = LlvmOpts+ { llvmOptsPlatform :: !Platform -- ^ Target platform+ , llvmOptsFillUndefWithGarbage :: !Bool -- ^ Fill undefined literals with garbage values+ , llvmOptsSplitSections :: !Bool -- ^ Split sections+ } --- | Print a literal value. No type.-ppLit :: LlvmLit -> SDoc-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"+-- | Get LlvmOptions from DynFlags+initLlvmOpts :: DynFlags -> LlvmOpts+initLlvmOpts dflags = LlvmOpts+ { llvmOptsPlatform = targetPlatform dflags+ , llvmOptsFillUndefWithGarbage = gopt Opt_LlvmFillUndefWithGarbage dflags+ , llvmOptsSplitSections = gopt Opt_SplitSections dflags+ } garbageLit :: LlvmType -> Maybe LlvmLit garbageLit t@(LMInt w) = Just (LMIntLit (0xbbbbbbbbbbbbbbb0 `mod` (2^w)) t)
compiler/GHC/Plugins.hs view
@@ -126,7 +126,7 @@ import qualified Language.Haskell.TH as TH -{- This instance is defined outside GHC.Core.Opt.Monad.hs so that+{- This instance is defined outside GHC.Core.Opt.Monad so that GHC.Core.Opt.Monad does not depend on GHC.Tc.Utils.Env -} instance MonadThings CoreM where lookupThing name = do { hsc_env <- getHscEnv
compiler/GHC/Rename/Env.hs view
@@ -15,7 +15,7 @@ lookupLocalOccThLvl_maybe, lookupLocalOccRn, lookupTypeOccRn, lookupGlobalOccRn, lookupGlobalOccRn_maybe,- lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, lookupExactOcc,+ lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, ChildLookupResult(..), lookupSubBndrOcc_helper,@@ -33,6 +33,10 @@ lookupSyntax, lookupSyntaxExpr, lookupSyntaxName, lookupSyntaxNames, lookupIfThenElse, + -- QualifiedDo+ lookupQualifiedDoExpr, lookupQualifiedDo,+ lookupQualifiedDoName, lookupNameWithQualifier,+ -- Constructing usage information addUsedGRE, addUsedGREs, addUsedDataCons, @@ -167,7 +171,7 @@ ; unless (this_mod == nameModule name) (addErrAt loc (badOrigBinding rdr_name)) ; return name }- else -- See Note [Binders in Template Haskell] in Convert.hs+ else -- See Note [Binders in Template Haskell] in "GHC.ThToHs" do { this_mod <- getModule ; externaliseName this_mod name } @@ -237,16 +241,6 @@ -- Can be made to not be exposed -- Only used unwrapped in rnAnnProvenance lookupTopBndrRn :: RdrName -> RnM Name-lookupTopBndrRn n = do nopt <- lookupTopBndrRn_maybe n- case nopt of- Just n' -> return n'- Nothing -> do traceRn "lookupTopBndrRn fail" (ppr n)- unboundName WL_LocalTop n--lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name)-lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn--lookupTopBndrRn_maybe :: RdrName -> RnM (Maybe Name) -- Look up a top-level source-code binder. We may be looking up an unqualified 'f', -- and there may be several imported 'f's too, which must not confuse us. -- For example, this is OK:@@ -257,14 +251,8 @@ -- -- A separate function (importsFromLocalDecls) reports duplicate top level -- decls, so here it's safe just to choose an arbitrary one.------ There should never be a qualified name in a binding position in Haskell,--- but there can be if we have read in an external-Core file.--- The Haskell parser checks for the illegal qualified name in Haskell--- source files, so we don't need to do so here.--lookupTopBndrRn_maybe rdr_name =- lookupExactOrOrig rdr_name Just $+lookupTopBndrRn rdr_name =+ lookupExactOrOrig rdr_name id $ do { -- Check for operators in type or class declarations -- See Note [Type and class operator definitions] let occ = rdrNameOcc rdr_name@@ -274,25 +262,19 @@ ; env <- getGlobalRdrEnv ; case filter isLocalGRE (lookupGRE_RdrName rdr_name env) of- [gre] -> return (Just (gre_name gre))- _ -> return Nothing -- Ambiguous (can't happen) or unbound+ [gre] -> return (gre_name gre)+ _ -> do -- Ambiguous (can't happen) or unbound+ traceRn "lookupTopBndrRN fail" (ppr rdr_name)+ unboundName WL_LocalTop rdr_name } --------------------------------------------------- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames].--- This adds an error if the name cannot be found.-lookupExactOcc :: Name -> RnM Name-lookupExactOcc name- = do { result <- lookupExactOcc_either name- ; case result of- Left err -> do { addErr err- ; return name }- Right name' -> return name' }+lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name)+lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn -- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames].--- This never adds an error, but it may return one.+-- This never adds an error, but it may return one, see+-- Note [Errors in lookup functions] lookupExactOcc_either :: Name -> RnM (Either MsgDoc Name)--- See Note [Looking up Exact RdrNames] lookupExactOcc_either name | Just thing <- wiredInNameTyThing_maybe name , Just tycon <- case thing of@@ -333,16 +315,11 @@ ; th_topnames <- readTcRef th_topnames_var ; if name `elemNameSet` th_topnames then return (Right name)- else return (Left exact_nm_err)+ else return (Left (exactNameErr name)) } } gres -> return (Left (sameNameErr gres)) -- Ugh! See Note [Template Haskell ambiguity] }- where- exact_nm_err = hang (text "The exact Name" <+> quotes (ppr name) <+> ptext (sLit "is not in scope"))- 2 (vcat [ text "Probable cause: you used a unique Template Haskell name (NameU), "- , text "perhaps via newName, but did not bind it"- , text "If that's it, then -ddump-splices might be useful" ]) sameNameErr :: [GlobalRdrElt] -> MsgDoc sameNameErr [] = panic "addSameNameErr: empty list"@@ -429,16 +406,68 @@ -- In CPS style as `RnM r` is monadic+-- Reports an error if the name is an Exact or Orig and it can't find the name+-- Otherwise if it is not an Exact or Orig, returns k lookupExactOrOrig :: RdrName -> (Name -> r) -> RnM r -> RnM r lookupExactOrOrig rdr_name res k+ = do { men <- lookupExactOrOrig_base rdr_name+ ; case men of+ FoundExactOrOrig n -> return (res n)+ ExactOrOrigError e ->+ do { addErr e+ ; return (res (mkUnboundNameRdr rdr_name)) }+ NotExactOrOrig -> k }++-- Variant of 'lookupExactOrOrig' that does not report an error+-- See Note [Errors in lookup functions]+-- Calls k if the name is neither an Exact nor Orig+lookupExactOrOrig_maybe :: RdrName -> (Maybe Name -> r) -> RnM r -> RnM r+lookupExactOrOrig_maybe rdr_name res k+ = do { men <- lookupExactOrOrig_base rdr_name+ ; case men of+ FoundExactOrOrig n -> return (res (Just n))+ ExactOrOrigError _ -> return (res Nothing)+ NotExactOrOrig -> k }++data ExactOrOrigResult = FoundExactOrOrig Name -- ^ Found an Exact Or Orig Name+ | ExactOrOrigError MsgDoc -- ^ The RdrName was an Exact+ -- or Orig, but there was an+ -- error looking up the Name+ | NotExactOrOrig -- ^ The RdrName is neither an Exact nor+ -- Orig++-- Does the actual looking up an Exact or Orig name, see 'ExactOrOrigResult'+lookupExactOrOrig_base :: RdrName -> RnM ExactOrOrigResult+lookupExactOrOrig_base rdr_name | Just n <- isExact_maybe rdr_name -- This happens in derived code- = res <$> lookupExactOcc n+ = cvtEither <$> lookupExactOcc_either n | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name- = res <$> lookupOrig rdr_mod rdr_occ- | otherwise = k+ = FoundExactOrOrig <$> lookupOrig rdr_mod rdr_occ+ | otherwise = return NotExactOrOrig+ where+ cvtEither (Left e) = ExactOrOrigError e+ cvtEither (Right n) = FoundExactOrOrig n +{- Note [Errors in lookup functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Many of these lookup functions will attach an error if it can't find the Name it+is trying to lookup. However there are also _maybe and _either variants for many+of these functions. +These variants should *not* attach any errors, as there are+places where we want to attempt looking up a name, but it's not the end of the+world if we don't find it.++For example, see lookupThName_maybe: It calls lookupGlobalOccRn_maybe multiple+times for varying names in different namespaces. lookupGlobalOccRn_maybe should+therefore never attach an error, instead just return a Nothing.++For these _maybe/_either variant functions then, avoid calling further lookup+functions that can attach errors and instead call their _maybe/_either+counterparts.+-}+ ----------------------------------------------- -- | Look up an occurrence of a field in record construction or pattern -- matching (but not update). When the -XDisambiguateRecordFields@@ -789,15 +818,17 @@ Note [Looking up Exact RdrNames] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Exact RdrNames are generated by Template Haskell. See Note [Binders-in Template Haskell] in Convert.+Exact RdrNames are generated by: +* Template Haskell (See Note [Binders in Template Haskell] in GHC.ThToHs)+* Derived instances (See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate)+ For data types and classes have Exact system Names in the binding positions for constructors, TyCons etc. For example [d| data T = MkT Int |]-when we splice in and Convert to HsSyn RdrName, we'll get+when we splice in and convert to HsSyn RdrName, we'll get data (Exact (system Name "T")) = (Exact (system Name "MkT")) ...-These System names are generated by Convert.thRdrName+These System names are generated by GHC.ThToHs.thRdrName But, constructors and the like need External Names, not System Names! So we do the following@@ -920,7 +951,7 @@ Just name -> return name Nothing -> unboundName WL_LocalOnly rdr_name } --- lookupPromotedOccRn looks up an optionally promoted RdrName.+-- lookupTypeOccRn looks up an optionally promoted RdrName. lookupTypeOccRn :: RdrName -> RnM Name -- see Note [Demotion] lookupTypeOccRn rdr_name@@ -1034,30 +1065,39 @@ lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name) -- Looks up a RdrName occurrence in the top-level--- environment, including using lookupQualifiedNameGHCi--- for the GHCi case+-- environment, including using lookupQualifiedNameGHCi+-- for the GHCi case, but first tries to find an Exact or Orig name. -- No filter function; does not report an error on failure+-- See Note [Errors in lookup functions] -- Uses addUsedRdrName to record use and deprecations lookupGlobalOccRn_maybe rdr_name =- lookupExactOrOrig rdr_name Just $- runMaybeT . msum . map MaybeT $- [ fmap gre_name <$> lookupGreRn_maybe rdr_name- , listToMaybe <$> lookupQualifiedNameGHCi rdr_name ]- -- This test is not expensive,- -- and only happens for failed lookups+ lookupExactOrOrig_maybe rdr_name id (lookupGlobalOccRn_base rdr_name) lookupGlobalOccRn :: RdrName -> RnM Name -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global -- environment. Adds an error message if the RdrName is not in scope. -- You usually want to use "lookupOccRn" which also looks in the local -- environment.-lookupGlobalOccRn rdr_name- = do { mb_name <- lookupGlobalOccRn_maybe rdr_name- ; case mb_name of- Just n -> return n- Nothing -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name)- ; unboundName WL_Global rdr_name } }+lookupGlobalOccRn rdr_name =+ lookupExactOrOrig rdr_name id $ do+ mn <- lookupGlobalOccRn_base rdr_name+ case mn of+ Just n -> return n+ Nothing -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name)+ ; unboundName WL_Global rdr_name } +-- Looks up a RdrName occurence in the GlobalRdrEnv and with+-- lookupQualifiedNameGHCi. Does not try to find an Exact or Orig name first.+-- lookupQualifiedNameGHCi here is used when we're in GHCi and a name like+-- 'Data.Map.elems' is typed, even if you didn't import Data.Map+lookupGlobalOccRn_base :: RdrName -> RnM (Maybe Name)+lookupGlobalOccRn_base rdr_name =+ runMaybeT . msum . map MaybeT $+ [ fmap gre_name <$> lookupGreRn_maybe rdr_name+ , listToMaybe <$> lookupQualifiedNameGHCi rdr_name ]+ -- This test is not expensive,+ -- and only happens for failed lookups+ lookupInfoOccRn :: RdrName -> RnM [Name] -- lookupInfoOccRn is intended for use in GHCi's ":info" command -- It finds all the GREs that RdrName could mean, not complaining@@ -1086,7 +1126,7 @@ lookupGlobalOccRn_overloaded :: Bool -> RdrName -> RnM (Maybe (Either Name [Name])) lookupGlobalOccRn_overloaded overload_ok rdr_name =- lookupExactOrOrig rdr_name (Just . Left) $+ lookupExactOrOrig_maybe rdr_name (fmap Left) $ do { res <- lookupGreRn_helper rdr_name ; case res of GreNotFound -> return Nothing@@ -1347,7 +1387,7 @@ , is_ghci , gopt Opt_ImplicitImportQualified dflags -- Enables this GHCi behaviour , not (safeDirectImpsReq dflags) -- See Note [Safe Haskell and GHCi]- = do { res <- loadSrcInterface_maybe doc mod False Nothing+ = do { res <- loadSrcInterface_maybe doc mod NotBoot Nothing ; case res of Succeeded iface -> return [ name@@ -1686,6 +1726,49 @@ else do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names ; return (map (HsVar noExtField . noLoc) usr_names, mkFVs usr_names) } }++{-+Note [QualifiedDo]+~~~~~~~~~~~~~~~~~~+QualifiedDo is implemented using the same placeholders for operation names in+the AST that were devised for RebindableSyntax. Whenever the renamer checks+which names to use for do syntax, it first checks if the do block is qualified+(e.g. M.do { stmts }), in which case it searches for qualified names. If the+qualified names are not in scope, an error is produced. If the do block is not+qualified, the renamer does the usual search of the names which considers+whether RebindableSyntax is enabled or not. Dealing with QualifiedDo is driven+by the Opt_QualifiedDo dynamic flag.+-}++-- Lookup operations for a qualified do. If the context is not a qualified+-- do, then use lookupSyntaxExpr. See Note [QualifiedDo].+lookupQualifiedDoExpr :: HsStmtContext p -> Name -> RnM (HsExpr GhcRn, FreeVars)+lookupQualifiedDoExpr ctxt std_name+ = first nl_HsVar <$> lookupQualifiedDoName ctxt std_name++-- Like lookupQualifiedDoExpr but for producing SyntaxExpr.+-- See Note [QualifiedDo].+lookupQualifiedDo+ :: HsStmtContext p+ -> Name+ -> RnM (SyntaxExpr GhcRn, FreeVars)+lookupQualifiedDo ctxt std_name+ = first mkSyntaxExpr <$> lookupQualifiedDoExpr ctxt std_name++lookupNameWithQualifier :: Name -> ModuleName -> RnM (Name, FreeVars)+lookupNameWithQualifier std_name modName+ = do { qname <- lookupOccRn (mkRdrQual modName (nameOccName std_name))+ ; return (qname, unitFV qname) }++-- See Note [QualifiedDo].+lookupQualifiedDoName+ :: HsStmtContext p+ -> Name+ -> RnM (Name, FreeVars)+lookupQualifiedDoName ctxt std_name+ = case qualifiedDoModuleName_maybe ctxt of+ Nothing -> lookupSyntaxName std_name+ Just modName -> lookupNameWithQualifier std_name modName -- Error messages
compiler/GHC/Rename/Expr.hs view
@@ -54,6 +54,7 @@ import GHC.Types.Name.Reader import GHC.Types.Unique.Set import Data.List+import Data.Maybe (isJust, isNothing) import GHC.Utils.Misc import GHC.Data.List.SetOps ( removeDups ) import GHC.Utils.Error@@ -64,6 +65,7 @@ import GHC.Builtin.Types ( nilDataConName ) import qualified GHC.LanguageExtensions as LangExt +import Control.Arrow (first) import Data.Ord import Data.Array import qualified Data.List.NonEmpty as NE@@ -696,7 +698,7 @@ -- -XApplicativeDo is on. Also strip out the FreeVars attached -- to each Stmt body. ado_is_on <- xoptM LangExt.ApplicativeDo- ; let is_do_expr | DoExpr <- ctxt = True+ ; let is_do_expr | DoExpr{} <- ctxt = True | otherwise = False -- don't apply the transformation inside TH brackets, because -- GHC.HsToCore.Quote does not handle ApplicativeDo.@@ -732,12 +734,12 @@ ; (thing, fvs) <- thing_inside [] ; return (([], thing), fvs) } -rnStmtsWithFreeVars MDoExpr rnBody stmts thing_inside -- Deal with mdo+rnStmtsWithFreeVars mDoExpr@MDoExpr{} rnBody stmts thing_inside -- Deal with mdo = -- Behave like do { rec { ...all but last... }; last } do { ((stmts1, (stmts2, thing)), fvs)- <- rnStmt MDoExpr rnBody (noLoc $ mkRecStmt all_but_last) $ \ _ ->- do { last_stmt' <- checkLastStmt MDoExpr last_stmt- ; rnStmt MDoExpr rnBody last_stmt' thing_inside }+ <- rnStmt mDoExpr rnBody (noLoc $ mkRecStmt all_but_last) $ \ _ ->+ do { last_stmt' <- checkLastStmt mDoExpr last_stmt+ ; rnStmt mDoExpr rnBody last_stmt' thing_inside } ; return (((stmts1 ++ stmts2), thing), fvs) } where Just (all_but_last, last_stmt) = snocView stmts@@ -809,7 +811,7 @@ rnStmt ctxt rnBody (L loc (BodyStmt _ body _ _)) thing_inside = do { (body', fv_expr) <- rnBody body- ; (then_op, fvs1) <- lookupStmtName ctxt thenMName+ ; (then_op, fvs1) <- lookupQualifiedDoStmtName ctxt thenMName ; (guard_op, fvs2) <- if isComprehensionContext ctxt then lookupStmtName ctxt guardMName@@ -825,7 +827,7 @@ 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+ ; (bind_op, fvs1) <- lookupQualifiedDoStmtName ctxt bindMName ; (fail_op, fvs2) <- monadFailOp pat ctxt @@ -845,9 +847,9 @@ , fvs) } } rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside- = do { (return_op, fvs1) <- lookupStmtName ctxt returnMName- ; (mfix_op, fvs2) <- lookupStmtName ctxt mfixName- ; (bind_op, fvs3) <- lookupStmtName ctxt bindMName+ = do { (return_op, fvs1) <- lookupQualifiedDoStmtName ctxt returnMName+ ; (mfix_op, fvs2) <- lookupQualifiedDoStmtName ctxt mfixName+ ; (bind_op, fvs3) <- lookupQualifiedDoStmtName ctxt bindMName ; let empty_rec_stmt = emptyRecStmtName { recS_ret_fn = return_op , recS_mfix_fn = mfix_op , recS_bind_fn = bind_op }@@ -861,7 +863,7 @@ -- for which it's the fwd refs within the bind itself -- (This set may not be empty, because we're in a recursive -- context.)- ; rnRecStmtsAndThen rnBody rec_stmts $ \ segs -> do+ ; rnRecStmtsAndThen ctxt rnBody rec_stmts $ \ segs -> do { let bndrs = nameSetElemsStable $ foldr (unionNameSet . (\(ds,_,_,_) -> ds)) emptyNameSet@@ -955,6 +957,14 @@ dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:" <+> quotes (ppr (NE.head vs))) +lookupQualifiedDoStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)+-- Like lookupStmtName, but respects QualifiedDo+lookupQualifiedDoStmtName ctxt n+ = case qualifiedDoModuleName_maybe ctxt of+ Nothing -> lookupStmtName ctxt n+ Just modName ->+ first (mkSyntaxExpr . nl_HsVar) <$> lookupNameWithQualifier n modName+ lookupStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars) -- Like lookupSyntax, but respects contexts lookupStmtName ctxt n@@ -985,8 +995,8 @@ ArrowExpr -> False PatGuard {} -> False - DoExpr -> True- MDoExpr -> True+ DoExpr m -> isNothing m+ MDoExpr m -> isNothing m MonadComp -> True GhciStmtCtxt -> True -- I suppose? @@ -1031,7 +1041,8 @@ -- wrapper that does both the left- and right-hand sides rnRecStmtsAndThen :: Outputable (body GhcPs) =>- (Located (body GhcPs)+ HsStmtContext GhcRn+ -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -> [LStmt GhcPs (Located (body GhcPs))] -- assumes that the FreeVars returned includes@@ -1039,7 +1050,7 @@ -> ([Segment (LStmt GhcRn (Located (body GhcRn)))] -> RnM (a, FreeVars)) -> RnM (a, FreeVars)-rnRecStmtsAndThen rnBody s cont+rnRecStmtsAndThen ctxt rnBody s cont = do { -- (A) Make the mini fixity env for all of the stmts fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s) @@ -1055,7 +1066,7 @@ addLocalFixities fix_env bound_names $ do -- (C) do the right-hand-sides and thing-inside- { segs <- rn_rec_stmts rnBody bound_names new_lhs_and_fv+ { segs <- rn_rec_stmts ctxt rnBody bound_names new_lhs_and_fv ; (res, fvs) <- cont segs ; mapM_ (\(loc, ns) -> checkUnusedRecordWildcard loc fvs (Just ns)) rec_uses@@ -1135,30 +1146,31 @@ -- right-hand-sides rn_rec_stmt :: (Outputable (body GhcPs)) =>- (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+ HsStmtContext GhcRn+ -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -> [Name] -> (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars) -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))] -- Rename a Stmt that is inside a RecStmt (or mdo) -- Assumes all binders are already in scope -- Turns each stmt into a singleton Stmt-rn_rec_stmt rnBody _ (L loc (LastStmt _ body noret _), _)+rn_rec_stmt ctxt rnBody _ (L loc (LastStmt _ body noret _), _) = do { (body', fv_expr) <- rnBody body- ; (ret_op, fvs1) <- lookupSyntax returnMName+ ; (ret_op, fvs1) <- lookupQualifiedDo ctxt returnMName ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet, L loc (LastStmt noExtField body' noret ret_op))] } -rn_rec_stmt rnBody _ (L loc (BodyStmt _ body _ _), _)+rn_rec_stmt ctxt rnBody _ (L loc (BodyStmt _ body _ _), _) = do { (body', fvs) <- rnBody body- ; (then_op, fvs1) <- lookupSyntax thenMName+ ; (then_op, fvs1) <- lookupQualifiedDo ctxt thenMName ; 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 ctxt rnBody _ (L loc (BindStmt _ pat' body), fv_pat) = do { (body', fv_expr) <- rnBody body- ; (bind_op, fvs1) <- lookupSyntax bindMName+ ; (bind_op, fvs1) <- lookupQualifiedDo ctxt bindMName - ; (fail_op, fvs2) <- getMonadFailOp+ ; (fail_op, fvs2) <- getMonadFailOp ctxt ; let bndrs = mkNameSet (collectPatBinders pat') fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2@@ -1166,10 +1178,10 @@ ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs, L loc (BindStmt xbsrn pat' body'))] } -rn_rec_stmt _ _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))), _)+rn_rec_stmt _ _ _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))), _) = failWith (badIpBinds (text "an mdo expression") binds) -rn_rec_stmt _ all_bndrs (L loc (LetStmt _ (L l (HsValBinds x binds'))), _)+rn_rec_stmt _ _ all_bndrs (L loc (LetStmt _ (L l (HsValBinds x binds'))), _) = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds' -- fixities and unused are handled above in rnRecStmtsAndThen ; let fvs = allUses du_binds@@ -1177,28 +1189,29 @@ L loc (LetStmt noExtField (L l (HsValBinds x binds'))))] } -- no RecStmt case because they get flattened above when doing the LHSes-rn_rec_stmt _ _ stmt@(L _ (RecStmt {}), _)+rn_rec_stmt _ _ _ stmt@(L _ (RecStmt {}), _) = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt) -rn_rec_stmt _ _ stmt@(L _ (ParStmt {}), _) -- Syntactically illegal in mdo+rn_rec_stmt _ _ _ stmt@(L _ (ParStmt {}), _) -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt) -rn_rec_stmt _ _ stmt@(L _ (TransStmt {}), _) -- Syntactically illegal in mdo+rn_rec_stmt _ _ _ stmt@(L _ (TransStmt {}), _) -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt) -rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))), _)+rn_rec_stmt _ _ _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))), _) = panic "rn_rec_stmt: LetStmt EmptyLocalBinds" -rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _)+rn_rec_stmt _ _ _ stmt@(L _ (ApplicativeStmt {}), _) = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt) rn_rec_stmts :: Outputable (body GhcPs) =>- (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+ HsStmtContext GhcRn+ -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -> [Name] -> [(LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)] -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]-rn_rec_stmts rnBody bndrs stmts- = do { segs_s <- mapM (rn_rec_stmt rnBody bndrs) stmts+rn_rec_stmts ctxt rnBody bndrs stmts+ = do { segs_s <- mapM (rn_rec_stmt ctxt rnBody bndrs) stmts ; return (concat segs_s) } ---------------------------------------------@@ -1211,7 +1224,7 @@ | null segs = ([], fvs_later) - | MDoExpr <- ctxt+ | MDoExpr _ <- ctxt = segsToStmts empty_rec_stmt grouped_segs fvs_later -- Step 4: Turn the segments into Stmts -- Use RecStmt when and only when there are fwd refs@@ -1501,7 +1514,7 @@ -} -- | The 'Name's of @return@ and @pure@. These may not be 'returnName' and--- 'pureName' due to @RebindableSyntax@.+-- 'pureName' due to @QualifiedDo@ or @RebindableSyntax@. data MonadNames = MonadNames { return_name, pure_name :: Name } instance Outputable MonadNames where@@ -1528,8 +1541,8 @@ let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts | otherwise = mkStmtTreeHeuristic stmts traceRn "rearrangeForADo" (ppr stmt_tree)- (return_name, _) <- lookupSyntaxName returnMName- (pure_name, _) <- lookupSyntaxName pureAName+ (return_name, _) <- lookupQualifiedDoName ctxt returnMName+ (pure_name, _) <- lookupQualifiedDoName ctxt pureAName let monad_names = MonadNames { return_name = return_name , pure_name = pure_name } stmtTreeToStmts monad_names ctxt stmt_tree [last] last_fvs@@ -1726,7 +1739,7 @@ if | L _ ApplicativeStmt{} <- last stmts' -> return (unLoc tup, emptyNameSet) | otherwise -> do- (ret, _) <- lookupSyntaxExpr returnMName+ (ret, _) <- lookupQualifiedDoExpr ctxt returnMName let expr = HsApp noExtField (noLoc ret) tup return (expr, emptyFVs) return ( ApplicativeArgMany@@ -1734,6 +1747,7 @@ , app_stmts = stmts' , final_expr = mb_ret , bv_pattern = pat+ , stmt_context = ctxt } , fvs1 `plusFV` fvs2) @@ -1925,11 +1939,11 @@ -> [ExprLStmt GhcRn] -- ^ The body statements -> RnM ([ExprLStmt GhcRn], FreeVars) mkApplicativeStmt ctxt args need_join body_stmts- = do { (fmap_op, fvs1) <- lookupStmtName ctxt fmapName- ; (ap_op, fvs2) <- lookupStmtName ctxt apAName+ = do { (fmap_op, fvs1) <- lookupQualifiedDoStmtName ctxt fmapName+ ; (ap_op, fvs2) <- lookupQualifiedDoStmtName ctxt apAName ; (mb_join, fvs3) <- if need_join then- do { (join_op, fvs) <- lookupStmtName ctxt joinMName+ do { (join_op, fvs) <- lookupQualifiedDoStmtName ctxt joinMName ; return (Just join_op, fvs) } else return (Nothing, emptyNameSet)@@ -2003,8 +2017,8 @@ ListComp -> check_comp MonadComp -> check_comp ArrowExpr -> check_do- DoExpr -> check_do- MDoExpr -> check_do+ DoExpr{} -> check_do+ MDoExpr{} -> check_do _ -> check_other where check_do -- Expect BodyStmt, and change it to LastStmt@@ -2061,8 +2075,8 @@ = case ctxt of PatGuard {} -> okPatGuardStmt stmt ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt- DoExpr -> okDoStmt dflags ctxt stmt- MDoExpr -> okDoStmt dflags ctxt stmt+ DoExpr{} -> okDoStmt dflags ctxt stmt+ MDoExpr{} -> okDoStmt dflags ctxt stmt ArrowExpr -> okDoStmt dflags ctxt stmt GhciStmtCtxt -> okDoStmt dflags ctxt stmt ListComp -> okCompStmt dflags ctxt stmt@@ -2144,9 +2158,9 @@ -- For non-monadic contexts (e.g. guard patterns, list -- 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)+ | not (isMonadStmtContext ctxt) = return (Nothing, emptyFVs) - | otherwise = getMonadFailOp+ | otherwise = getMonadFailOp ctxt {- Note [Monad fail : Rebindable syntax, overloaded strings]@@ -2171,18 +2185,32 @@ (rather than plain 'fail') for the 'fail' operation. This is done in 'getMonadFailOp'.++Similarly with QualifiedDo and OverloadedStrings, we also want to desugar+using fromString:++ foo x = M.do { Just y <- x; return y }++ ===>++ foo x = x M.>>= \r -> case r of+ Just y -> return y+ Nothing -> M.fail (fromString "Pattern match error")+ -}-getMonadFailOp :: RnM (FailOperator GhcRn, FreeVars) -- Syntax expr fail op-getMonadFailOp+getMonadFailOp :: HsStmtContext p -> RnM (FailOperator GhcRn, FreeVars) -- Syntax expr fail op+getMonadFailOp ctxt = do { xOverloadedStrings <- fmap (xopt LangExt.OverloadedStrings) getDynFlags ; xRebindableSyntax <- fmap (xopt LangExt.RebindableSyntax) getDynFlags ; (fail, fvs) <- reallyGetMonadFailOp xRebindableSyntax xOverloadedStrings ; return (Just fail, fvs) } where+ isQualifiedDo = isJust (qualifiedDoModuleName_maybe ctxt)+ reallyGetMonadFailOp rebindableSyntax overloadedStrings- | rebindableSyntax && overloadedStrings = do- (failExpr, failFvs) <- lookupSyntaxExpr failMName+ | (isQualifiedDo || rebindableSyntax) && overloadedStrings = do+ (failExpr, failFvs) <- lookupQualifiedDoExpr ctxt failMName (fromStringExpr, fromStringFvs) <- lookupSyntaxExpr fromStringName let arg_lit = mkVarOcc "arg" arg_name <- newSysName arg_lit@@ -2195,4 +2223,4 @@ let failAfterFromStringSynExpr :: SyntaxExpr GhcRn = mkSyntaxExpr failAfterFromStringExpr return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs)- | otherwise = lookupSyntax failMName+ | otherwise = lookupQualifiedDo ctxt failMName
compiler/GHC/Rename/HsType.hs view
@@ -18,17 +18,20 @@ rnConDeclFields, rnLTyVar, + rnScaledLHsType,+ -- Precence related stuff mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn, checkPrecMatch, checkSectionPrec, -- Binding related stuff- bindLHsTyVarBndr, bindLHsTyVarBndrs, rnImplicitBndrs,- bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames,+ bindHsForAllTelescope,+ bindLHsTyVarBndr, bindLHsTyVarBndrs, WarnUnusedForalls(..),+ rnImplicitBndrs, bindSigTyVarsFV, bindHsQTyVars,+ FreeKiTyVars, extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,- extractHsTysRdrTyVarsDups,- extractRdrKindSigVars, extractDataDefnKindVars,- extractHsTvBndrs, extractHsTyArgRdrKiTyVarsDup,+ extractHsTysRdrTyVars, extractRdrKindSigVars, extractDataDefnKindVars,+ extractHsTvBndrs, extractHsTyArgRdrKiTyVars, forAllOrNothing, nubL ) where @@ -41,9 +44,10 @@ 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.Utils ( HsDocContext(..), inHsDocContext, withHsDocContext+ , mapFvRn, pprHsDocContext, bindLocalNamesFV+ , typeAppErr, newLocalBndrRn, checkDupRdrNames+ , checkShadowedRdrNames ) import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn , lookupTyFixityRn ) import GHC.Tc.Utils.Monad@@ -56,7 +60,6 @@ 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(..) )@@ -164,14 +167,14 @@ -> RnM (a, FreeVars) rn_hs_sig_wc_type scoping ctxt inf_err hs_ty thing_inside = do { check_inferred_vars ctxt inf_err hs_ty- ; free_vars <- filterInScopeM (extractHsTyRdrTyVarsDups hs_ty)+ ; free_vars <- filterInScopeM (extractHsTyRdrTyVars hs_ty) ; (nwc_rdrs', tv_rdrs) <- partition_nwcs free_vars ; let nwc_rdrs = nubL nwc_rdrs' ; implicit_bndrs <- case scoping of AlwaysBind -> pure tv_rdrs BindUnlessForall -> forAllOrNothing (isLHsForAllTy hs_ty) tv_rdrs NeverBind -> pure []- ; rnImplicitBndrs implicit_bndrs $ \ vars ->+ ; rnImplicitBndrs Nothing implicit_bndrs $ \ vars -> do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty ; (res, fvs2) <- thing_inside wcs vars hs_ty' ; return (res, fvs1 `plusFV` fvs2) } }@@ -179,7 +182,8 @@ rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars) rnHsWcType ctxt (HsWC { hswc_body = hs_ty }) = do { free_vars <- filterInScopeM (extractHsTyRdrTyVars hs_ty)- ; (nwc_rdrs, _) <- partition_nwcs free_vars+ ; (nwc_rdrs', _) <- partition_nwcs free_vars+ ; let nwc_rdrs = nubL nwc_rdrs' ; (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) }@@ -203,12 +207,11 @@ 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' ->+ rn_ty env (HsForAllTy { hst_tele = tele, hst_body = hs_body })+ = bindHsForAllTelescope (rtke_ctxt env) tele $ \ tele' -> do { (hs_body', fvs) <- rn_lty env hs_body- ; return (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField- , hst_bndrs = tvs', hst_body = hs_body' }+ ; return (HsForAllTy { hst_xforall = noExtField+ , hst_tele = tele', hst_body = hs_body' } , fvs) } rn_ty env (HsQualTy { hst_ctxt = L cx hs_ctxt@@ -275,7 +278,7 @@ TypeSigCtx {} -> True ExprWithTySigCtx {} -> True DerivDeclCtx {} -> True- StandaloneKindSigCtx {} -> False -- See Note [Wildcards in standalone kind signatures] in GHC/Hs/Decls+ StandaloneKindSigCtx {} -> False -- See Note [Wildcards in standalone kind signatures] in "GHC.Hs.Decls" _ -> False -- | When the NamedWildCards extension is enabled, partition_nwcs@@ -328,8 +331,8 @@ ; check_inferred_vars ctx inf_err hs_ty ; vars0 <- forAllOrNothing (isLHsForAllTy hs_ty) $ filterInScope rdr_env- $ extractHsTyRdrTyVarsDups hs_ty- ; rnImplicitBndrs vars0 $ \ vars ->+ $ extractHsTyRdrTyVars hs_ty+ ; rnImplicitBndrs Nothing vars0 $ \ vars -> do { (body', fvs) <- rnLHsTyKi (mkTyKiEnv ctx level RnTypeBody) hs_ty ; return ( HsIB { hsib_ext = vars@@ -357,9 +360,9 @@ -- we do not want to bring 'b' into scope, hence True -- But f :: a -> b -- we want to bring both 'a' and 'b' into scope, hence False- -> FreeKiTyVarsWithDups+ -> FreeKiTyVars -- ^ Free vars of the type- -> RnM FreeKiTyVarsWithDups+ -> RnM FreeKiTyVars forAllOrNothing has_outer_forall fvs = case has_outer_forall of True -> do traceRn "forAllOrNothing" $ text "has explicit outer forall"@@ -368,24 +371,50 @@ traceRn "forAllOrNothing" $ text "no explicit forall. implicit binders:" <+> ppr fvs pure fvs -rnImplicitBndrs :: FreeKiTyVarsWithDups+rnImplicitBndrs :: Maybe assoc+ -- ^ @'Just' _@ => an associated type decl+ -> FreeKiTyVars -- ^ Surface-syntax free vars that we will implicitly bind.- -- May have duplicates, which is checked here+ -- May have duplicates, which are removed here. -> ([Name] -> RnM (a, FreeVars)) -> RnM (a, FreeVars)-rnImplicitBndrs implicit_vs_with_dups- thing_inside+rnImplicitBndrs mb_assoc implicit_vs_with_dups thing_inside = do { let implicit_vs = nubL implicit_vs_with_dups ; traceRn "rnImplicitBndrs" $ vcat [ ppr implicit_vs_with_dups, ppr implicit_vs ] + -- Use the currently set SrcSpan as the new source location for each Name.+ -- See Note [Source locations for implicitly bound type variables]. ; loc <- getSrcSpanM- ; vars <- mapM (newLocalBndrRn . L loc . unLoc) implicit_vs+ ; vars <- mapM (newTyVarNameRn mb_assoc . L loc . unLoc) implicit_vs ; bindLocalNamesFV vars $ thing_inside vars } +{-+Note [Source locations for implicitly bound type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When bringing implicitly bound type variables into scope (in rnImplicitBndrs),+we do something peculiar: we drop the original SrcSpan attached to each+variable and replace it with the currently set SrcSpan. Moreover, this new+SrcSpan is usually /less/ precise than the original one, and that's OK. To see+why this is done, consider the following example:++ f :: a -> b -> a++Suppose that a warning or error message needs to point to the SrcSpans of the+binding sites for `a` and `b`. But where /are/ they bound, anyway? Technically,+they're bound by an unwritten `forall` at the front of the type signature, but+there is no SrcSpan for that. We could point to the first occurrence of `a` as+the binding site for `a`, but that would make the first occurrence of `a`+special. Moreover, we don't want IDEs to confuse binding sites and occurrences.++As a result, we make the `SrcSpan`s for `a` and `b` span the entirety of the+type signature, since the type signature implicitly carries their binding+sites. This is less precise, but more accurate.+-}+ check_inferred_vars :: HsDocContext -> Maybe SDoc -- ^ The error msg if the signature is not allowed to contain@@ -401,9 +430,10 @@ where forallty_bndrs :: LHsType GhcPs -> [HsTyVarBndr Specificity GhcPs] forallty_bndrs (L _ ty) = case ty of- HsParTy _ ty' -> forallty_bndrs ty'- HsForAllTy { hst_bndrs = tvs } -> map unLoc tvs- _ -> []+ HsParTy _ ty' -> forallty_bndrs ty'+ HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = tvs }}+ -> map unLoc tvs+ _ -> [] {- ****************************************************** * *@@ -484,6 +514,14 @@ rnLHsTypes :: HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars) rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys +rnScaledLHsType :: HsDocContext -> HsScaled GhcPs (LHsType GhcPs)+ -> RnM (HsScaled GhcRn (LHsType GhcRn), FreeVars)+rnScaledLHsType doc (HsScaled w ty) = do+ (w' , fvs_w) <- rnHsArrow (mkTyKiEnv doc TypeLevel RnTypeBody) w+ (ty', fvs) <- rnLHsType doc ty+ return (HsScaled w' ty', fvs `plusFV` fvs_w)++ rnHsType :: HsDocContext -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) rnHsType ctxt ty = rnHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty @@ -531,14 +569,12 @@ rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) -rnHsTyKi env ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tyvars- , hst_body = tau })+rnHsTyKi env ty@(HsForAllTy { hst_tele = tele, hst_body = tau }) = do { checkPolyKinds env ty- ; bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc ty)- Nothing tyvars $ \ tyvars' ->+ ; bindHsForAllTelescope (rtke_ctxt env) tele $ \ tele' -> do { (tau', fvs) <- rnLHsTyKi env tau- ; return ( HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField- , hst_bndrs = tyvars' , hst_body = tau' }+ ; return ( HsForAllTy { hst_xforall = noExtField+ , hst_tele = tele' , hst_body = tau' } , fvs) } } rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau })@@ -591,7 +627,7 @@ 2 (ppr ty)) ; return [] } -rnHsTyKi env (HsFunTy _ ty1 ty2)+rnHsTyKi env (HsFunTy _ mult 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@@ -599,8 +635,11 @@ -- 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) }+ ; (mult', w_fvs) <- rnHsArrow env mult+ ; res_ty <- mkHsOpTyRn (hs_fun_ty mult') funTyConName funTyFixity ty1' ty2'+ ; return (res_ty, fvs1 `plusFV` fvs2 `plusFV` w_fvs) }+ where+ hs_fun_ty w a b = HsFunTy noExtField w a b rnHsTyKi env listTy@(HsListTy _ ty) = do { data_kinds <- xoptM LangExt.DataKinds@@ -696,6 +735,12 @@ = do { checkAnonWildCard env ; return (HsWildCardTy noExtField, emptyFVs) } +rnHsArrow :: RnTyKiEnv -> HsArrow GhcPs -> RnM (HsArrow GhcRn, FreeVars)+rnHsArrow _env HsUnrestrictedArrow = return (HsUnrestrictedArrow, emptyFVs)+rnHsArrow _env HsLinearArrow = return (HsLinearArrow, emptyFVs)+rnHsArrow env (HsExplicitMult p)+ = (\(mult, fvs) -> (HsExplicitMult mult, fvs)) <$> rnLHsTyKi env p+ -------------- rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name rnTyVar env rdr_name@@ -784,7 +829,7 @@ FamPatCtx {} -> True -- Not named wildcards though GHCiCtx {} -> True HsTypeCtx {} -> True- StandaloneKindSigCtx {} -> False -- See Note [Wildcards in standalone kind signatures] in GHC/Hs/Decls+ StandaloneKindSigCtx {} -> False -- See Note [Wildcards in standalone kind signatures] in "GHC.Hs.Decls" _ -> False @@ -831,25 +876,12 @@ 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)+ -> FreeKiTyVars -- Kind variables from scope+ -> 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:@@ -863,18 +895,17 @@ -- 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+bindHsQTyVars doc mb_assoc body_kv_occs hsq_bndrs thing_inside+ = do { let bndr_kv_occs = extractHsTyVarBndrsKVs hs_tv_bndrs ; let -- See Note [bindHsQTyVars examples] for what -- all these various things are doing bndrs, implicit_kvs :: [Located RdrName] bndrs = map hsLTyVarLocName hs_tv_bndrs- implicit_kvs = nubL $ filterFreeVarsToBind bndrs $+ implicit_kvs = filterFreeVarsToBind bndrs $ bndr_kv_occs ++ body_kv_occs- del = deleteBys eqLocated- body_remaining = (body_kv_occs `del` bndrs) `del` bndr_kv_occs+ body_remaining = filterFreeVarsToBind bndr_kv_occs $+ filterFreeVarsToBind bndrs body_kv_occs all_bound_on_lhs = null body_remaining ; traceRn "checkMixedVars3" $@@ -885,15 +916,36 @@ , text "body_remaining" <+> ppr body_remaining ] - ; implicit_kv_nms <- mapM (newTyVarNameRn mb_assoc) implicit_kvs+ ; rnImplicitBndrs mb_assoc implicit_kvs $ \ implicit_kv_nms' ->+ bindLHsTyVarBndrs doc NoWarnUnusedForalls mb_assoc hs_tv_bndrs $ \ rn_bndrs ->+ -- This is the only call site for bindLHsTyVarBndrs where we pass+ -- NoWarnUnusedForalls, which suppresses -Wunused-foralls warnings.+ -- See Note [Suppress -Wunused-foralls when binding LHsQTyVars].+ do { let -- The SrcSpan that rnImplicitBndrs will attach to each Name will+ -- span the entire declaration to which the LHsQTyVars belongs,+ -- which will be reflected in warning and error messages. We can+ -- be a little more precise than that by pointing to the location+ -- of the LHsQTyVars instead, which is what bndrs_loc+ -- corresponds to.+ implicit_kv_nms = map (`setNameLoc` bndrs_loc) implicit_kv_nms' - ; 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)+ ; 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+ hs_tv_bndrs = hsQTvExplicit hsq_bndrs + -- The SrcSpan of the LHsQTyVars. For example, bndrs_loc would be the+ -- highlighted part in the class below:+ --+ -- class C (a :: j) (b :: k) where+ -- ^^^^^^^^^^^^^^^+ bndrs_loc = case map getLoc hs_tv_bndrs ++ map getLoc body_kv_occs of+ [] -> panic "bindHsQTyVars.bndrs_loc"+ [loc] -> loc+ (loc:locs) -> loc `combineSrcSpans` last locs+ {- Note [bindHsQTyVars examples] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have@@ -909,12 +961,12 @@ 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+ implicit_kvs = [k1,k2,k1], 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+* If body_kv_occs 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.@@ -922,6 +974,9 @@ * Order is not important in these lists. All we are doing is bring Names into scope. +* bndr_kv_occs, body_kv_occs, and implicit_kvs can contain duplicates. All+ duplicate occurrences are removed when we bind them with rnImplicitBndrs.+ Finally, you may wonder why filterFreeVarsToBind removes in-scope variables from bndr/body_kv_occs. How can anything be in scope? Answer: HsQTyVars is /also/ used (slightly oddly) for Haskell-98 syntax@@ -990,17 +1045,63 @@ So tvs is {k,a} and kvs is {k}. NB: we do this only at the binding site of 'tvs'.++Note [Suppress -Wunused-foralls when binding LHsQTyVars]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The WarnUnusedForalls flag controls whether bindLHsTyVarBndrs should warn about+explicit type variable binders that go unused (e.g., the `a` in+`forall a. Int`). We almost always want to warn about these, since unused type+variables can usually be deleted without any repercussions. There is one+exception to this rule, however: binding LHsQTyVars. Consider this example:++ data Proxy a = Proxy++The `a` in `Proxy a` is bound by an LHsQTyVars, and the code which brings it+into scope, bindHsQTyVars, will invoke bindLHsTyVarBndrs in turn. As such, it+has a choice to make about whether to emit -Wunused-foralls warnings or not.+If it /did/ emit warnings, then the `a` would be flagged as unused. However,+this is not what we want! Removing the `a` in `Proxy a` would change its kind+entirely, which is a huge price to pay for fixing a warning.++Unlike other forms of type variable binders, dropping "unused" variables in+an LHsQTyVars can be semantically significant. As a result, we suppress+-Wunused-foralls warnings in exactly one place: in bindHsQTyVars. -} +bindHsForAllTelescope :: HsDocContext+ -> HsForAllTelescope GhcPs+ -> (HsForAllTelescope GhcRn -> RnM (a, FreeVars))+ -> RnM (a, FreeVars)+bindHsForAllTelescope doc tele thing_inside =+ case tele of+ HsForAllVis { hsf_vis_bndrs = bndrs } ->+ bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs $ \bndrs' ->+ thing_inside $ mkHsForAllVisTele bndrs'+ HsForAllInvis { hsf_invis_bndrs = bndrs } ->+ bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs $ \bndrs' ->+ thing_inside $ mkHsForAllInvisTele bndrs'++-- | Should GHC warn if a quantified type variable goes unused? Usually, the+-- answer is \"yes\", but in the particular case of binding 'LHsQTyVars', we+-- avoid emitting warnings.+-- See @Note [Suppress -Wunused-foralls when binding LHsQTyVars]@.+data WarnUnusedForalls+ = WarnUnusedForalls+ | NoWarnUnusedForalls++instance Outputable WarnUnusedForalls where+ ppr wuf = text $ case wuf of+ WarnUnusedForalls -> "WarnUnusedForalls"+ NoWarnUnusedForalls -> "NoWarnUnusedForalls"+ bindLHsTyVarBndrs :: (OutputableBndrFlag flag) => HsDocContext- -> Maybe SDoc -- Just d => check for unused tvs- -- d is a phrase like "in the type ..."+ -> WarnUnusedForalls -> Maybe a -- Just _ => an associated type decl -> [LHsTyVarBndr flag GhcPs] -- User-written tyvars -> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars)) -> RnM (b, FreeVars)-bindLHsTyVarBndrs doc mb_in_doc mb_assoc tv_bndrs thing_inside+bindLHsTyVarBndrs doc wuf 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 }@@ -1014,9 +1115,9 @@ ; 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 ()+ warn_unused tv_bndr fvs = case wuf of+ WarnUnusedForalls -> warnUnusedForAll doc tv_bndr fvs+ NoWarnUnusedForalls -> return () bindLHsTyVarBndr :: HsDocContext -> Maybe a -- associated class@@ -1040,14 +1141,15 @@ $ thing_inside (L loc (KindedTyVar x fl (L lv tv_nm) kind')) ; return (b, fvs1 `plusFV` fvs2) } -newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name-newTyVarNameRn mb_assoc (L loc rdr)+newTyVarNameRn :: Maybe a -- associated class+ -> Located RdrName -> RnM Name+newTyVarNameRn mb_assoc lrdr@(L _ rdr) = do { rdr_env <- getLocalRdrEnv ; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of (Just _, Just n) -> return n -- Use the same Name as the parent class decl - _ -> newLocalBndrRn (L loc rdr) }+ _ -> newLocalBndrRn lrdr } {- ********************************************************* * *@@ -1126,9 +1228,11 @@ (\t1 t2 -> HsOpTy noExtField t1 op2 t2) (unLoc op2) fix2 ty21 ty22 loc2 } -mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy _ ty21 ty22))+mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy _ mult ty21 ty22)) = mk_hs_op_ty mk1 pp_op1 fix1 ty1- (HsFunTy noExtField) funTyConName funTyFixity ty21 ty22 loc2+ hs_fun_ty funTyConName funTyFixity ty21 ty22 loc2+ where+ hs_fun_ty a b = HsFunTy noExtField mult a b mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment = return (mk1 ty1 ty2)@@ -1456,16 +1560,14 @@ pp_what | isRnKindLevel env = text "kind" | otherwise = text "type" -inTypeDoc :: HsType GhcPs -> SDoc-inTypeDoc ty = text "In the type" <+> quotes (ppr ty)--warnUnusedForAll :: (OutputableBndrFlag flag) => SDoc -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM ()-warnUnusedForAll in_doc (L loc tv) used_names+warnUnusedForAll :: OutputableBndrFlag flag+ => HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM ()+warnUnusedForAll 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 ]+ , inHsDocContext doc ] opTyErr :: Outputable a => RdrName -> a -> SDoc opTyErr op overall_ty@@ -1504,7 +1606,10 @@ 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.+It is common for lists of free type variables to contain duplicates. For+example, in `f :: a -> a`, the free type variable list is [a, a]. When these+implicitly bound variables are brought into scope (with rnImplicitBndrs),+duplicates are removed with nubL. Note [Ordering of implicit variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1533,9 +1638,8 @@ 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.).+FreeKiTyVars, which notably includes the `extract-` family of functions+(extractHsTysRdrTyVars, extractHsTyVarBndrsKVs, etc.). These functions thus promise to keep left-to-right ordering. Note [Implicit quantification in type synonyms]@@ -1621,18 +1725,13 @@ -} +-- A list of free type/kind variables, which can contain duplicates. -- 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- -- | Filter out any type and kind variables that are already in scope in the -- the supplied LocalRdrEnv. Note that this includes named wildcards, which -- look like perfectly ordinary type variables at this point.@@ -1650,46 +1749,32 @@ inScope :: LocalRdrEnv -> RdrName -> Bool inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env -extract_tyarg :: LHsTypeArg GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups+extract_tyarg :: LHsTypeArg GhcPs -> FreeKiTyVars -> FreeKiTyVars 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 :: [LHsTypeArg GhcPs] -> FreeKiTyVars -> FreeKiTyVars extract_tyargs args acc = foldr extract_tyarg acc args -extractHsTyArgRdrKiTyVarsDup :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups-extractHsTyArgRdrKiTyVarsDup args+extractHsTyArgRdrKiTyVars :: [LHsTypeArg GhcPs] -> FreeKiTyVars+extractHsTyArgRdrKiTyVars 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 []+extractHsTyRdrTyVars :: LHsType GhcPs -> FreeKiTyVars+extractHsTyRdrTyVars 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.+-- 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 :: LHsType GhcPs -> FreeKiTyVars extractHsTyRdrTyVarsKindVars (L _ ty) = case ty of HsParTy _ ty -> extractHsTyRdrTyVarsKindVars ty@@ -1699,51 +1784,45 @@ -- | 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 []+extractHsTysRdrTyVars :: [LHsType GhcPs] -> FreeKiTyVars+extractHsTysRdrTyVars 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 flag GhcPs] -> FreeKiTyVarsNoDups-extractHsTyVarBndrsKVs tv_bndrs- = nubL (extract_hs_tv_bndrs_kvs tv_bndrs)+extractHsTyVarBndrsKVs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars+extractHsTyVarBndrsKVs tv_bndrs = 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 :: LFamilyResultSig GhcPs -> FreeKiTyVars extractRdrKindSigVars (L _ resultSig) = case resultSig of KindSig _ k -> extractHsTyRdrTyVars k TyVarSig _ (L _ (KindedTyVar _ _ _ k)) -> extractHsTyRdrTyVars k _ -> [] -- | Get type/kind variables mentioned in the kind signature, preserving--- left-to-right order and without duplicates:+-- left-to-right order: -- -- * 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 GhcPs -> FreeKiTyVars extractDataDefnKindVars (HsDataDefn { dd_kindSig = ksig }) = maybe [] extractHsTyRdrTyVars ksig -extract_lctxt :: LHsContext GhcPs- -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups+extract_lctxt :: LHsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars extract_lctxt ctxt = extract_ltys (unLoc ctxt) -extract_ltys :: [LHsType GhcPs]- -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups+extract_ltys :: [LHsType GhcPs] -> FreeKiTyVars -> FreeKiTyVars extract_ltys tys acc = foldr extract_lty acc tys -extract_lty :: LHsType GhcPs- -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups+extract_lty :: LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars extract_lty (L _ ty) acc = case ty of HsTyVar _ _ ltv -> extract_tv ltv acc@@ -1758,8 +1837,9 @@ 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+ HsFunTy _ w ty1 ty2 -> extract_lty ty1 $+ extract_lty ty2 $+ extract_hs_arrow w acc HsIParamTy _ _ ty -> extract_lty ty acc HsOpTy _ ty1 tv ty2 -> extract_tv tv $ extract_lty ty1 $@@ -1773,8 +1853,8 @@ 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 $+ HsForAllTy { hst_tele = tele, hst_body = ty }+ -> extract_hs_for_all_telescope tele acc $ extract_lty ty [] HsQualTy { hst_ctxt = ctxt, hst_body = ty } -> extract_lctxt ctxt $@@ -1783,16 +1863,32 @@ -- We deal with these separately in rnLHsTypeWithWildCards HsWildCardTy {} -> acc +extract_hs_arrow :: HsArrow GhcPs -> FreeKiTyVars ->+ FreeKiTyVars+extract_hs_arrow (HsExplicitMult p) acc = extract_lty p acc+extract_hs_arrow _ acc = acc++extract_hs_for_all_telescope :: HsForAllTelescope GhcPs+ -> FreeKiTyVars -- Accumulator+ -> FreeKiTyVars -- Free in body+ -> FreeKiTyVars+extract_hs_for_all_telescope tele acc_vars body_fvs =+ case tele of+ HsForAllVis { hsf_vis_bndrs = bndrs } ->+ extract_hs_tv_bndrs bndrs acc_vars body_fvs+ HsForAllInvis { hsf_invis_bndrs = bndrs } ->+ extract_hs_tv_bndrs bndrs acc_vars body_fvs+ extractHsTvBndrs :: [LHsTyVarBndr flag GhcPs]- -> FreeKiTyVarsWithDups -- Free in body- -> FreeKiTyVarsWithDups -- Free in result+ -> FreeKiTyVars -- Free in body+ -> FreeKiTyVars -- Free in result extractHsTvBndrs tv_bndrs body_fvs = extract_hs_tv_bndrs tv_bndrs [] body_fvs extract_hs_tv_bndrs :: [LHsTyVarBndr flag GhcPs]- -> FreeKiTyVarsWithDups -- Accumulator- -> FreeKiTyVarsWithDups -- Free in body- -> FreeKiTyVarsWithDups+ -> FreeKiTyVars -- Accumulator+ -> FreeKiTyVars -- Free in body+ -> FreeKiTyVars -- In (forall (a :: Maybe e). a -> b) we have -- 'a' is bound by the forall -- 'b' is a free type variable@@ -1807,25 +1903,29 @@ bndr_vars = extract_hs_tv_bndrs_kvs tv_bndrs tv_bndr_rdrs = map hsLTyVarLocName tv_bndrs -extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVarsWithDups+extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars -- 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 :: Located RdrName -> FreeKiTyVars -> FreeKiTyVars extract_tv tv acc = if isRdrTyVar (unLoc tv) then tv:acc else acc --- Deletes duplicates in a list of Located things.+-- Deletes duplicates in a list of Located things. This is used to: --+-- * Delete duplicate occurrences of implicitly bound type/kind variables when+-- bringing them into scope (in rnImplicitBndrs).+--+-- * Delete duplicate occurrences of named wildcards (in rn_hs_sig_wc_type and+-- rnHsWcType).+-- -- 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@@ -1838,9 +1938,9 @@ -- already in scope, or are explicitly bound in the binder. filterFreeVarsToBind :: FreeKiTyVars -- ^ Explicitly bound here- -> FreeKiTyVarsWithDups+ -> FreeKiTyVars -- ^ Potential implicit binders- -> FreeKiTyVarsWithDups+ -> FreeKiTyVars -- ^ Final implicit binders filterFreeVarsToBind bndrs = filterOut is_in_scope -- Make sure to list the binder kvs before the body kvs, as mandated by
compiler/GHC/Rename/Module.hs view
@@ -31,7 +31,7 @@ import GHC.Rename.Bind import GHC.Rename.Env import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, bindLocalNames- , checkDupRdrNames, inHsDocContext, bindLocalNamesFV+ , checkDupRdrNames, bindLocalNamesFV , checkShadowedRdrNames, warnUnusedTypePatterns , extendTyVarEnvFVRn, newLocalBndrsRn , withHsDocContext )@@ -65,6 +65,7 @@ import GHC.Data.Graph.Directed ( SCC, flattenSCC, flattenSCCs, Node(..) , stronglyConnCompFromEdgedVerticesUniq ) import GHC.Types.Unique.Set+import GHC.Data.Maybe ( whenIsJust ) import GHC.Data.OrdList import qualified GHC.LanguageExtensions as LangExt @@ -373,8 +374,8 @@ ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel Nothing ty -- Mark any PackageTarget style imports as coming from the current package- ; let unitId = thisPackage $ hsc_dflags topEnv- spec' = patchForeignImport unitId spec+ ; let unitId = homeUnit $ hsc_dflags topEnv+ spec' = patchForeignImport unitId spec ; return (ForeignImport { fd_i_ext = noExtField , fd_name = name', fd_sig_ty = ty'@@ -601,27 +602,43 @@ , 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 inf_err inst_ty+ = do { (inst_ty', inst_fvs) <- rnHsSigType ctxt TypeLevel inf_err 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 "<class>"))+ -- Check if there are any nested `forall`s or contexts, which are+ -- illegal in the type of an instance declaration (see+ -- Note [No nested foralls or contexts in instance types] in+ -- GHC.Hs.Type)...+ mb_nested_msg = no_nested_foralls_contexts_err+ (text "Instance head") head_ty'+ -- ...then check if the instance head is actually headed by a+ -- class type constructor...+ eith_cls = case hsTyGetAppHead_maybe head_ty' of+ Just (L _ cls) -> Right cls+ Nothing -> Left+ ( getLoc head_ty'+ , hang (text "Illegal head of an instance declaration:"+ <+> quotes (ppr head_ty'))+ 2 (vcat [ text "Instance heads must be of the form"+ , nest 2 $ text "C ty_1 ... ty_n"+ , text "where" <+> quotes (char 'C')+ <+> text "is a class"+ ])+ )+ -- ...finally, attempt to retrieve the class type constructor, failing+ -- with an error message if there isn't one. To avoid excessive+ -- amounts of error messages, we will only report one of the errors+ -- from mb_nested_msg or eith_cls at a time.+ ; cls <- case maybe eith_cls Left mb_nested_msg of+ Right cls -> pure cls+ Left (l, err_msg) -> 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 l $ withHsDocContext ctxt err_msg+ pure $ mkUnboundName (mkTcOccFS (fsLit "<class>")) -- Rename the bindings -- The typechecker (not the renamer) checks that all@@ -660,11 +677,12 @@ -- strange, but should not matter (and it would be more work -- to remove the context). where+ ctxt = GenericCtx $ text "an instance declaration" inf_err = Just (text "Inferred type variables are not allowed") rnFamInstEqn :: HsDocContext -> AssocTyFamInfo- -> [Located RdrName]+ -> FreeKiTyVars -- ^ Kind variables from the equation's RHS to be implicitly bound -- if no explicit forall. -> FamInstEqn GhcPs rhs@@ -676,16 +694,7 @@ , 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-- ; let bndrs = fromMaybe [] mb_bndrs+ = do { tycon' <- lookupFamInstName mb_cls tycon -- all_imp_vars represent the implicitly bound type variables. This is -- empty if we have an explicit `forall` (see@@ -713,48 +722,45 @@ -- No need to filter out explicit binders (the 'mb_bndrs = Just -- explicit_bndrs' case) because there must be none if we're going -- to implicitly bind anything, per the previous comment.- nubL $ pat_kity_vars_with_dups ++ rhs_kvars- ; all_imp_var_names <- mapM (newTyVarNameRn mb_cls) all_imp_vars+ pat_kity_vars_with_dups ++ rhs_kvars - -- 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+ ; rnImplicitBndrs mb_cls all_imp_vars $ \all_imp_var_names' ->+ bindLHsTyVarBndrs doc WarnUnusedForalls+ Nothing (fromMaybe [] mb_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+ -- Report unused binders on the LHS+ -- See Note [Unused type variables in family instances]+ ; let -- The SrcSpan that rnImplicitBndrs will attach to each Name will+ -- span the entire type family instance, which will be reflected in+ -- -Wunused-type-patterns warnings. We can be a little more precise+ -- than that by pointing to the LHS of the instance instead, which+ -- is what lhs_loc corresponds to.+ all_imp_var_names = map (`setNameLoc` lhs_loc) all_imp_var_names' - ; return ((bndrs', pats', payload'), rhs_fvs `plusFV` pat_fvs) }+ 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+ all_nms = all_imp_var_names ++ hsLTyVarNames bndrs'+ ; warnUnusedTypePatterns all_nms nms_used - ; let all_fvs = fvs `addOneFV` unLoc tycon'+ ; let all_fvs = (rhs_fvs `plusFV` pat_fvs) `addOneFV` unLoc tycon' -- type instance => use, hence addOneFV ; return (HsIB { hsib_ext = all_imp_var_names -- Note [Wildcards in family instances]@@ -765,8 +771,37 @@ , feqn_pats = pats' , feqn_fixity = fixity , feqn_rhs = payload' } },- all_fvs) }+ all_fvs) } }+ where+ -- The parent class, if we are dealing with an associated type family+ -- instance.+ mb_cls = case atfi of+ NonAssocTyFamEqn -> Nothing+ AssocTyFamDeflt cls -> Just cls+ AssocTyFamInst cls _ -> Just cls + -- The type variables from the instance head, if we are dealing with an+ -- associated type family instance.+ inst_tvs = case atfi of+ NonAssocTyFamEqn -> []+ AssocTyFamDeflt _ -> []+ AssocTyFamInst _ inst_tvs -> inst_tvs++ pat_kity_vars_with_dups = extractHsTyArgRdrKiTyVars pats+ -- It is crucial that extractHsTyArgRdrKiTyVars return+ -- duplicate occurrences, since they're needed to help+ -- determine unused binders on the LHS.++ -- The SrcSpan of the LHS of the instance. For example, lhs_loc would be+ -- the highlighted part in the example below:+ --+ -- type instance F a b c = Either a b+ -- ^^^^^+ lhs_loc = case map lhsTypeArgSrcSpan pats ++ map getLoc rhs_kvars of+ [] -> panic "rnFamInstEqn.lhs_loc"+ [loc] -> loc+ (loc:locs) -> loc `combineSrcSpans` last locs+ rnTyFamInstDecl :: AssocTyFamInfo -> TyFamInstDecl GhcPs -> RnM (TyFamInstDecl GhcRn, FreeVars)@@ -976,11 +1011,19 @@ = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving ; unless standalone_deriv_ok (addErr standaloneDerivErr) ; (mds', ty', fvs)- <- rnLDerivStrategy DerivDeclCtx mds $- rnHsSigWcType DerivDeclCtx inf_err ty+ <- rnLDerivStrategy ctxt mds $ rnHsSigWcType ctxt inf_err ty+ -- Check if there are any nested `forall`s or contexts, which are+ -- illegal in the type of an instance declaration (see+ -- Note [No nested foralls or contexts in instance types] in+ -- GHC.Hs.Type).+ ; whenIsJust (no_nested_foralls_contexts_err+ (text "Standalone-derived instance head")+ (getLHsInstDeclHead $ dropWildCards ty')) $ \(l, err_msg) ->+ addErrAt l $ withHsDocContext ctxt err_msg ; warnNoDerivStrat mds' loc ; return (DerivDecl noExtField ty' mds' overlap, fvs) } where+ ctxt = DerivDeclCtx inf_err = Just (text "Inferred type variables are not allowed") loc = getLoc $ hsib_body $ hswc_body ty @@ -1017,7 +1060,7 @@ ; checkShadowedRdrNames rdr_names_w_loc ; names <- newLocalBndrsRn rdr_names_w_loc ; let doc = RuleCtx (snd $ unLoc rule_name)- ; bindRuleTyVars doc in_rule tyvs $ \ tyvs' ->+ ; bindRuleTyVars doc tyvs $ \ tyvs' -> bindRuleTmVars doc tyvs' tmvs names $ \ tmvs' -> do { (lhs', fv_lhs') <- rnLExpr lhs ; (rhs', fv_rhs') <- rnLExpr rhs@@ -1033,7 +1076,6 @@ 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]@@ -1059,17 +1101,17 @@ bind_free_tvs = case tyvs of Nothing -> AlwaysBind Just _ -> NeverBind -bindRuleTyVars :: HsDocContext -> SDoc -> Maybe [LHsTyVarBndr () GhcPs]+bindRuleTyVars :: HsDocContext -> 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+bindRuleTyVars doc (Just bndrs) thing_inside+ = bindLHsTyVarBndrs doc WarnUnusedForalls 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+Check the shape of a rewrite rule LHS. Currently we only allow LHSs of the form @(f e1 .. en)@, where @f@ is not one of the @forall@'d variables. @@ -1581,7 +1623,7 @@ ; let kvs = extractHsTyRdrTyVarsKindVars rhs doc = TySynCtx tycon ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs)- ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' _ ->+ ; bindHsQTyVars doc Nothing kvs tyvars $ \ tyvars' _ -> do { (rhs', fvs) <- rnTySyn doc rhs ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars' , tcdFixity = fixity@@ -1597,7 +1639,7 @@ ; let kvs = extractDataDefnKindVars defn doc = TyDataCtx tycon ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs)- ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' no_rhs_kvs ->+ ; bindHsQTyVars doc 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@@ -1621,7 +1663,7 @@ -- Tyvars scope over superclass context and method signatures ; ((tyvars', context', fds', ats'), stuff_fvs)- <- bindHsQTyVars cls_doc Nothing Nothing kvs tyvars $ \ tyvars' _ -> do+ <- bindHsQTyVars cls_doc Nothing kvs tyvars $ \ tyvars' _ -> do -- Checks for distinct tyvars { (context', cxt_fvs) <- rnContext cls_doc context ; fds' <- rnFds fds@@ -1747,8 +1789,9 @@ } where h98_style = case condecls of -- Note [Stupid theta]- (L _ (ConDeclGADT {})) : _ -> False- _ -> True+ (L _ (ConDeclGADT {})) : _ -> False+ (L _ (XConDecl (ConDeclGADTPrefixPs {}))) : _ -> False+ _ -> True rn_derivs (L loc ds) = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies@@ -1788,14 +1831,26 @@ , deriv_clause_strategy = dcs , deriv_clause_tys = L loc' dct })) = do { (dcs', dct', fvs)- <- rnLDerivStrategy doc dcs $ mapFvRn (rnHsSigType doc TypeLevel inf_err) dct+ <- rnLDerivStrategy doc dcs $ mapFvRn rn_clause_pred dct ; warnNoDerivStrat dcs' loc ; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExtField , deriv_clause_strategy = dcs' , deriv_clause_tys = L loc' dct' }) , fvs ) } where- inf_err = Just (text "Inferred type variables are not allowed")+ rn_clause_pred :: LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars)+ rn_clause_pred pred_ty = do+ let inf_err = Just (text "Inferred type variables are not allowed")+ ret@(pred_ty', _) <- rnHsSigType doc TypeLevel inf_err pred_ty+ -- Check if there are any nested `forall`s, which are illegal in a+ -- `deriving` clause.+ -- See Note [No nested foralls or contexts in instance types]+ -- (Wrinkle: Derived instances) in GHC.Hs.Type.+ whenIsJust (no_nested_foralls_contexts_err+ (text "Derived class type")+ (getLHsInstDeclHead pred_ty')) $ \(l, err_msg) ->+ addErrAt l $ withHsDocContext doc err_msg+ pure ret rnLDerivStrategy :: forall a. HsDocContext@@ -1831,9 +1886,17 @@ do (via_ty', fvs1) <- rnHsSigType doc TypeLevel inf_err via_ty let HsIB { hsib_ext = via_imp_tvs , hsib_body = via_body } = via_ty'- (via_exp_tv_bndrs, _, _) = splitLHsSigmaTyInvis via_body- via_exp_tvs = hsLTyVarNames via_exp_tv_bndrs+ (via_exp_tv_bndrs, via_rho) = splitLHsForAllTyInvis_KP via_body+ via_exp_tvs = maybe [] hsLTyVarNames via_exp_tv_bndrs via_tvs = via_imp_tvs ++ via_exp_tvs+ -- Check if there are any nested `forall`s, which are illegal in a+ -- `via` type.+ -- See Note [No nested foralls or contexts in instance types]+ -- (Wrinkle: Derived instances) in GHC.Hs.Type.+ whenIsJust (no_nested_foralls_contexts_err+ (quotes (text "via") <+> text "type")+ via_rho) $ \(l, err_msg) ->+ addErrAt l $ withHsDocContext doc err_msg (thing, fvs2) <- extendTyVarEnvFVRn via_tvs thing_inside pure (ViaStrategy via_ty', thing, fvs1 `plusFV` fvs2) @@ -1878,7 +1941,7 @@ , fdInjectivityAnn = injectivity }) = do { tycon' <- lookupLocatedTopBndrRn tycon ; ((tyvars', res_sig', injectivity'), fv1) <-- bindHsQTyVars doc Nothing mb_cls kvs tyvars $ \ tyvars' _ ->+ bindHsQTyVars doc 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')@@ -2080,12 +2143,12 @@ -- scoping we get. So no implicit binders at the existential forall ; let ctxt = ConDeclCtx [new_name]- ; bindLHsTyVarBndrs ctxt (Just (inHsDocContext ctxt))+ ; bindLHsTyVarBndrs ctxt WarnUnusedForalls 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+ ; traceRn "rnConDecl (ConDeclH98)" (ppr name <+> vcat [ text "ex_tvs:" <+> ppr ex_tvs , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ]) @@ -2116,35 +2179,70 @@ -- See #14808. ; implicit_bndrs <- forAllOrNothing explicit_forall $ extractHsTvBndrs explicit_tkvs- $ extractHsTysRdrTyVarsDups (theta ++ arg_tys ++ [res_ty])+ $ extractHsTysRdrTyVars (theta ++ map hsScaledThing arg_tys ++ [res_ty]) - ; let ctxt = ConDeclCtx new_names- mb_ctxt = Just (inHsDocContext ctxt)+ ; let ctxt = ConDeclCtx new_names - ; rnImplicitBndrs implicit_bndrs $ \ implicit_tkvs ->- bindLHsTyVarBndrs ctxt mb_ctxt Nothing explicit_tkvs $ \ explicit_tkvs ->+ ; rnImplicitBndrs Nothing implicit_bndrs $ \ implicit_tkvs ->+ bindLHsTyVarBndrs ctxt WarnUnusedForalls+ 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) - ; traceRn "rnConDecl2" (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs)+ ; traceRn "rnConDecl (ConDeclGADT)"+ (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs) ; return (decl { con_g_ext = implicit_tkvs, con_names = new_names , con_qvars = explicit_tkvs, con_mb_cxt = new_cxt- , con_args = args', con_res_ty = res_ty'+ , con_args = new_args, con_res_ty = new_res_ty , con_doc = mb_doc' }, all_fvs) } } +-- This case is only used for prefix GADT constructors generated by GHC's+-- parser, where we do not know the argument types until type operator+-- precedence has been resolved. See Note [GADT abstract syntax] in+-- GHC.Hs.Decls for the full story.+rnConDecl (XConDecl (ConDeclGADTPrefixPs { con_gp_names = names, con_gp_ty = ty+ , con_gp_doc = mb_doc }))+ = do { mapM_ (addLocM checkConName) names+ ; new_names <- mapM lookupLocatedTopBndrRn names+ ; mb_doc' <- rnMbLHsDoc mb_doc + ; let ctxt = ConDeclCtx new_names+ ; (ty', fvs) <- rnHsSigType ctxt TypeLevel Nothing ty+ ; linearTypes <- xopt LangExt.LinearTypes <$> getDynFlags++ -- Now that operator precedence has been resolved, we can split the+ -- GADT type into its individual components below.+ ; let HsIB { hsib_ext = implicit_tkvs, hsib_body = body } = ty'+ (mb_explicit_tkvs, mb_cxt, tau) = splitLHsGADTPrefixTy body+ lhas_forall = L (getLoc body) $ isJust mb_explicit_tkvs+ explicit_tkvs = fromMaybe [] mb_explicit_tkvs+ (arg_tys, res_ty) = splitHsFunType tau+ arg_details | linearTypes = PrefixCon arg_tys+ | otherwise = PrefixCon $ map (hsLinear . hsScaledThing) arg_tys++ -- NB: The only possibility here is PrefixCon. RecCon is handled+ -- separately, through ConDeclGADT, from the parser onwards.++ -- Ensure that there are no nested `forall`s or contexts, per+ -- Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts)+ -- in GHC.Hs.Type.+ ; whenIsJust (no_nested_foralls_contexts_err+ (text "GADT constructor type signature")+ res_ty) $ \(l, err_msg) ->+ addErrAt l $ withHsDocContext ctxt err_msg++ ; traceRn "rnConDecl (ConDeclGADTPrefixPs)"+ (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs)+ ; pure (ConDeclGADT { con_g_ext = implicit_tkvs, con_names = new_names+ , con_forall = lhas_forall, con_qvars = explicit_tkvs+ , con_mb_cxt = mb_cxt, con_args = arg_details+ , con_res_ty = res_ty, con_doc = mb_doc' },+ fvs) }+ rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs) -> RnM (Maybe (LHsContext GhcRn), FreeVars) rnMbContext _ Nothing = return (Nothing, emptyFVs)@@ -2154,16 +2252,16 @@ rnConDeclDetails :: Name -> HsDocContext- -> HsConDetails (LHsType GhcPs) (Located [LConDeclField GhcPs])- -> RnM (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]),+ -> HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (Located [LConDeclField GhcPs])+ -> RnM ((HsConDetails (HsScaled GhcRn (LHsType GhcRn))) (Located [LConDeclField GhcRn]), FreeVars) rnConDeclDetails _ doc (PrefixCon tys)- = do { (new_tys, fvs) <- rnLHsTypes doc tys+ = do { (new_tys, fvs) <- mapFvRn (rnScaledLHsType 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+ = do { (new_ty1, fvs1) <- rnScaledLHsType doc ty1+ ; (new_ty2, fvs2) <- rnScaledLHsType doc ty2 ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) } rnConDeclDetails con doc (RecCon (L l fields))@@ -2172,6 +2270,41 @@ -- No need to check for duplicate fields -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn ; return (RecCon (L l new_fields), fvs) }++-- | Examines a non-outermost type for @forall@s or contexts, which are assumed+-- to be nested. Returns @'Just' err_msg@ if such a @forall@ or context is+-- found, and returns @Nothing@ otherwise.+--+-- This is currently used in two places:+--+-- * In GADT constructor types (in 'rnConDecl').+-- See @Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts)@+-- in "GHC.Hs.Type".+--+-- * In instance declaration types (in 'rnClsIntDecl' and 'rnSrcDerivDecl').+-- See @Note [No nested foralls or contexts in instance types]@ in+-- "GHC.Hs.Type".+no_nested_foralls_contexts_err :: SDoc -> LHsType GhcRn -> Maybe (SrcSpan, SDoc)+no_nested_foralls_contexts_err what lty =+ case ignoreParens lty of+ L l (HsForAllTy { hst_tele = tele })+ | HsForAllVis{} <- tele+ -- The only two places where this function is called correspond to+ -- types of terms, so we give a slightly more descriptive error+ -- message in the event that they contain visible dependent+ -- quantification (currently only allowed in kinds).+ -> Just (l, vcat [ text "Illegal visible, dependent quantification" <+>+ text "in the type of a term"+ , text "(GHC does not yet support this)" ])+ | HsForAllInvis{} <- tele+ -> Just (l, nested_foralls_contexts_err)+ L l (HsQualTy {})+ -> Just (l, nested_foralls_contexts_err)+ _ -> Nothing+ where+ nested_foralls_contexts_err =+ what <+> text "cannot contain nested"+ <+> quotes forAllLit <> text "s or contexts" -------------------------------------------------
compiler/GHC/Rename/Names.hs view
@@ -176,7 +176,7 @@ -- module to import from its implementor let this_mod = tcg_mod tcg_env let (source, ordinary) = partition is_source_import imports- is_source_import d = ideclSource (unLoc d)+ is_source_import d = ideclSource (unLoc d) == IsBoot stuff1 <- mapAndReportM (rnImportDecl this_mod) ordinary stuff2 <- mapAndReportM (rnImportDecl this_mod) source -- Safe Haskell: See Note [Tracking Trust Transitively]@@ -323,7 +323,7 @@ -- Compiler sanity check: if the import didn't say -- {-# SOURCE #-} we should not get a hi-boot file- WARN( not want_boot && mi_boot iface, ppr imp_mod_name ) do+ WARN( (want_boot == NotBoot) && (mi_boot iface == IsBoot), ppr imp_mod_name ) do -- Issue a user warning for a redundant {- SOURCE -} import -- NB that we arrange to read all the ordinary imports before@@ -334,7 +334,7 @@ -- the non-boot module depends on the compilation order, which -- is not deterministic. The hs-boot test can show this up. dflags <- getDynFlags- warnIf (want_boot && not (mi_boot iface) && isOneShot (ghcMode dflags))+ warnIf ((want_boot == IsBoot) && (mi_boot iface == NotBoot) && isOneShot (ghcMode dflags)) (warnRedundantSourceImport imp_mod_name) when (mod_safe && not (safeImportsOn dflags)) $ addErr (text "safe import can't be used as Safe Haskell isn't on!"@@ -448,7 +448,7 @@ ptrust = trust == Sf_Trustworthy || trust_pkg (dependent_mods, dependent_pkgs, pkg_trust_req)- | pkg == thisPackage dflags =+ | pkg == homeUnit dflags = -- Imported module is from the home package -- Take its dependent modules and add imp_mod itself -- Take its dependent packages unchanged@@ -460,7 +460,10 @@ -- know if any of them depended on CM.hi-boot, in -- which case we should do the hi-boot consistency -- check. See GHC.Iface.Load.loadHiBootInterface- ((moduleName imp_mod,want_boot):dep_mods deps,dep_pkgs deps,ptrust)+ ( GWIB { gwib_mod = moduleName imp_mod, gwib_isBoot = want_boot } : dep_mods deps+ , dep_pkgs deps+ , ptrust+ ) | otherwise = -- Imported module is from another package@@ -833,8 +836,8 @@ -- of an already renamer-resolved field and its use -- sites. This is needed to correctly support record -- selectors in Template Haskell. See Note [Binders in- -- Template Haskell] in Convert.hs and Note [Looking up- -- Exact RdrNames] in GHC.Rename.Env.+ -- Template Haskell] in "GHC.ThToHs" and Note [Looking up+ -- Exact RdrNames] in "GHC.Rename.Env". | otherwise = mkRdrUnqual (flSelector qualFieldLbl) {-@@ -1620,7 +1623,7 @@ ; this_mod <- getModule ; dflags <- getDynFlags ; liftIO $ withFile (mkFilename dflags this_mod) WriteMode $ \h ->- printForUser dflags h neverQualify (vcat (map ppr imports'))+ printForUser dflags h neverQualify AllTheWay (vcat (map ppr imports')) -- The neverQualify is important. We are printing Names -- but they are in the context of an 'import' decl, and -- we never qualify things inside there@@ -1698,20 +1701,23 @@ = hang (text "Illegal qualified name in import item:") 2 (ppr rdr) +pprImpDeclSpec :: ModIface -> ImpDeclSpec -> SDoc+pprImpDeclSpec iface decl_spec =+ quotes (ppr (is_mod decl_spec)) <+> case mi_boot iface of+ IsBoot -> text "(hi-boot interface)"+ NotBoot -> Outputable.empty+ badImportItemErrStd :: ModIface -> ImpDeclSpec -> IE GhcPs -> SDoc badImportItemErrStd iface decl_spec ie- = sep [text "Module", quotes (ppr (is_mod decl_spec)), source_import,+ = sep [text "Module", pprImpDeclSpec iface decl_spec, text "does not export", quotes (ppr ie)]- where- source_import | mi_boot iface = text "(hi-boot interface)"- | otherwise = Outputable.empty badImportItemErrDataCon :: OccName -> ModIface -> ImpDeclSpec -> IE GhcPs -> SDoc badImportItemErrDataCon dataType_occ iface decl_spec ie = vcat [ text "In module"- <+> quotes (ppr (is_mod decl_spec))- <+> source_import <> colon+ <+> pprImpDeclSpec iface decl_spec+ <> colon , nest 2 $ quotes datacon <+> text "is a data constructor of" <+> quotes dataType@@ -1728,8 +1734,6 @@ datacon_occ = rdrNameOcc $ ieName ie datacon = parenSymOcc datacon_occ (ppr datacon_occ) dataType = parenSymOcc dataType_occ (ppr dataType_occ)- source_import | mi_boot iface = text "(hi-boot interface)"- | otherwise = Outputable.empty parens_sp d = parens (space <> d <> space) -- T( f,g ) badImportItemErr :: ModIface -> ImpDeclSpec -> IE GhcPs -> [AvailInfo] -> SDoc
compiler/GHC/Rename/Splice.hs view
@@ -48,7 +48,7 @@ import GHC.Builtin.Names.TH ( quoteExpName, quotePatName, quoteDecName, quoteTypeName , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, ) -import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcCheckExpr )+import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcCheckPolyExpr ) import {-# SOURCE #-} GHC.Tc.Gen.Splice ( runMetaD , runMetaE@@ -324,7 +324,7 @@ ; meta_exp_ty <- tcMetaTy meta_ty_name ; zonked_q_expr <- zonkTopLExpr =<< tcTopSpliceExpr Untyped- (tcCheckExpr the_expr meta_exp_ty)+ (tcCheckPolyExpr the_expr meta_exp_ty) -- Run the expression ; mod_finalizers_ref <- newTcRef []@@ -867,7 +867,7 @@ foo = [d| op = 3 bop = op + 1 |] Here the bind_lvl of 'op' is (bogusly) outerLevel, even though it is-bound inside a bracket. That is because we don't even even record+bound inside a bracket. That is because we don't even record binding levels for top-level things; the binding levels are in the LocalRdrEnv.
compiler/GHC/Rename/Unbound.hs view
@@ -14,6 +14,7 @@ , unboundName , unboundNameX , notInScopeErr+ , exactNameErr ) where @@ -80,8 +81,10 @@ notInScopeErr :: RdrName -> SDoc notInScopeErr rdr_name- = hang (text "Not in scope:")- 2 (what <+> quotes (ppr rdr_name))+ = case isExact_maybe rdr_name of+ Just name -> exactNameErr name+ Nothing -> hang (text "Not in scope:")+ 2 (what <+> quotes (ppr rdr_name)) where what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) @@ -90,7 +93,7 @@ -- Right ispec => imported as specified by ispec --- | Called from the typechecker (GHC.Tc.Errors) 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@@ -385,3 +388,10 @@ and we have to check the current module in the last added entry of the HomePackageTable. (See test T15611b) -}++exactNameErr :: Name -> SDoc+exactNameErr name =+ hang (text "The exact Name" <+> quotes (ppr name) <+> ptext (sLit "is not in scope"))+ 2 (vcat [ text "Probable cause: you used a unique Template Haskell name (NameU), "+ , text "perhaps via newName, but did not bind it"+ , text "If that's it, then -ddump-splices might be useful" ])
compiler/GHC/Rename/Utils.hs view
@@ -71,7 +71,7 @@ newLocalBndrRn (L loc rdr_name) | Just name <- isExact_maybe rdr_name = return name -- This happens in code generated by Template Haskell- -- See Note [Binders in Template Haskell] in Convert.hs+ -- See Note [Binders in Template Haskell] in "GHC.ThToHs" | otherwise = do { unless (isUnqual rdr_name) (addErrAt loc (badQualBndrErr rdr_name))@@ -113,7 +113,7 @@ checkDupNames :: [Name] -> RnM () -- Check for duplicated names in a binding group checkDupNames names = check_dup_names (filterOut isSystemName names)- -- See Note [Binders in Template Haskell] in Convert+ -- See Note [Binders in Template Haskell] in "GHC.ThToHs" check_dup_names :: [Name] -> RnM () check_dup_names names@@ -128,7 +128,7 @@ ; checkShadowedOccs envs get_loc_occ filtered_rdrs } where filtered_rdrs = filterOut (isExact . unLoc) loc_rdr_names- -- See Note [Binders in Template Haskell] in Convert+ -- See Note [Binders in Template Haskell] in "GHC.ThToHs" get_loc_occ (L loc rdr) = (loc,rdrNameOcc rdr) checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM ()@@ -137,7 +137,7 @@ ; checkShadowedOccs envs get_loc_occ filtered_names } where filtered_names = filterOut isSystemName names- -- See Note [Binders in Template Haskell] in Convert+ -- See Note [Binders in Template Haskell] in "GHC.ThToHs" get_loc_occ name = (nameSrcSpan name, nameOccName name) -------------------------------------@@ -495,7 +495,7 @@ pprHsDocContext SpecInstSigCtx = text "a SPECIALISE instance pragma" pprHsDocContext DefaultDeclCtx = text "a `default' declaration" pprHsDocContext DerivDeclCtx = text "a deriving declaration"-pprHsDocContext (RuleCtx name) = text "the transformation rule" <+> ftext name+pprHsDocContext (RuleCtx name) = text "the rewrite rule" <+> doubleQuotes (ftext name) pprHsDocContext (TyDataCtx tycon) = text "the data type declaration for" <+> quotes (ppr tycon) pprHsDocContext (FamPatCtx tycon) = text "a type pattern of family instance for" <+> quotes (ppr tycon) pprHsDocContext (TySynCtx name) = text "the declaration for type synonym" <+> quotes (ppr name)
compiler/GHC/Runtime/Debugger.hs view
@@ -75,8 +75,8 @@ -- Do the obtainTerm--bindSuspensions-computeSubstitution dance go :: GhcMonad m => TCvSubst -> Id -> m (TCvSubst, Term) go subst id = do- let id_ty' = substTy subst (idType id)- id' = id `setIdType` id_ty'+ let id' = updateIdTypeAndMult (substTy subst) id+ id_ty' = idType id' term_ <- GHC.obtainTermFromId maxBound force id' term <- tidyTermTyVars term_ term' <- if bindThings@@ -183,7 +183,7 @@ showPpr dflags bname ++ ") :: Prelude.IO Prelude.String" dl = hsc_dynLinker hsc_env- _ <- GHC.setSessionDynFlags dflags{log_action=noop_log}+ GHC.setSessionDynFlags dflags{log_action=noop_log} txt_ <- withExtendedLinkEnv dl [(bname, fhv)] (GHC.compileExprRemote expr)
compiler/GHC/Runtime/Eval.hs view
@@ -118,11 +118,8 @@ import GHC.Tc.Utils.Zonk ( ZonkFlexi (SkolemiseFlexi) ) import GHC.Tc.Utils.Env (tcGetInstEnvs) import GHC.Tc.Utils.Instantiate (instDFunType)-import GHC.Tc.Solver (solveWanteds)+import GHC.Tc.Solver (simplifyWantedsTcM) import GHC.Tc.Utils.Monad-import GHC.Tc.Types.Evidence-import Data.Bifunctor (second)-import GHC.Tc.Solver.Monad (runTcS) import GHC.Core.Class (classTyCon) -- -----------------------------------------------------------------------------@@ -814,7 +811,7 @@ -- its full top-level scope available. moduleIsInterpreted :: GhcMonad m => Module -> m Bool moduleIsInterpreted modl = withSession $ \h ->- if moduleUnit modl /= thisPackage (hsc_dflags h)+ if not (isHomeModule (hsc_dflags h) modl) then return False else case lookupHpt (hsc_HPT h) (moduleName modl) of Just details -> return (isJust (mi_globals (hm_iface details)))@@ -1069,24 +1066,22 @@ return ty -- Get all the constraints required of a dictionary binding-getDictionaryBindings :: PredType -> TcM WantedConstraints+getDictionaryBindings :: PredType -> TcM CtEvidence getDictionaryBindings theta = do dictName <- newName (mkDictOcc (mkVarOcc "magic")) let dict_var = mkVanillaGlobal dictName theta loc <- getCtLocM (GivenOrigin UnkSkol) Nothing - -- Generate a wanted constraint here because at the end of constraint+ -- Generate a wanted here because at the end of constraint -- solving, most derived constraints get thrown away, which in certain -- cases, notably with quantified constraints makes it impossible to rule -- out instances as invalid. (See #18071)- let wCs = mkSimpleWC [CtWanted {+ return CtWanted { ctev_pred = varType dict_var, ctev_dest = EvVarDest dict_var, ctev_nosh = WDeriv, ctev_loc = loc- }]-- return wCs+ } -- Find instances where the head unifies with the provided type findMatchingInstances :: Type -> TcM [(ClsInst, [DFunInstType])]@@ -1100,7 +1095,7 @@ k -> Constraint where k is the type of the queried type. -} try_cls ies cls- | Just (arg_kind, res_kind) <- splitFunTy_maybe (tyConKind $ classTyCon cls)+ | Just (_, arg_kind, res_kind) <- splitFunTy_maybe (tyConKind $ classTyCon cls) , tcIsConstraintKind res_kind , Type.typeKind ty `eqType` arg_kind , (matches, _, _) <- lookupInstEnv True ies cls [ty]@@ -1142,17 +1137,18 @@ -- thetas of clsInst. (tys, thetas) <- instDFunType (is_dfun clsInst) mb_inst_tys wanteds <- mapM getDictionaryBindings thetas- (residuals, _) <- second evBindMapBinds <$> runTcS (solveWanteds (unionsWC wanteds))-- let WC { wc_simple = simples, wc_impl = impls } = (dropDerivedWC residuals)-- let resPreds = mapBag ctPred simples+ -- It's important to zonk constraints after solving in order to expose things like TypeErrors+ -- which otherwise appear as opaque type variables. (See #18262).+ WC { wc_simple = simples, wc_impl = impls } <- simplifyWantedsTcM wanteds - if allBag isSatisfiablePred resPreds && solvedImplics impls- then return . Just $ substInstArgs tys (bagToList resPreds) clsInst+ if allBag allowedSimple simples && solvedImplics impls+ then return . Just $ substInstArgs tys (bagToList (mapBag ctPred simples)) clsInst else return Nothing where+ allowedSimple :: Ct -> Bool+ allowedSimple ct = isSatisfiablePred (ctPred ct)+ solvedImplics :: Bag Implication -> Bool solvedImplics impls = allBag (isSolvedStatus . ic_status) impls
compiler/GHC/Runtime/Heap/Inspect.hs view
@@ -36,6 +36,7 @@ import GHC.Core.DataCon import GHC.Core.Type import GHC.Types.RepType+import GHC.Core.Multiplicity import qualified GHC.Core.Unify as U import GHC.Types.Var import GHC.Tc.Utils.Monad@@ -54,7 +55,6 @@ import GHC.Types.Var.Set import GHC.Types.Basic ( Boxity(..) ) import GHC.Builtin.Types.Prim-import GHC.Builtin.Names import GHC.Builtin.Types import GHC.Driver.Session import GHC.Utils.Outputable as Ppr@@ -65,21 +65,13 @@ import Control.Monad import Data.Maybe-import Data.List ((\\))-#if defined(INTEGER_GMP)-import GHC.Exts-import Data.Array.Base-import GHC.Integer.GMP.Internals-#elif defined(INTEGER_SIMPLE)+import Data.List import GHC.Exts-import GHC.Integer.Simple.Internals-#endif import qualified Data.Sequence as Seq import Data.Sequence (viewl, ViewL(..)) import Foreign import System.IO.Unsafe - --------------------------------------------- -- * A representation of semi evaluated Terms ---------------------------------------------@@ -329,11 +321,12 @@ . subTerms) , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2) ppr_list- , ifTerm' (isTyCon intTyCon . ty) ppr_int- , ifTerm' (isTyCon charTyCon . ty) ppr_char- , ifTerm' (isTyCon floatTyCon . ty) ppr_float- , ifTerm' (isTyCon doubleTyCon . ty) ppr_double- , ifTerm' (isIntegerTy . ty) ppr_integer+ , ifTerm' (isTyCon intTyCon . ty) ppr_int+ , ifTerm' (isTyCon charTyCon . ty) ppr_char+ , ifTerm' (isTyCon floatTyCon . ty) ppr_float+ , ifTerm' (isTyCon doubleTyCon . ty) ppr_double+ , ifTerm' (isTyCon integerTyCon . ty) ppr_integer+ , ifTerm' (isTyCon naturalTyCon . ty) ppr_natural ] where ifTerm :: (Term -> Bool)@@ -356,10 +349,6 @@ (tc,_) <- tcSplitTyConApp_maybe ty return (a_tc == tc) - isIntegerTy ty = fromMaybe False $ do- (tc,_) <- tcSplitTyConApp_maybe ty- return (tyConName tc == integerTyConName)- ppr_int, ppr_char, ppr_float, ppr_double :: Precedence -> Term -> m (Maybe SDoc) ppr_int _ Term{subTerms=[Prim{valRaw=[w]}]} =@@ -392,63 +381,53 @@ return (Just (Ppr.double f)) ppr_double _ _ = return Nothing - ppr_integer :: Precedence -> Term -> m (Maybe SDoc)-#if defined(INTEGER_GMP)- -- Reconstructing Integers is a bit of a pain. This depends deeply- -- on the integer-gmp representation, so it'll break if that- -- changes (but there are several tests in- -- tests/ghci.debugger/scripts that will tell us if this is wrong).- --- -- data Integer- -- = S# Int#- -- | Jp# {-# UNPACK #-} !BigNat- -- | Jn# {-# UNPACK #-} !BigNat- --- -- data BigNat = BN# ByteArray#- --- ppr_integer _ Term{subTerms=[Prim{valRaw=[W# w]}]} =- return (Just (Ppr.integer (S# (word2Int# w))))- ppr_integer _ Term{dc=Right con,- subTerms=[Term{subTerms=[Prim{valRaw=ws}]}]} = do- -- We don't need to worry about sizes that are not an integral- -- number of words, because luckily GMP uses arrays of words- -- (see GMP_LIMB_SHIFT).+ ppr_bignat :: Bool -> Precedence -> [Word] -> m (Maybe SDoc)+ ppr_bignat sign _ ws = do let- !(UArray _ _ _ arr#) = listArray (0,length ws-1) ws- constr- | "Jp#" <- getOccString (dataConName con) = Jp#- | otherwise = Jn#- return (Just (Ppr.integer (constr (BN# arr#))))-#elif defined(INTEGER_SIMPLE)- -- As with the GMP case, this depends deeply on the integer-simple- -- representation.+ wordSize = finiteBitSize (0 :: Word) -- does the word size depend on the target?+ makeInteger n _ [] = n+ makeInteger n s (x:xs) = makeInteger (n + (fromIntegral x `shiftL` s)) (s + wordSize) xs+ signf = case sign of+ False -> 1+ True -> -1+ return $ Just $ Ppr.integer $ signf * (makeInteger 0 0 ws)++ -- Reconstructing Bignums is a bit of a pain. This depends deeply on their+ -- representation, so it'll break if that changes (but there are several+ -- tests in tests/ghci.debugger/scripts that will tell us if this is wrong). --- -- @- -- data Integer = Positive !Digits | Negative !Digits | Naught+ -- data Integer+ -- = IS !Int#+ -- | IP !BigNat+ -- | IN !BigNat --- -- data Digits = Some !Word# !Digits- -- | None- -- @+ -- data Natural+ -- = NS !Word#+ -- | NB !BigNat --- -- NB: the above has some type synonyms expanded out for the sake of brevity- ppr_integer _ Term{subTerms=[]} =- return (Just (Ppr.integer Naught))- ppr_integer _ Term{dc=Right con, subTerms=[digitTerm]}- | Just digits <- get_digits digitTerm- = return (Just (Ppr.integer (constr digits)))- where- get_digits :: Term -> Maybe Digits- get_digits Term{subTerms=[]} = Just None- get_digits Term{subTerms=[Prim{valRaw=[W# w]},t]}- = Some w <$> get_digits t- get_digits _ = Nothing+ -- type BigNat = ByteArray# - constr- | "Positive" <- getOccString (dataConName con) = Positive- | otherwise = Negative-#endif+ ppr_integer :: Precedence -> Term -> m (Maybe SDoc)+ ppr_integer _ Term{dc=Right con, subTerms=[Prim{valRaw=ws}]}+ | con == integerISDataCon+ , [W# w] <- ws+ = return (Just (Ppr.integer (fromIntegral (I# (word2Int# w)))))+ ppr_integer p Term{dc=Right con, subTerms=[Term{subTerms=[Prim{valRaw=ws}]}]}+ | con == integerIPDataCon = ppr_bignat False p ws+ | con == integerINDataCon = ppr_bignat True p ws+ | otherwise = panic "Unexpected Integer constructor" ppr_integer _ _ = return Nothing + ppr_natural :: Precedence -> Term -> m (Maybe SDoc)+ ppr_natural _ Term{dc=Right con, subTerms=[Prim{valRaw=ws}]}+ | con == naturalNSDataCon+ , [w] <- ws+ = return (Just (Ppr.integer (fromIntegral w)))+ ppr_natural p Term{dc=Right con, subTerms=[Term{subTerms=[Prim{valRaw=ws}]}]}+ | con == naturalNBDataCon = ppr_bignat False p ws+ | otherwise = panic "Unexpected Natural constructor"+ ppr_natural _ _ = return Nothing+ --Note pprinting of list terms is not lazy ppr_list :: Precedence -> Term -> m SDoc ppr_list p (Term{subTerms=[h,t]}) = do@@ -760,9 +739,9 @@ traceTR (text "Following a MutVar") contents_tv <- newVar liftedTypeKind MASSERT(isUnliftedType my_ty)- (mutvar_ty,_) <- instScheme $ quantifyType $ mkVisFunTy+ (mutvar_ty,_) <- instScheme $ quantifyType $ mkVisFunTyMany contents_ty (mkTyConApp tycon [world,contents_ty])- addConstraint (mkVisFunTy contents_tv my_ty) mutvar_ty+ addConstraint (mkVisFunTyMany contents_tv my_ty) mutvar_ty x <- go (pred max_depth) contents_tv contents_ty contents return (RefWrap my_ty x) @@ -1055,7 +1034,7 @@ ; (subst, _) <- instTyVars (univ_tvs ++ ex_tvs) ; addConstraint rep_con_app_ty (substTy subst (dataConOrigResTy dc)) -- See Note [Constructor arg types]- ; let con_arg_tys = substTys subst (dataConRepArgTys dc)+ ; let con_arg_tys = substTys subst (map scaledThing $ dataConRepArgTys dc) ; traceTR (text "getDataConArgTys 2" <+> (ppr rep_con_app_ty $$ ppr con_arg_tys $$ ppr subst)) ; return con_arg_tys } where@@ -1263,11 +1242,12 @@ ppr tv, equals, ppr ty_v] go ty_v r -- FunTy inductive case- | Just (l1,l2) <- splitFunTy_maybe l- , Just (r1,r2) <- splitFunTy_maybe r+ | Just (w1,l1,l2) <- splitFunTy_maybe l+ , Just (w2,r1,r2) <- splitFunTy_maybe r+ , w1 `eqType` w2 = do r2' <- go l2 r2 r1' <- go l1 r1- return (mkVisFunTy r1' r2')+ return (mkVisFunTy w1 r1' r2') -- TyconApp Inductive case; this is the interesting bit. | Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs@@ -1332,7 +1312,7 @@ , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args , tyv `notElem` phantom_vars] = all isMonomorphicOnNonPhantomArgs concrete_args- | Just (ty1, ty2) <- splitFunTy_maybe ty+ | Just (_, ty1, ty2) <- splitFunTy_maybe ty = all isMonomorphicOnNonPhantomArgs [ty1,ty2] | otherwise = isMonomorphic ty
compiler/GHC/Runtime/Linker.hs view
@@ -48,7 +48,7 @@ import GHC.Types.Name.Env import GHC.Unit.Module import GHC.Data.List.SetOps-import GHC.Runtime.Linker.Types (DynLinker(..), LinkerUnitId, PersistentLinkerState(..))+import GHC.Runtime.Linker.Types (DynLinker(..), PersistentLinkerState(..)) import GHC.Driver.Session import GHC.Types.Basic import GHC.Utils.Outputable@@ -68,6 +68,7 @@ import qualified Data.Set as Set import Data.Char (isSpace)+import Data.Function ((&)) import Data.IORef import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition) import Data.Maybe@@ -142,7 +143,7 @@ -- -- The linker's symbol table is populated with RTS symbols using an -- explicit list. See rts/Linker.c for details.- where init_pkgs = map toUnitId [rtsUnitId]+ where init_pkgs = [rtsUnitId] extendLoadedPkgs :: DynLinker -> [UnitId] -> IO () extendLoadedPkgs dl pkgs =@@ -286,7 +287,7 @@ initObjLinker hsc_env -- (b) Load packages from the command-line (Note [preload packages])- pls <- linkPackages' hsc_env (preloadPackages (pkgState dflags)) pls0+ pls <- linkPackages' hsc_env (preloadUnits (unitState dflags)) pls0 -- steps (c), (d) and (e) linkCmdLineLibs' hsc_env pls@@ -654,7 +655,7 @@ ; return (lnks_needed, pkgs_needed) } where dflags = hsc_dflags hsc_env- this_pkg = thisPackage dflags+ this_pkg = homeUnit dflags -- The ModIface contains the transitive closure of the module dependencies -- within the current package, *except* for boot modules: if we encounter@@ -670,21 +671,23 @@ follow_deps (mod:mods) acc_mods acc_pkgs = do mb_iface <- initIfaceCheck (text "getLinkDeps") hsc_env $- loadInterface msg mod (ImportByUser False)+ loadInterface msg mod (ImportByUser NotBoot) iface <- case mb_iface of Maybes.Failed err -> throwGhcExceptionIO (ProgramError (showSDoc dflags err)) Maybes.Succeeded iface -> return iface - when (mi_boot iface) $ link_boot_mod_error mod+ when (mi_boot iface == IsBoot) $ link_boot_mod_error mod let pkg = moduleUnit mod deps = mi_deps iface pkg_deps = dep_pkgs deps- (boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps)- where is_boot (m,True) = Left m- is_boot (m,False) = Right m+ (boot_deps, mod_deps) = flip partitionWith (dep_mods deps) $+ \ (GWIB { gwib_mod = m, gwib_isBoot = is_boot }) ->+ m & case is_boot of+ IsBoot -> Left+ NotBoot -> Right boot_deps' = filter (not . (`elementOfUniqDSet` acc_mods)) boot_deps acc_mods' = addListToUniqDSet acc_mods (moduleName mod : mod_deps)@@ -951,7 +954,6 @@ -- the vanilla dynamic libraries, so we set the -- ways / build tag to be just WayDyn. ways = Set.singleton WayDyn,- buildTag = waysTag (Set.singleton WayDyn), outputFile = Just soFile } -- link all "loaded packages" so symbols in those can be resolved@@ -1224,7 +1226,7 @@ -- automatically, and it doesn't matter what order you specify the input -- packages. ---linkPackages :: HscEnv -> [LinkerUnitId] -> IO ()+linkPackages :: HscEnv -> [UnitId] -> IO () -- NOTE: in fact, since each module tracks all the packages it depends on, -- we don't really need to use the package-config dependencies. --@@ -1241,16 +1243,16 @@ modifyPLS_ dl $ \pls -> do linkPackages' hsc_env new_pkgs pls -linkPackages' :: HscEnv -> [LinkerUnitId] -> PersistentLinkerState+linkPackages' :: HscEnv -> [UnitId] -> PersistentLinkerState -> IO PersistentLinkerState linkPackages' hsc_env new_pks pls = do pkgs' <- link (pkgs_loaded pls) new_pks return $! pls { pkgs_loaded = pkgs' } where dflags = hsc_dflags hsc_env- pkgstate = pkgState dflags+ pkgstate = unitState dflags - link :: [LinkerUnitId] -> [LinkerUnitId] -> IO [LinkerUnitId]+ link :: [UnitId] -> [UnitId] -> IO [UnitId] link pkgs new_pkgs = foldM link_one pkgs new_pkgs @@ -1258,7 +1260,7 @@ | new_pkg `elem` pkgs -- Already linked = return pkgs - | Just pkg_cfg <- lookupInstalledPackage pkgstate new_pkg+ | Just pkg_cfg <- lookupUnitId pkgstate new_pkg = do { -- Link dependents first pkgs' <- link pkgs (unitDepends pkg_cfg) -- Now link the package itself@@ -1325,6 +1327,7 @@ ("Loading package " ++ unitPackageIdString pkg ++ " ... ") -- See comments with partOfGHCi+#if defined(CAN_LOAD_DLL) when (unitPackageName pkg `notElem` partOfGHCi) $ do loadFrameworks hsc_env platform pkg -- See Note [Crash early load_dyn and locateLib]@@ -1333,7 +1336,7 @@ -- For remaining `dlls` crash early only when there is surely -- no package's DLL around ... (not is_dyn) mapM_ (load_dyn hsc_env (not is_dyn) . mkSOName platform) dlls-+#endif -- After loading all the DLLs, we can load the static objects. -- Ordering isn't important here, because we do one final link -- step to resolve everything.@@ -1468,10 +1471,15 @@ -- O(n). Loading an import library is also O(n) so in general we prefer -- shared libraries because they are simpler and faster. --- = findDll user `orElse`+ =+#if defined(CAN_LOAD_DLL)+ findDll user `orElse`+#endif tryImpLib user `orElse`+#if defined(CAN_LOAD_DLL) findDll gcc `orElse` findSysDll `orElse`+#endif tryImpLib gcc `orElse` findArchive `orElse` tryGcc `orElse`@@ -1536,7 +1544,13 @@ full = dllpath $ search lib_so_name lib_dirs gcc name = liftM (fmap Archive) $ search name lib_dirs files = import_libs ++ arch_files- in apply $ short : full : map gcc files+ dlls = [short, full]+ archives = map gcc files+ in apply $+#if defined(CAN_LOAD_DLL)+ dlls +++#endif+ archives tryImpLib re = case os of OSMinGW32 -> let dirs' = if re == user then lib_dirs else gcc_dirs
compiler/GHC/Runtime/Loader.hs view
@@ -244,7 +244,7 @@ lookupRdrNameInModuleForPlugins :: HscEnv -> ModuleName -> RdrName -> IO (Maybe (Name, ModIface)) lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do- -- First find the package the module resides in by searching exposed packages and home modules+ -- First find the unit the module resides in by searching exposed units and home modules found_module <- findPluginModule hsc_env mod_name case found_module of Found _ mod -> do
compiler/GHC/Settings/IO.hs view
@@ -78,7 +78,6 @@ 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,@@ -149,19 +148,6 @@ 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"@@ -229,13 +215,10 @@ , 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_libFFI = useLibFFI , platformMisc_ghcThreaded = ghcThreaded , platformMisc_ghcDebugged = ghcDebugged
compiler/GHC/Stg/CSE.hs view
@@ -3,6 +3,7 @@ {-| Note [CSE for Stg] ~~~~~~~~~~~~~~~~~~+ This module implements a simple common subexpression elimination pass for STG. This is useful because there are expressions that we want to common up (because they are operationally equivalent), but that we cannot common up in Core, because@@ -16,6 +17,7 @@ Note [Case 1: CSEing allocated closures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+ The first kind of CSE opportunity we aim for is generated by this Haskell code: bar :: a -> (Either Int a, Either Bool a)@@ -43,6 +45,7 @@ Note [Case 2: CSEing case binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+ The second kind of CSE opportunity we aim for is more interesting, and came up in #9291 and #5344: The Haskell code @@ -70,6 +73,7 @@ Note [StgCse after unarisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+ Consider two unboxed sum terms: (# 1 | #) :: (# Int | Int# #)@@ -235,7 +239,7 @@ -- This is much simpler than the equivalent code in GHC.Core.Subst: -- * We do not substitute type variables, and--- * There is nothing relevant in IdInfo at this stage+-- * There is nothing relevant in GHC.Types.Id.Info at this stage -- that needs substitutions. -- Therefore, no special treatment for a recursive group is required.
compiler/GHC/Stg/Lift/Monad.hs view
@@ -34,11 +34,12 @@ import GHC.Data.OrdList import GHC.Stg.Subst import GHC.Stg.Syntax-import GHC.Core.Type+import GHC.Core.Utils import GHC.Types.Unique.Supply import GHC.Utils.Misc import GHC.Types.Var.Env import GHC.Types.Var.Set+import GHC.Core.Multiplicity import Control.Arrow ( second ) import Control.Monad.Trans.Class@@ -155,7 +156,7 @@ where (rec, pairs) = decomposeStgBinding bind --- | Flattens an expression in @['FloatLang']@ into an STG program, see #floats.+-- | Flattens an expression in @['FloatLang']@ into an STG program, see "GHC.Stg.Lift.Monad#floats". -- Important pre-conditions: The nesting of opening 'StartBindinGroup's and -- closing 'EndBindinGroup's is balanced. Also, it is crucial that every binding -- group has at least one recursive binding inside. Otherwise there's no point@@ -231,16 +232,16 @@ addTopStringLit :: OutId -> ByteString -> LiftM () addTopStringLit id = LiftM . RWS.tell . unitOL . PlainTopBinding . StgTopStringLit id --- | Starts a recursive binding group. See #floats# and 'collectFloats'.+-- | Starts a recursive binding group. See "GHC.Stg.Lift.Monad#floats" and 'collectFloats'. startBindingGroup :: LiftM () startBindingGroup = LiftM $ RWS.tell $ unitOL $ StartBindingGroup --- | Ends a recursive binding group. See #floats# and 'collectFloats'.+-- | Ends a recursive binding group. See "GHC.Stg.Lift.Monad#floats" and 'collectFloats'. endBindingGroup :: LiftM () endBindingGroup = LiftM $ RWS.tell $ unitOL $ EndBindingGroup -- | Lifts a binding to top-level. Depending on whether it's declared inside--- a recursive RHS (see #floats# and 'collectFloats'), this might be added to+-- a recursive RHS (see "GHC.Stg.Lift.Monad#floats" and 'collectFloats'), this might be added to -- an existing recursive top-level binding group. addLiftedBinding :: OutStgBinding -> LiftM () addLiftedBinding = LiftM . RWS.tell . unitOL . LiftedBinding@@ -274,7 +275,7 @@ -- See Note [transferPolyIdInfo] in GHC.Types.Id. We need to do this at least -- for arity information. = transferPolyIdInfo bndr (dVarSetElems abs_ids)- . mkSysLocal (mkFastString str) uniq+ . mkSysLocal (mkFastString str) uniq Many $ ty LiftM $ RWS.local (\e -> e@@ -288,7 +289,7 @@ withLiftedBndrs abs_ids = runContT . traverse (ContT . withLiftedBndr abs_ids) -- | Substitutes a binder /occurrence/, which was brought in scope earlier by--- 'withSubstBndr'\/'withLiftedBndr'.+-- 'withSubstBndr' \/ 'withLiftedBndr'. substOcc :: Id -> LiftM Id substOcc id = LiftM (RWS.asks (lookupIdSubst id . e_subst))
compiler/GHC/Stg/Unarise.hs view
@@ -192,7 +192,7 @@ * Binders always have zero (for void arguments) or one PrimRep. -} -{-# LANGUAGE CPP, TupleSections #-}+{-# LANGUAGE CPP, TupleSections, PatternSynonyms #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -215,7 +215,7 @@ import GHC.Types.RepType import GHC.Stg.Syntax import GHC.Core.Type-import GHC.Builtin.Types.Prim (intPrimTy,wordPrimTy,word64PrimTy)+import GHC.Builtin.Types.Prim (intPrimTy) import GHC.Builtin.Types import GHC.Types.Unique.Supply import GHC.Utils.Misc@@ -481,7 +481,7 @@ unariseSumAlt rho args (DataAlt sumCon, bs, e) = do let rho' = mapSumIdBinders bs args rho e' <- unariseExpr rho' e- return ( LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon)) intPrimTy), [], e' )+ return ( LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon))), [], e' ) unariseSumAlt _ scrt alt = pprPanic "unariseSumAlt" (ppr scrt $$ ppr alt)@@ -567,7 +567,7 @@ tag = dataConTag dc layout' = layoutUbxSum sum_slots (mapMaybe (typeSlotTy . stgArgType) args0)- tag_arg = StgLitArg (LitNumber LitNumInt (fromIntegral tag) intPrimTy)+ tag_arg = StgLitArg (LitNumber LitNumInt (fromIntegral tag)) arg_idxs = IM.fromList (zipEqual "mkUbxSum" layout' args0) mkTupArgs :: Int -> [SlotTy] -> IM.IntMap StgArg -> [StgArg]@@ -588,12 +588,12 @@ -- * Literals: 0 or 0.0 -- * Pointers: `ghc-prim:GHC.Prim.Panic.absentSumFieldError` ----- See Note [aBSENT_SUM_FIELD_ERROR_ID] in GHC.Core.Make+-- See Note [aBSENT_SUM_FIELD_ERROR_ID] in "GHC.Core.Make" -- ubxSumRubbishArg :: SlotTy -> StgArg ubxSumRubbishArg PtrSlot = StgVarArg aBSENT_SUM_FIELD_ERROR_ID-ubxSumRubbishArg WordSlot = StgLitArg (LitNumber LitNumWord 0 wordPrimTy)-ubxSumRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0 word64PrimTy)+ubxSumRubbishArg WordSlot = StgLitArg (LitNumber LitNumWord 0)+ubxSumRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0) ubxSumRubbishArg FloatSlot = StgLitArg (LitFloat 0) ubxSumRubbishArg DoubleSlot = StgLitArg (LitDouble 0) @@ -672,7 +672,7 @@ -- -- While not unarising the binder in this case does not break any programs -- (because it unarises to a single variable), it triggers StgLint as we- -- break the the post-unarisation invariant that says unboxed tuple/sum+ -- break the post-unarisation invariant that says unboxed tuple/sum -- binders should vanish. See Note [Post-unarisation invariants]. | isUnboxedSumType (idType x) || isUnboxedTupleType (idType x) -> do x' <- mkId (mkFastString "us") (primRepToType rep)@@ -740,7 +740,7 @@ mkIds fs tys = mapM (mkId fs) tys mkId :: FastString -> UnaryType -> UniqSM Id-mkId = mkSysLocalM+mkId s t = mkSysLocalM s Many t isMultiValBndr :: Id -> Bool isMultiValBndr id
compiler/GHC/StgToCmm.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- --@@ -25,6 +26,7 @@ import GHC.StgToCmm.Closure import GHC.StgToCmm.Hpc import GHC.StgToCmm.Ticky+import GHC.StgToCmm.Types (ModuleLFInfos) import GHC.Cmm import GHC.Cmm.Utils@@ -41,12 +43,15 @@ import GHC.Types.RepType import GHC.Core.DataCon import GHC.Core.TyCon+import GHC.Core.Multiplicity 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 GHC.Types.Unique.FM+import GHC.Types.Name.Env import GHC.Data.OrdList import GHC.Cmm.Graph@@ -63,7 +68,8 @@ -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. -> [CgStgTopBinding] -- Bindings to convert -> HpcInfo- -> Stream IO CmmGroup () -- Output as a stream, so codegen can+ -> Stream IO CmmGroup ModuleLFInfos+ -- Output as a stream, so codegen can -- be interleaved with output codeGen dflags this_mod data_tycons@@ -105,6 +111,23 @@ mapM_ (cg . cgDataCon) (tyConDataCons tycon) ; mapM_ do_tycon data_tycons++ ; cg_id_infos <- cgs_binds <$> liftIO (readIORef cgref)++ -- See Note [Conveying CAF-info and LFInfo between modules] in+ -- GHC.StgToCmm.Types+ ; let extractInfo info = (name, lf)+ where+ !name = idName (cg_id info)+ !lf = cg_lf info++ !generatedInfo+ | gopt Opt_OmitInterfacePragmas dflags+ = emptyNameEnv+ | otherwise+ = mkNameEnv (Prelude.map extractInfo (eltsUFM cg_id_infos))++ ; return generatedInfo } ---------------------------------------------------------------@@ -220,7 +243,7 @@ arg_reps :: [NonVoid PrimRep] arg_reps = [ NonVoid rep_ty | ty <- dataConRepArgTys data_con- , rep_ty <- typePrimRep ty+ , rep_ty <- typePrimRep (scaledThing ty) , not (isVoidRep rep_ty) ] ; emitClosureAndInfoTable dyn_info_tbl NativeDirectCall [] $
compiler/GHC/StgToCmm/Bind.hs view
@@ -82,7 +82,7 @@ -- shortcutting the whole process, and generating a lot less code -- (#7308). Eventually the IND_STATIC closure will be eliminated -- by assembly '.equiv' directives, where possible (#15155).- -- See note [emit-time elimination of static indirections] in CLabel.+ -- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". -- -- Note: we omit the optimisation when this binding is part of a -- recursive group, because the optimisation would inhibit the black@@ -206,7 +206,7 @@ -- con args are always non-void, -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise -{- See Note [GC recovery] in compiler/GHC.StgToCmm/Closure.hs -}+{- See Note [GC recovery] in "GHC.StgToCmm.Closure" -} cgRhs id (StgRhsClosure fvs cc upd_flag args body) = do dflags <- getDynFlags mkRhsClosure dflags id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body@@ -307,7 +307,7 @@ , all (isGcPtrRep . idPrimRep . fromNonVoid) fvs , isUpdatable upd_flag , n_fvs <= mAX_SPEC_AP_SIZE dflags- , not (gopt Opt_SccProfilingOn dflags)+ , not (sccProfilingEnabled dflags) -- not when profiling: we don't want to -- lose information about this particular -- thunk (e.g. its type) (#949)@@ -552,7 +552,7 @@ platform <- getPlatform let node = idToReg platform (NonVoid bndr) slow_lbl = closureSlowEntryLabel cl_info- fast_lbl = closureLocalEntryLabel dflags cl_info+ fast_lbl = closureLocalEntryLabel platform cl_info -- mkDirectJump does not clobber `Node' containing function closure jump = mkJump dflags NativeNodeCall (mkLblExpr fast_lbl)@@ -626,7 +626,7 @@ -- Note the eager-blackholing check is here rather than in blackHoleOnEntry, -- because emitBlackHoleCode is called from GHC.Cmm.Parser. - let eager_blackholing = not (gopt Opt_SccProfilingOn dflags)+ let eager_blackholing = not (sccProfilingEnabled dflags) && gopt Opt_EagerBlackHoling dflags -- Profiling needs slop filling (to support LDV -- profiling), so currently eager blackholing doesn't@@ -655,7 +655,7 @@ dflags <- getDynFlags let bh = blackHoleOnEntry closure_info &&- not (gopt Opt_SccProfilingOn dflags) &&+ not (sccProfilingEnabled dflags) && gopt Opt_EagerBlackHoling dflags lbl | bh = mkBHUpdInfoLabel@@ -727,7 +727,7 @@ -- see Note [atomic CAF entry] in rts/sm/Storage.c ; updfr <- getUpdFrameOff- ; let target = entryCode dflags (closureInfoPtr dflags (CmmReg (CmmLocal node)))+ ; let target = entryCode platform (closureInfoPtr dflags (CmmReg (CmmLocal node))) ; emit =<< mkCmmIfThen (cmmEqWord platform (CmmReg (CmmLocal bh)) (zeroExpr platform)) -- re-enter the CAF
compiler/GHC/StgToCmm/Closure.hs view
@@ -65,11 +65,13 @@ #include "GhclibHsVersions.h" import GHC.Prelude+import GHC.Platform import GHC.Stg.Syntax import GHC.Runtime.Heap.Layout import GHC.Cmm import GHC.Cmm.Ppr.Expr() -- For Outputable instances+import GHC.StgToCmm.Types import GHC.Types.CostCentre import GHC.Cmm.BlockId@@ -142,7 +144,7 @@ -- | Used in places where some invariant ensures that all these Ids are -- non-void; e.g. constructor field binders in case expressions.--- See Note [Post-unarisation invariants] in GHC.Stg.Unarise.+-- See Note [Post-unarisation invariants] in "GHC.Stg.Unarise". assertNonVoidIds :: [Id] -> [NonVoid Id] assertNonVoidIds ids = ASSERT(not (any (isVoidTy . idType) ids)) coerce ids@@ -152,7 +154,7 @@ -- | Used in places where some invariant ensures that all these arguments are -- non-void; e.g. constructor arguments.--- See Note [Post-unarisation invariants] in GHC.Stg.Unarise.+-- See Note [Post-unarisation invariants] in "GHC.Stg.Unarise". assertNonVoidStgArgs :: [StgArg] -> [NonVoid StgArg] assertNonVoidStgArgs args = ASSERT(not (any (isVoidTy . stgArgType) args)) coerce args@@ -188,76 +190,6 @@ argPrimRep :: StgArg -> PrimRep argPrimRep arg = typePrimRep1 (stgArgType arg) ---------------------------------------------------------------------------------- LambdaFormInfo---------------------------------------------------------------------------------- Information about an identifier, from the code generator's point of--- view. Every identifier is bound to a LambdaFormInfo in the--- environment, which gives the code generator enough info to be able to--- tail call or return that identifier.--data LambdaFormInfo- = LFReEntrant -- Reentrant closure (a function)- TopLevelFlag -- True if top level- !RepArity -- Arity. Invariant: always > 0- !Bool -- True <=> no fvs- ArgDescr -- Argument descriptor (should really be in ClosureInfo)-- | LFThunk -- Thunk (zero arity)- TopLevelFlag- !Bool -- True <=> no free vars- !Bool -- True <=> updatable (i.e., *not* single-entry)- StandardFormInfo- !Bool -- True <=> *might* be a function type-- | LFCon -- A saturated constructor application- DataCon -- The constructor-- | LFUnknown -- Used for function arguments and imported things.- -- We know nothing about this closure.- -- Treat like updatable "LFThunk"...- -- Imported things which we *do* know something about use- -- one of the other LF constructors (eg LFReEntrant for- -- known functions)- !Bool -- True <=> *might* be a function type- -- The False case is good when we want to enter it,- -- because then we know the entry code will do- -- For a function, the entry code is the fast entry point-- | LFUnlifted -- A value of unboxed type;- -- always a value, needs evaluation-- | LFLetNoEscape -- See LetNoEscape module for precise description------------------------------- StandardFormInfo tells whether this thunk has one of--- a small number of standard forms--data StandardFormInfo- = NonStandardThunk- -- The usual case: not of the standard forms-- | SelectorThunk- -- A SelectorThunk is of form- -- case x of- -- con a1,..,an -> ak- -- and the constructor is from a single-constr type.- WordOff -- 0-origin offset of ak within the "goods" of- -- constructor (Recall that the a1,...,an may be laid- -- out in the heap in a non-obvious order.)-- | ApThunk- -- An ApThunk is of form- -- x1 ... xn- -- The code for the thunk just pushes x2..xn on the stack and enters x1.- -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled- -- in the RTS to save space.- RepArity -- Arity, n-- ------------------------------------------------------ -- Building LambdaFormInfo ------------------------------------------------------@@ -325,18 +257,27 @@ ------------- mkLFImported :: Id -> LambdaFormInfo-mkLFImported id- | Just con <- isDataConWorkId_maybe id- , isNullaryRepDataCon con- = LFCon con -- An imported nullary constructor- -- We assume that the constructor is evaluated so that- -- the id really does point directly to the constructor+mkLFImported id =+ -- See Note [Conveying CAF-info and LFInfo between modules] in+ -- GHC.StgToCmm.Types+ case idLFInfo_maybe id of+ Just lf_info ->+ -- Use the LambdaFormInfo from the interface+ lf_info+ Nothing+ -- Interface doesn't have a LambdaFormInfo, make a conservative one from+ -- the type.+ | Just con <- isDataConWorkId_maybe id+ , isNullaryRepDataCon con+ -> LFCon con -- An imported nullary constructor+ -- We assume that the constructor is evaluated so that+ -- the id really does point directly to the constructor - | arity > 0- = LFReEntrant TopLevel arity True (panic "arg_descr")+ | arity > 0+ -> LFReEntrant TopLevel arity True ArgUnknown - | otherwise- = mkLFArgument id -- Not sure of exact arity+ | otherwise+ -> mkLFArgument id -- Not sure of exact arity where arity = idFunRepArity id @@ -440,7 +381,7 @@ = not no_fvs -- Self parameter || isNotTopLevel top -- Note [GC recovery] || updatable -- Need to push update frame- || gopt Opt_SccProfilingOn dflags+ || sccProfilingEnabled dflags -- For the non-updatable (single-entry case): -- -- True if has fvs (in which case we need access to them, and we@@ -567,11 +508,11 @@ getCallMethod dflags name id (LFReEntrant _ arity _ _) n_args _v_args _cg_loc _self_loop_info | n_args == 0 -- No args at all- && not (gopt Opt_SccProfilingOn dflags)+ && not (sccProfilingEnabled dflags) -- See Note [Evaluating functions with profiling] in rts/Apply.cmm = ASSERT( arity /= 0 ) ReturnIt | n_args < arity = SlowCall -- Not enough args- | otherwise = DirectEntry (enterIdLabel dflags name (idCafInfo id)) arity+ | otherwise = DirectEntry (enterIdLabel (targetPlatform dflags) name (idCafInfo id)) arity getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info = ASSERT( n_args == 0 ) ReturnIt@@ -697,7 +638,7 @@ prof = mkProfilingInfo dflags id val_descr nonptr_wds = tot_wds - ptr_wds - info_lbl = mkClosureInfoTableLabel id lf_info+ info_lbl = mkClosureInfoTableLabel dflags id lf_info -------------------------------------- -- Other functions over ClosureInfo@@ -841,19 +782,19 @@ closureSlowEntryLabel :: ClosureInfo -> CLabel closureSlowEntryLabel = toSlowEntryLbl . closureInfoLabel -closureLocalEntryLabel :: DynFlags -> ClosureInfo -> CLabel-closureLocalEntryLabel dflags- | tablesNextToCode dflags = toInfoLbl . closureInfoLabel- | otherwise = toEntryLbl . closureInfoLabel+closureLocalEntryLabel :: Platform -> ClosureInfo -> CLabel+closureLocalEntryLabel platform+ | platformTablesNextToCode platform = toInfoLbl . closureInfoLabel+ | otherwise = toEntryLbl . closureInfoLabel -mkClosureInfoTableLabel :: Id -> LambdaFormInfo -> CLabel-mkClosureInfoTableLabel id lf_info+mkClosureInfoTableLabel :: DynFlags -> Id -> LambdaFormInfo -> CLabel+mkClosureInfoTableLabel dflags id lf_info = case lf_info of LFThunk _ _ upd_flag (SelectorThunk offset) _- -> mkSelectorInfoLabel upd_flag offset+ -> mkSelectorInfoLabel dflags upd_flag offset LFThunk _ _ upd_flag (ApThunk arity) _- -> mkApInfoTableLabel upd_flag arity+ -> mkApInfoTableLabel dflags upd_flag arity LFThunk{} -> std_mk_lbl name cafs LFReEntrant{} -> std_mk_lbl name cafs@@ -870,7 +811,7 @@ -- Make the _info pointer for the implicit datacon worker -- binding local. The reason we can do this is that importing -- code always either uses the _closure or _con_info. By the- -- invariants in CorePrep anything else gets eta expanded.+ -- invariants in "GHC.CoreToStg.Prep" anything else gets eta expanded. thunkEntryLabel :: DynFlags -> Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel@@ -881,22 +822,26 @@ thunkEntryLabel dflags _thunk_id _ (SelectorThunk offset) upd_flag = enterSelectorLabel dflags upd_flag offset thunkEntryLabel dflags thunk_id c _ _- = enterIdLabel dflags thunk_id c+ = enterIdLabel (targetPlatform dflags) thunk_id c enterApLabel :: DynFlags -> Bool -> Arity -> CLabel enterApLabel dflags is_updatable arity- | tablesNextToCode dflags = mkApInfoTableLabel is_updatable arity- | otherwise = mkApEntryLabel is_updatable arity+ | platformTablesNextToCode platform = mkApInfoTableLabel dflags is_updatable arity+ | otherwise = mkApEntryLabel dflags is_updatable arity+ where+ platform = targetPlatform dflags enterSelectorLabel :: DynFlags -> Bool -> WordOff -> CLabel enterSelectorLabel dflags upd_flag offset- | tablesNextToCode dflags = mkSelectorInfoLabel upd_flag offset- | otherwise = mkSelectorEntryLabel upd_flag offset+ | platformTablesNextToCode platform = mkSelectorInfoLabel dflags upd_flag offset+ | otherwise = mkSelectorEntryLabel dflags upd_flag offset+ where+ platform = targetPlatform dflags -enterIdLabel :: DynFlags -> Name -> CafInfo -> CLabel-enterIdLabel dflags id c- | tablesNextToCode dflags = mkInfoTableLabel id c- | otherwise = mkEntryLabel id c+enterIdLabel :: Platform -> Name -> CafInfo -> CLabel+enterIdLabel platform id c+ | platformTablesNextToCode platform = mkInfoTableLabel id c+ | otherwise = mkEntryLabel id c --------------------------------------@@ -914,7 +859,7 @@ mkProfilingInfo :: DynFlags -> Id -> String -> ProfilingInfo mkProfilingInfo dflags id val_descr- | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo+ | not (sccProfilingEnabled dflags) = NoProfilingInfo | otherwise = ProfilingInfo ty_descr_w8 (BS8.pack val_descr) where ty_descr_w8 = BS8.pack (getTyDescription (idType id))@@ -961,8 +906,8 @@ -- We keep the *zero-indexed* tag in the srt_len field -- of the info table of a data constructor. - prof | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo- | otherwise = ProfilingInfo ty_descr val_descr+ prof | not (sccProfilingEnabled dflags) = NoProfilingInfo+ | otherwise = ProfilingInfo ty_descr val_descr ty_descr = BS8.pack $ occNameString $ getOccName $ dataConTyCon data_con val_descr = BS8.pack $ occNameString $ getOccName data_con
compiler/GHC/StgToCmm/DataCon.hs view
@@ -4,7 +4,7 @@ -- -- Stg to C--: code generation for constructors ----- This module provides the support code for StgToCmm to deal with with+-- This module provides the support code for StgToCmm to deal with -- constructors on the RHSs of let(rec)s. -- -- (c) The University of Glasgow 2004-2006@@ -71,7 +71,7 @@ -- 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+ -- See Note [About the NameSorts] in "GHC.Types.Name" for Internal/External (static_info, static_code) -- Otherwise generate a closure for the constructor.@@ -311,7 +311,7 @@ platform = targetPlatform dflags intClosure = maybeIntLikeCon con charClosure = maybeCharLikeCon con- getClosurePayload (NonVoid (StgLitArg (LitNumber LitNumInt val _))) = Just val+ 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!
compiler/GHC/StgToCmm/Env.hs view
@@ -136,7 +136,7 @@ let ext_lbl | isUnliftedType (idType id) = -- An unlifted external Id must refer to a top-level- -- string literal. See Note [Bytes label] in CLabel.+ -- string literal. See Note [Bytes label] in "GHC.Cmm.CLabel". ASSERT( idType id `eqType` addrPrimTy ) mkBytesLabel name | otherwise = mkClosureLabel name $ idCafInfo id
compiler/GHC/StgToCmm/Expr.hs view
@@ -464,7 +464,7 @@ tagToEnum# (#13397) we will have: case (a>b) of ... Rather than make it behave quite differently, I am testing for a-comparison operator here in in the general case as well.+comparison operator here in the general case as well. ToDo: figure out what the Right Rule should be. @@ -1007,6 +1007,7 @@ emitEnter :: CmmExpr -> FCode ReturnKind emitEnter fun = do { dflags <- getDynFlags+ ; platform <- getPlatform ; adjustHpBackwards ; sequel <- getSequel ; updfr_off <- getUpdFrameOff@@ -1020,7 +1021,7 @@ -- Right now, we do what the old codegen did, and omit the tag -- test, just generating an enter. Return -> do- { let entry = entryCode dflags $ closureInfoPtr dflags $ CmmReg nodeReg+ { let entry = entryCode platform $ closureInfoPtr dflags $ CmmReg nodeReg ; emit $ mkJump dflags NativeNodeCall entry [cmmUntag dflags fun] updfr_off ; return AssignedDirectly@@ -1062,7 +1063,7 @@ -- refer to fun via nodeReg after the copyout, to avoid having -- both live simultaneously; this sometimes enables fun to be -- inlined in the RHS of the R1 assignment.- ; let entry = entryCode dflags (closureInfoPtr dflags (CmmReg nodeReg))+ ; let entry = entryCode platform (closureInfoPtr dflags (CmmReg nodeReg)) the_call = toCall entry (Just lret) updfr_off off outArgs regs ; tscope <- getTickScope ; emit $
compiler/GHC/StgToCmm/ExtCode.hs view
@@ -61,7 +61,7 @@ = VarN CmmExpr -- ^ Holds CmmLit(CmmLabel ..) which gives the label type, -- eg, RtsLabel, ForeignLabel, CmmLabel etc. - | FunN Unit -- ^ A function name from this package+ | FunN UnitId -- ^ A function name from this unit | LabelN BlockId -- ^ A blockid of some code or data. -- | An environment of named things.@@ -162,10 +162,10 @@ addLabel name (mkBlockId u) return (mkBlockId u) --- | Add add a local function to the environment.+-- | Add a local function to the environment. newFunctionName :: FastString -- ^ name of the function- -> Unit -- ^ package of the current module+ -> UnitId -- ^ package of the current module -> ExtCode newFunctionName name pkg = addDecl name (FunN pkg)@@ -204,7 +204,7 @@ return $ case lookupUFM env name of Just (VarN e) -> e- Just (FunN pkg) -> CmmLit (CmmLabel (mkCmmCodeLabel pkg name))+ Just (FunN uid) -> CmmLit (CmmLabel (mkCmmCodeLabel uid name)) _other -> CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId name))
compiler/GHC/StgToCmm/Foreign.hs view
@@ -13,6 +13,8 @@ emitSaveThreadState, saveThreadState, emitLoadThreadState,+ emitSaveRegs,+ emitRestoreRegs, loadThreadState, emitOpenNursery, emitCloseNursery,@@ -32,6 +34,7 @@ import GHC.Cmm import GHC.Cmm.Utils import GHC.Cmm.Graph+import GHC.Cmm.CallConv import GHC.Core.Type import GHC.Types.RepType import GHC.Cmm.CLabel@@ -74,6 +77,7 @@ | otherwise = Nothing -- ToDo: this might not be correct for 64-bit API+ -- This is correct for the PowerPC ELF ABI version 1 and 2. arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType platform arg) (platformWordSizeInBytes platform) ; cmm_args <- getFCallArgs stg_args typ@@ -302,11 +306,37 @@ spExpr, close_nursery, -- and save the current cost centre stack in the TSO when profiling:- if gopt Opt_SccProfilingOn dflags then+ if sccProfilingEnabled dflags then mkStore (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) cccsExpr else mkNop ] +++-- | Save STG registers+--+-- STG registers must be saved around a C call, just in case the STG+-- register is mapped to a caller-saves machine register. Normally we+-- don't need to worry about this the code generator has already+-- loaded any live STG registers into variables for us, but in+-- hand-written low-level Cmm code where we don't know which registers+-- are live, we might have to save them all.+emitSaveRegs :: FCode ()+emitSaveRegs = do+ dflags <- getDynFlags+ let regs = realArgRegsCover dflags+ save = catAGraphs (map (callerSaveGlobalReg dflags) regs)+ emit save++-- | Restore STG registers (see 'emitSaveRegs')+emitRestoreRegs :: FCode ()+emitRestoreRegs = do+ dflags <- getDynFlags+ let regs = realArgRegsCover dflags+ save = catAGraphs (map (callerRestoreGlobalReg dflags) regs)+ emit save++ emitCloseNursery :: FCode () emitCloseNursery = do dflags <- getDynFlags@@ -391,7 +421,7 @@ mkAssign hpAllocReg (zeroExpr platform), open_nursery, -- and load the current cost centre stack from the TSO when profiling:- if gopt Opt_SccProfilingOn dflags+ if sccProfilingEnabled dflags then storeCurCCS (CmmLoad (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) (ccsType platform))@@ -634,4 +664,3 @@ -- a type in a foreign function signature with a representationally -- equivalent newtype. tycon = tyConAppTyCon (unwrapType typ)-
compiler/GHC/StgToCmm/Heap.hs view
@@ -344,7 +344,7 @@ Just (_, ArgGen _) -> False _otherwise -> True --- | lower-level version for GHC.Cmm.Parser+-- | lower-level version for "GHC.Cmm.Parser" entryHeapCheck' :: Bool -- is a known function pattern -> CmmExpr -- expression for the closure pointer -> Int -- Arity -- not same as len args b/c of voids
compiler/GHC/StgToCmm/Layout.hs view
@@ -86,7 +86,7 @@ Return -> do { adjustHpBackwards ; let e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord platform)- ; emit (mkReturn dflags (entryCode dflags e) results updfr_off)+ ; emit (mkReturn dflags (entryCode platform e) results updfr_off) } AssignTo regs adjust -> do { when adjust adjustHpBackwards@@ -222,7 +222,7 @@ fast_code <- getCode $ emitCall (NativeNodeCall, NativeReturn)- (entryCode dflags fun_iptr)+ (entryCode platform fun_iptr) (nonVArgs ((P,Just funv):argsreps)) slow_lbl <- newBlockId@@ -367,7 +367,7 @@ slowArgs :: DynFlags -> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)] slowArgs _ [] = [] slowArgs dflags args -- careful: reps contains voids (V), but args does not- | gopt Opt_SccProfilingOn dflags+ | sccProfilingEnabled dflags = save_cccs ++ this_pat ++ slowArgs dflags rest_args | otherwise = this_pat ++ slowArgs dflags rest_args where
compiler/GHC/StgToCmm/Monad.hs view
@@ -49,7 +49,7 @@ getModuleName, -- ideally we wouldn't export these, but some other modules access internal state- getState, setState, getSelfLoop, withSelfLoop, getInfoDown, getDynFlags, getThisPackage,+ getState, setState, getSelfLoop, withSelfLoop, getInfoDown, getDynFlags, -- more localised access to monad state CgIdInfo(..),@@ -473,9 +473,6 @@ getPlatform :: FCode Platform getPlatform = targetPlatform <$> getDynFlags--getThisPackage :: FCode Unit-getThisPackage = liftM thisPackage getDynFlags withInfoDown :: FCode a -> CgInfoDownwards -> FCode a withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
compiler/GHC/StgToCmm/Prim.hs view
@@ -42,7 +42,7 @@ import GHC.Cmm.Graph import GHC.Stg.Syntax import GHC.Cmm-import GHC.Unit ( rtsUnitId )+import GHC.Unit ( rtsUnit ) import GHC.Core.Type ( Type, tyConAppTyCon ) import GHC.Core.TyCon import GHC.Cmm.CLabel@@ -300,8 +300,8 @@ GetCCSOfOp -> \[arg] -> opAllDone $ \[res] -> do let val- | gopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag dflags arg)- | otherwise = CmmLit (zeroCLit platform)+ | sccProfilingEnabled dflags = costCentreFrom dflags (cmmUntag dflags arg)+ | otherwise = CmmLit (zeroCLit platform) emitAssign (CmmLocal res) val GetCurrentCCSOp -> \[_] -> opAllDone $ \[res] -> do@@ -856,6 +856,12 @@ Word2DoubleOp -> \[w] -> opAllDone $ \[res] -> do emitPrimCall [res] (MO_UF_Conv W64) [w] +-- Atomic operations+ InterlockedExchange_Addr -> \[src, value] -> opAllDone $ \[res] ->+ emitPrimCall [res] (MO_Xchg (wordWidth platform)) [src, value]+ InterlockedExchange_Int -> \[src, value] -> opAllDone $ \[res] ->+ emitPrimCall [res] (MO_Xchg (wordWidth platform)) [src, value]+ -- SIMD primops (VecBroadcastOp vcat n w) -> \[e] -> opAllDone $ \[res] -> do checkVecCompatibility dflags vcat n w@@ -1453,9 +1459,6 @@ CasMutVarOp -> alwaysExternal CatchOp -> alwaysExternal RaiseOp -> alwaysExternal- RaiseDivZeroOp -> alwaysExternal- RaiseUnderflowOp -> alwaysExternal- RaiseOverflowOp -> alwaysExternal RaiseIOOp -> alwaysExternal MaskAsyncExceptionsOp -> alwaysExternal MaskUninterruptibleOp -> alwaysExternal@@ -2152,7 +2155,7 @@ -- values! -- The current design with respect to register mapping of scalars could -- very well be the best,but exploring the design space and doing careful--- measurements is the only only way to validate that.+-- measurements is the only way to validate that. -- In some next generation CPU ISAs, notably RISC V, the SIMD extension -- includes support for a sort of run time CPU dependent vectorization parameter, -- where a loop may act upon a single scalar each iteration OR some 2,4,8 ...@@ -3043,7 +3046,7 @@ emit graph where lbl = mkLblExpr $ mkPrimCallLabel- $ PrimCall (fsLit "stg_copyArray_barrier") rtsUnitId+ $ PrimCall (fsLit "stg_copyArray_barrier") rtsUnit args = [ mkIntExpr platform hdr_size , dst
compiler/GHC/StgToCmm/Prof.hs view
@@ -76,15 +76,15 @@ -- | The profiling header words in a static closure staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit] staticProfHdr dflags ccs- | gopt Opt_SccProfilingOn dflags = [mkCCostCentreStack ccs, staticLdvInit platform]- | otherwise = []+ | sccProfilingEnabled dflags = [mkCCostCentreStack ccs, staticLdvInit platform]+ | otherwise = [] where platform = targetPlatform dflags -- | Profiling header words in a dynamic closure dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr] dynProfHdr dflags ccs- | gopt Opt_SccProfilingOn dflags = [ccs, dynLdvInit dflags]- | otherwise = []+ | sccProfilingEnabled dflags = [ccs, dynLdvInit dflags]+ | otherwise = [] -- | Initialise the profiling field of an update frame initUpdFrameProf :: CmmExpr -> FCode ()@@ -130,7 +130,7 @@ saveCurrentCostCentre = do dflags <- getDynFlags platform <- getPlatform- if not (gopt Opt_SccProfilingOn dflags)+ if not (sccProfilingEnabled dflags) then return Nothing else do local_cc <- newTemp (ccType platform) emitAssign (CmmLocal local_cc) cccsExpr@@ -195,7 +195,7 @@ ifProfiling :: FCode () -> FCode () ifProfiling code = do dflags <- getDynFlags- if gopt Opt_SccProfilingOn dflags+ if sccProfilingEnabled dflags then code else return () @@ -207,7 +207,7 @@ -- Emit the declarations initCostCentres (local_CCs, singleton_CCSs) = do dflags <- getDynFlags- when (gopt Opt_SccProfilingOn dflags) $+ when (sccProfilingEnabled dflags) $ do mapM_ emitCostCentreDecl local_CCs mapM_ emitCostCentreStackDecl singleton_CCSs @@ -277,7 +277,7 @@ emitSetCCC cc tick push = do dflags <- getDynFlags platform <- getPlatform- if not (gopt Opt_SccProfilingOn dflags)+ if not (sccProfilingEnabled dflags) then return () else do tmp <- newTemp (ccsType platform) pushCostCentre tmp cccsExpr cc@@ -364,7 +364,7 @@ loadEra :: DynFlags -> CmmExpr loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth platform))- [CmmLoad (mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "era")))+ [CmmLoad (mkLblExpr (mkRtsCmmDataLabel (fsLit "era"))) (cInt dflags)] where platform = targetPlatform dflags
compiler/GHC/StgToCmm/Ticky.hs view
@@ -115,7 +115,6 @@ import GHC.Cmm.CLabel import GHC.Runtime.Heap.Layout -import GHC.Unit import GHC.Types.Name import GHC.Types.Id import GHC.Types.Basic@@ -356,7 +355,7 @@ , mkStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_registeredp dflags))) (mkIntExpr platform 1) ]- ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "ticky_entry_ctrs"))+ ticky_entry_ctrs = mkLblExpr (mkRtsCmmDataLabel (fsLit "ticky_entry_ctrs")) emit =<< mkCmmIfThen test (catAGraphs register_stmts) tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode ()@@ -498,12 +497,12 @@ bytes, -- Bump the global allocation total ALLOC_HEAP_tot addToMemLbl (bWord platform)- (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_tot"))+ (mkRtsCmmDataLabel (fsLit "ALLOC_HEAP_tot")) bytes, -- Bump the global allocation counter ALLOC_HEAP_ctr if not genuine then mkNop else addToMemLbl (bWord platform)- (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_ctr"))+ (mkRtsCmmDataLabel (fsLit "ALLOC_HEAP_ctr")) 1 ]} @@ -567,13 +566,13 @@ ifTickyDynThunk code = tickyDynThunkIsOn >>= \b -> when b code bumpTickyCounter :: FastString -> FCode ()-bumpTickyCounter lbl = bumpTickyLbl (mkCmmDataLabel rtsUnitId lbl)+bumpTickyCounter lbl = bumpTickyLbl (mkRtsCmmDataLabel lbl) bumpTickyCounterBy :: FastString -> Int -> FCode ()-bumpTickyCounterBy lbl = bumpTickyLblBy (mkCmmDataLabel rtsUnitId lbl)+bumpTickyCounterBy lbl = bumpTickyLblBy (mkRtsCmmDataLabel lbl) bumpTickyCounterByE :: FastString -> CmmExpr -> FCode ()-bumpTickyCounterByE lbl = bumpTickyLblByE (mkCmmDataLabel rtsUnitId lbl)+bumpTickyCounterByE lbl = bumpTickyLblByE (mkRtsCmmDataLabel lbl) bumpTickyEntryCount :: CLabel -> FCode () bumpTickyEntryCount lbl = do@@ -615,7 +614,7 @@ emit (addToMem (bWord platform) (cmmIndexExpr platform (wordWidth platform)- (CmmLit (CmmLabel (mkCmmDataLabel rtsUnitId lbl)))+ (CmmLit (CmmLabel (mkRtsCmmDataLabel lbl))) (CmmLit (CmmInt (fromIntegral offset) (wordWidth platform)))) 1)
compiler/GHC/StgToCmm/Utils.hs view
@@ -23,6 +23,7 @@ tagToClosure, mkTaggedObjectLoad, callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,+ callerSaveGlobalReg, callerRestoreGlobalReg, cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord, cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,@@ -103,10 +104,10 @@ (LitChar c) -> CmmInt (fromIntegral (ord c)) (wordWidth platform) LitNullAddr -> zeroCLit platform- (LitNumber LitNumInt i _) -> CmmInt i (wordWidth platform)- (LitNumber LitNumInt64 i _) -> CmmInt i W64- (LitNumber LitNumWord i _) -> CmmInt i (wordWidth platform)- (LitNumber LitNumWord64 i _) -> CmmInt i W64+ (LitNumber LitNumInt i) -> CmmInt i (wordWidth platform)+ (LitNumber LitNumInt64 i) -> CmmInt i W64+ (LitNumber LitNumWord i) -> CmmInt i (wordWidth platform)+ (LitNumber LitNumWord64 i) -> CmmInt i W64 (LitFloat r) -> CmmFloat r W32 (LitDouble r) -> CmmFloat r W64 (LitLabel fs ms fod)@@ -180,10 +181,10 @@ -- ------------------------------------------------------------------------- -emitRtsCall :: Unit -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()+emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe -emitRtsCallWithResult :: LocalReg -> ForeignHint -> Unit -> FastString+emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () emitRtsCallWithResult res hint pkg fun args safe = emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe@@ -249,8 +250,8 @@ where platform = targetPlatform dflags - caller_save = catAGraphs (map callerSaveGlobalReg regs_to_save)- caller_load = catAGraphs (map callerRestoreGlobalReg regs_to_save)+ caller_save = catAGraphs (map (callerSaveGlobalReg dflags) regs_to_save)+ caller_load = catAGraphs (map (callerRestoreGlobalReg dflags) regs_to_save) system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery {- ,SparkHd,SparkTl,SparkBase,SparkLim -}@@ -258,12 +259,14 @@ regs_to_save = filter (callerSaves platform) system_regs - callerSaveGlobalReg reg- = mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg))+callerSaveGlobalReg :: DynFlags -> GlobalReg -> CmmAGraph+callerSaveGlobalReg dflags reg+ = mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg)) - callerRestoreGlobalReg reg- = mkAssign (CmmGlobal reg)- (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType platform reg))+callerRestoreGlobalReg :: DynFlags -> GlobalReg -> CmmAGraph+callerRestoreGlobalReg dflags reg+ = mkAssign (CmmGlobal reg)+ (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType (targetPlatform dflags) reg)) -------------------------------------------------------------------------@@ -495,7 +498,7 @@ -- We find the necessary type information in the literals in the branches let signed = case head branches of- (LitNumber nt _ _, _) -> litNumIsSigned nt+ (LitNumber nt _, _) -> litNumIsSigned nt _ -> False let range | signed = (platformMinInt platform, platformMaxInt platform)
compiler/GHC/SysTools.hs view
@@ -32,7 +32,7 @@ libmLinkOpts, -- * Mac OS X frameworks- getPkgFrameworkOpts,+ getUnitFrameworkOpts, getFrameworkOpts ) where @@ -239,15 +239,14 @@ dflags1 = if platformMisc_ghcThreaded $ platformMisc dflags0 then addWay' WayThreaded dflags0 else dflags0- dflags2 = if platformMisc_ghcDebugged $ platformMisc dflags1+ dflags = 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+ pkgs <- getPreloadUnitsAnd dflags dep_packages let pkg_lib_paths = collectLibraryPaths dflags pkgs let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths@@ -276,7 +275,7 @@ OSMinGW32 -> pkgs _ ->- filter ((/= rtsUnitId) . mkUnit) pkgs+ filter ((/= rtsUnitId) . unitId) 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 @@ -285,7 +284,7 @@ let extra_ld_inputs = ldInputs dflags -- frameworks- pkg_framework_opts <- getPkgFrameworkOpts dflags platform+ pkg_framework_opts <- getUnitFrameworkOpts dflags platform (map unitId pkgs) let framework_opts = getFrameworkOpts dflags platform @@ -421,15 +420,15 @@ [] #endif -getPkgFrameworkOpts :: DynFlags -> Platform -> [UnitId] -> IO [String]-getPkgFrameworkOpts dflags platform dep_packages+getUnitFrameworkOpts :: DynFlags -> Platform -> [UnitId] -> IO [String]+getUnitFrameworkOpts dflags platform dep_packages | platformUsesFrameworks platform = do pkg_framework_path_opts <- do- pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages+ pkg_framework_paths <- getUnitFrameworkPath dflags dep_packages return $ map ("-F" ++) pkg_framework_paths pkg_framework_opts <- do- pkg_frameworks <- getPackageFrameworks dflags dep_packages+ pkg_frameworks <- getUnitFrameworks dflags dep_packages return $ concat [ ["-framework", fw] | fw <- pkg_frameworks ] return (pkg_framework_path_opts ++ pkg_framework_opts)
compiler/GHC/SysTools/ExtraObj.hs view
@@ -50,12 +50,14 @@ else asmOpts ccInfo) return oFile where+ pkgs = unitState dflags+ -- 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)+ (unitIncludeDirs $ unsafeLookupUnit pkgs rtsUnit) -- 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@@ -168,9 +170,9 @@ -- See Note [LinkInfo section] getLinkInfo :: DynFlags -> [UnitId] -> IO String getLinkInfo dflags dep_packages = do- package_link_opts <- getPackageLinkOpts dflags dep_packages+ package_link_opts <- getUnitLinkOpts dflags dep_packages pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags)- then getPackageFrameworks dflags dep_packages+ then getUnitFrameworks dflags dep_packages else return [] let extra_ld_inputs = ldInputs dflags let
compiler/GHC/SysTools/Process.hs view
@@ -33,13 +33,17 @@ import GHC.SysTools.FileCleanup -- | Enable process jobs support on Windows if it can be expected to work (e.g.--- @process >= 1.6.8.0@).+-- @process >= 1.6.9.0@). enableProcessJobs :: CreateProcess -> CreateProcess #if defined(MIN_VERSION_process)+#if MIN_VERSION_process(1,6,9) enableProcessJobs opts = opts { use_process_jobs = True } #else enableProcessJobs opts = opts #endif+#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.@@ -48,7 +52,7 @@ -> IO (ExitCode, String) -- ^ stdout readCreateProcessWithExitCode' proc = do (_, Just outh, _, pid) <-- createProcess proc{ std_out = CreatePipe }+ createProcess $ enableProcessJobs $ proc{ std_out = CreatePipe } -- fork off a thread to start consuming the output output <- hGetContents outh@@ -77,7 +81,7 @@ -> IO (ExitCode, String, String) -- ^ (exit_code, stdout, stderr) readProcessEnvWithExitCode prog args env_update = do current_env <- getEnvironment- readCreateProcessWithExitCode (enableProcessJobs $ proc prog args) {+ readCreateProcessWithExitCode (proc prog args) { env = Just (replaceVar env_update current_env) } "" -- Don't let gcc localize version info string, #8825@@ -344,8 +348,8 @@ -- 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")@+-- * @"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
compiler/GHC/Tc/Deriv.hs view
@@ -38,11 +38,10 @@ 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.Rename.Utils import GHC.Core.Unify( tcUnifyTy ) import GHC.Core.Class@@ -294,11 +293,12 @@ ; 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+ -- Importantly, we use rnLocalValBindsLHS, not rnTopBindsLHS, to rename+ -- auxiliary bindings as if they were defined locally.+ -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate.+ ; (bndrs, rn_aux_lhs) <- rnLocalValBindsLHS emptyFsEnv aux_val_binds+ ; bindLocalNames bndrs $+ do { (rn_aux, dus_aux) <- rnLocalValBindsRHS (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)) } }@@ -722,8 +722,7 @@ HsIB { hsib_ext = vars , hsib_body = L (getLoc deriv_ty_body) $- HsForAllTy { hst_fvf = ForallInvis- , hst_bndrs = tvs+ HsForAllTy { hst_tele = mkHsForAllInvisTele tvs , hst_xforall = noExtField , hst_body = rho }} let (tvs, _theta, cls, inst_tys) = tcSplitDFunTy dfun_ty
compiler/GHC/Tc/Deriv/Functor.hs view
@@ -557,7 +557,7 @@ foldDataConArgs :: FFoldType a -> DataCon -> [a] -- Fold over the arguments of the datacon foldDataConArgs ft con- = map foldArg (dataConOrigArgTys con)+ = map foldArg (map scaledThing $ dataConOrigArgTys con) where foldArg = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of
compiler/GHC/Tc/Deriv/Generate.hs view
@@ -13,7 +13,7 @@ -- | Generating derived instance declarations ----- This module is nominally ``subordinate'' to @GHC.Tc.Deriv@, which is the+-- 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.@@ -46,8 +46,6 @@ 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@@ -66,6 +64,7 @@ import GHC.Builtin.Types.Prim import GHC.Builtin.Types import GHC.Core.Type+import GHC.Core.Multiplicity import GHC.Core.Class import GHC.Types.Var.Set import GHC.Types.Var.Env@@ -81,22 +80,77 @@ type BagDerivStuff = Bag DerivStuff +-- | A declarative description of an auxiliary binding that should be+-- generated. See @Note [Auxiliary binders]@ for a more detailed description+-- of how these are used. data AuxBindSpec- = DerivCon2Tag TyCon -- The con2Tag for given TyCon- | DerivTag2Con TyCon -- ...ditto tag2Con- | DerivMaxTag TyCon -- ...and maxTag- deriving( Eq )+ -- DerivCon2Tag, DerivTag2Con, and DerivMaxTag are used in derived Eq, Ord,+ -- Enum, and Ix instances. -- All these generate ZERO-BASED tag operations -- I.e first constructor has tag 0 + -- | @$con2tag@: Computes the tag for a given constructor+ = DerivCon2Tag+ TyCon -- The type constructor of the data type to which the+ -- constructors belong+ RdrName -- The to-be-generated $con2tag binding's RdrName++ -- | @$tag2con@: Given a tag, computes the corresponding data constructor+ | DerivTag2Con+ TyCon -- The type constructor of the data type to which the+ -- constructors belong+ RdrName -- The to-be-generated $tag2con binding's RdrName++ -- | @$maxtag@: The maximum possible tag value among a data type's+ -- constructors+ | DerivMaxTag+ TyCon -- The type constructor of the data type to which the+ -- constructors belong+ RdrName -- The to-be-generated $maxtag binding's RdrName++ -- DerivDataDataType and DerivDataConstr are only used in derived Data+ -- instances++ -- | @$t@: The @DataType@ representation for a @Data@ instance+ | DerivDataDataType+ TyCon -- The type constructor of the data type to be represented+ RdrName -- The to-be-generated $t binding's RdrName+ [RdrName] -- The RdrNames of the to-be-generated $c bindings for each+ -- data constructor. These are only used on the RHS of the+ -- to-be-generated $t binding.++ -- | @$c@: The @Constr@ representation for a @Data@ instance+ | DerivDataConstr+ DataCon -- The data constructor to be represented+ RdrName -- The to-be-generated $c binding's RdrName+ RdrName -- The RdrName of the to-be-generated $t binding for the parent+ -- data type. This is only used on the RHS of the+ -- to-be-generated $c binding.++-- | Retrieve the 'RdrName' of the binding that the supplied 'AuxBindSpec'+-- describes.+auxBindSpecRdrName :: AuxBindSpec -> RdrName+auxBindSpecRdrName (DerivCon2Tag _ con2tag_RDR) = con2tag_RDR+auxBindSpecRdrName (DerivTag2Con _ tag2con_RDR) = tag2con_RDR+auxBindSpecRdrName (DerivMaxTag _ maxtag_RDR) = maxtag_RDR+auxBindSpecRdrName (DerivDataDataType _ dataT_RDR _) = dataT_RDR+auxBindSpecRdrName (DerivDataConstr _ dataC_RDR _) = dataC_RDR+ data DerivStuff -- Please add this auxiliary stuff = DerivAuxBind AuxBindSpec+ -- ^ A new, top-level auxiliary binding. Used for deriving 'Eq', 'Ord',+ -- 'Enum', 'Ix', and 'Data'. See Note [Auxiliary binders]. -- Generics and DeriveAnyClass | DerivFamInst FamInst -- New type family instances-- -- New top-level auxiliary bindings- | DerivHsBind (LHsBind GhcPs, LSig GhcPs) -- Also used for SYB+ -- ^ A new type family instance. Used for:+ --+ -- * @DeriveGeneric@, which generates instances of @Rep(1)@+ --+ -- * @DeriveAnyClass@, which can fill in associated type family defaults+ --+ -- * @GeneralizedNewtypeDeriving@, which generates instances of associated+ -- type families for newtypes {-@@ -160,8 +214,10 @@ gen_Eq_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) gen_Eq_binds loc tycon = do- dflags <- getDynFlags- return (method_binds dflags, aux_binds)+ -- See Note [Auxiliary binders]+ con2tag_RDR <- new_con2tag_rdr_name loc tycon++ return (method_binds con2tag_RDR, aux_binds con2tag_RDR) where all_cons = tyConDataCons tycon (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons@@ -175,7 +231,7 @@ no_tag_match_cons = null tag_match_cons - fall_through_eqn dflags+ fall_through_eqn con2tag_RDR | no_tag_match_cons -- All constructors have arguments = case pat_match_cons of [] -> [] -- No constructors; no fall-though case@@ -187,16 +243,18 @@ | 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)]+ untag_Expr con2tag_RDR [(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+ aux_binds con2tag_RDR+ | no_tag_match_cons = emptyBag+ | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon con2tag_RDR - 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)+ method_binds con2tag_RDR = unitBag (eq_bind con2tag_RDR)+ eq_bind con2tag_RDR+ = mkFunBindEC 2 loc eq_RDR (const true_Expr)+ (map pats_etc pat_match_cons+ ++ fall_through_eqn con2tag_RDR) ------------------------------------------------------------------ pats_etc data_con@@ -210,7 +268,7 @@ 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)+ ([con1_pat, con2_pat], nested_eq_expr (map scaledThing tys_needed) as_needed bs_needed) where nested_eq_expr [] [] [] = true_Expr nested_eq_expr tys as bs@@ -340,21 +398,25 @@ ------------ gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) gen_Ord_binds loc tycon = do- dflags <- getDynFlags+ -- See Note [Auxiliary binders]+ con2tag_RDR <- new_con2tag_rdr_name loc tycon+ 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)+ else ( unitBag (mkOrdOp con2tag_RDR OrdCompare)+ `unionBags` other_ops con2tag_RDR+ , aux_binds con2tag_RDR) where- aux_binds | single_con_type = emptyBag- | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon+ aux_binds con2tag_RDR+ | single_con_type = emptyBag+ | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon con2tag_RDR -- Note [Game plan for deriving Ord]- other_ops dflags+ other_ops con2tag_RDR | (last_tag - first_tag) <= 2 -- 1-3 constructors || null non_nullary_cons -- Or it's an enumeration- = listToBag [mkOrdOp dflags OrdLT, lE, gT, gE]+ = listToBag [mkOrdOp con2tag_RDR OrdLT, lE, gT, gE] | otherwise = emptyBag @@ -380,39 +442,40 @@ (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons - mkOrdOp :: DynFlags -> OrdOp -> LHsBind GhcPs+ mkOrdOp :: RdrName -> 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)+ mkOrdOp con2tag_RDR op+ = mkSimpleGeneratedFunBind loc (ordMethRdr op) [a_Pat, b_Pat]+ (mkOrdOpRhs con2tag_RDR op) - mkOrdOpRhs :: DynFlags -> OrdOp -> LHsExpr GhcPs- mkOrdOpRhs dflags op -- RHS for comparing 'a' and 'b' according to op+ mkOrdOpRhs :: RdrName -> OrdOp -> LHsExpr GhcPs+ mkOrdOpRhs con2tag_RDR 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+ map (mkOrdOpAlt con2tag_RDR 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+ = mkTagCmp con2tag_RDR op | otherwise -- Mixed nullary and non-nullary = nlHsCase (nlHsVar a_RDR) $- (map (mkOrdOpAlt dflags op) non_nullary_cons- ++ [mkHsCaseAlt nlWildPat (mkTagCmp dflags op)])+ (map (mkOrdOpAlt con2tag_RDR op) non_nullary_cons+ ++ [mkHsCaseAlt nlWildPat (mkTagCmp con2tag_RDR op)]) - mkOrdOpAlt :: DynFlags -> OrdOp -> DataCon- -> LMatch GhcPs (LHsExpr GhcPs)+ mkOrdOpAlt :: RdrName -> OrdOp -> DataCon+ -> LMatch GhcPs (LHsExpr GhcPs) -- Make the alternative (Ki a1 a2 .. av ->- mkOrdOpAlt dflags op data_con+ mkOrdOpAlt con2tag_RDR op data_con = mkHsCaseAlt (nlConVarPat data_con_RDR as_needed)- (mkInnerRhs dflags op data_con)+ (mkInnerRhs con2tag_RDR op data_con) where as_needed = take (dataConSourceArity data_con) as_RDRs data_con_RDR = getRdrName data_con - mkInnerRhs dflags op data_con+ mkInnerRhs con2tag_RDR op data_con | single_con_type = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ] @@ -435,14 +498,14 @@ , mkHsCaseAlt nlWildPat (gtResult op) ] | tag > last_tag `div` 2 -- lower range is larger- = untag_Expr dflags tycon [(b_RDR, bh_RDR)] $+ = untag_Expr con2tag_RDR [(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)] $+ = untag_Expr con2tag_RDR [(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@@ -456,16 +519,16 @@ -- 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)+ mkCompareFields op (map scaledThing $ dataConOrigArgTys data_con) where data_con_RDR = getRdrName data_con bs_needed = take (dataConSourceArity data_con) bs_RDRs - mkTagCmp :: DynFlags -> OrdOp -> LHsExpr GhcPs+ mkTagCmp :: RdrName -> 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)] $+ mkTagCmp con2tag_RDR op =+ untag_Expr con2tag_RDR [(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $ unliftedOrdOp intPrimTy op ah_RDR bh_RDR mkCompareFields :: OrdOp -> [Type] -> LHsExpr GhcPs@@ -528,7 +591,7 @@ -- mean more tests (dynamically) nlHsIf (ascribeBool $ genPrimOpApp a_expr eq_op b_expr) eq gt where- ascribeBool e = nlExprWithTySig e boolTy+ ascribeBool e = nlExprWithTySig e $ nlHsTyVar boolTyCon_RDR nlConWildPat :: DataCon -> LPat GhcPs -- The pattern (K {})@@ -585,78 +648,86 @@ gen_Enum_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) gen_Enum_binds loc tycon = do- dflags <- getDynFlags- return (method_binds dflags, aux_binds)+ -- See Note [Auxiliary binders]+ con2tag_RDR <- new_con2tag_rdr_name loc tycon+ tag2con_RDR <- new_tag2con_rdr_name loc tycon+ maxtag_RDR <- new_maxtag_rdr_name loc tycon++ return ( method_binds con2tag_RDR tag2con_RDR maxtag_RDR+ , aux_binds con2tag_RDR tag2con_RDR maxtag_RDR ) where- method_binds dflags = listToBag- [ succ_enum dflags- , pred_enum dflags- , to_enum dflags- , enum_from dflags -- [0 ..]- , enum_from_then dflags -- [0, 1 ..]- , from_enum dflags+ method_binds con2tag_RDR tag2con_RDR maxtag_RDR = listToBag+ [ succ_enum con2tag_RDR tag2con_RDR maxtag_RDR+ , pred_enum con2tag_RDR tag2con_RDR+ , to_enum tag2con_RDR maxtag_RDR+ , enum_from con2tag_RDR tag2con_RDR maxtag_RDR -- [0 ..]+ , enum_from_then con2tag_RDR tag2con_RDR maxtag_RDR -- [0, 1 ..]+ , from_enum con2tag_RDR ]- aux_binds = listToBag $ map DerivAuxBind- [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]+ aux_binds con2tag_RDR tag2con_RDR maxtag_RDR = listToBag $ map DerivAuxBind+ [ DerivCon2Tag tycon con2tag_RDR+ , DerivTag2Con tycon tag2con_RDR+ , DerivMaxTag tycon maxtag_RDR+ ] occ_nm = getOccString tycon - succ_enum dflags+ succ_enum con2tag_RDR tag2con_RDR maxtag_RDR = mkSimpleGeneratedFunBind loc succ_RDR [a_Pat] $- untag_Expr dflags tycon [(a_RDR, ah_RDR)] $- nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR dflags tycon),+ untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] $+ nlHsIf (nlHsApps eq_RDR [nlHsVar maxtag_RDR, 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))+ (nlHsApp (nlHsVar tag2con_RDR) (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR], nlHsIntLit 1])) - pred_enum dflags+ pred_enum con2tag_RDR tag2con_RDR = mkSimpleGeneratedFunBind loc pred_RDR [a_Pat] $- untag_Expr dflags tycon [(a_RDR, ah_RDR)] $+ untag_Expr con2tag_RDR [(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))+ (nlHsApp (nlHsVar tag2con_RDR) (nlHsApps plus_RDR [ nlHsVarApps intDataCon_RDR [ah_RDR] , nlHsLit (HsInt noExtField (mkIntegralLit (-1 :: Int)))])) - to_enum dflags+ to_enum tag2con_RDR maxtag_RDR = 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))+ , nlHsVar maxtag_RDR]])+ (nlHsVarApps tag2con_RDR [a_RDR])+ (illegal_toEnum_tag occ_nm maxtag_RDR) - enum_from dflags+ enum_from con2tag_RDR tag2con_RDR maxtag_RDR = mkSimpleGeneratedFunBind loc enumFrom_RDR [a_Pat] $- untag_Expr dflags tycon [(a_RDR, ah_RDR)] $+ untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] $ nlHsApps map_RDR- [nlHsVar (tag2con_RDR dflags tycon),+ [nlHsVar tag2con_RDR, nlHsPar (enum_from_to_Expr (nlHsVarApps intDataCon_RDR [ah_RDR])- (nlHsVar (maxtag_RDR dflags tycon)))]+ (nlHsVar maxtag_RDR))] - enum_from_then dflags+ enum_from_then con2tag_RDR tag2con_RDR maxtag_RDR = 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]) $+ untag_Expr con2tag_RDR [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $+ nlHsApp (nlHsVarApps map_RDR [tag2con_RDR]) $ 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))+ (nlHsVar maxtag_RDR) )) - from_enum dflags+ from_enum con2tag_RDR = mkSimpleGeneratedFunBind loc fromEnum_RDR [a_Pat] $- untag_Expr dflags tycon [(a_RDR, ah_RDR)] $+ untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] $ (nlHsVarApps intDataCon_RDR [ah_RDR]) {-@@ -757,35 +828,40 @@ gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) gen_Ix_binds loc tycon = do- dflags <- getDynFlags+ -- See Note [Auxiliary binders]+ con2tag_RDR <- new_con2tag_rdr_name loc tycon+ tag2con_RDR <- new_tag2con_rdr_name loc tycon+ 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)))+ then (enum_ixes con2tag_RDR tag2con_RDR, listToBag $ map DerivAuxBind+ [ DerivCon2Tag tycon con2tag_RDR+ , DerivTag2Con tycon tag2con_RDR+ ])+ else (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon con2tag_RDR))) where --------------------------------------------------------------- enum_ixes dflags = listToBag- [ enum_range dflags- , enum_index dflags- , enum_inRange dflags+ enum_ixes con2tag_RDR tag2con_RDR = listToBag+ [ enum_range con2tag_RDR tag2con_RDR+ , enum_index con2tag_RDR+ , enum_inRange con2tag_RDR ] - enum_range dflags+ enum_range con2tag_RDR tag2con_RDR = 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]) $+ untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] $+ untag_Expr con2tag_RDR [(b_RDR, bh_RDR)] $+ nlHsApp (nlHsVarApps map_RDR [tag2con_RDR]) $ nlHsPar (enum_from_to_Expr (nlHsVarApps intDataCon_RDR [ah_RDR]) (nlHsVarApps intDataCon_RDR [bh_RDR])) - enum_index dflags+ enum_index con2tag_RDR = 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)] (+ untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] (+ untag_Expr con2tag_RDR [(d_RDR, dh_RDR)] ( let rhs = nlHsVarApps intDataCon_RDR [c_RDR] in@@ -796,11 +872,11 @@ ) -- This produces something like `(ch >= ah) && (ch <= bh)`- enum_inRange dflags+ enum_inRange con2tag_RDR = 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)] (+ untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] (+ untag_Expr con2tag_RDR [(b_RDR, bh_RDR)] (+ untag_Expr con2tag_RDR [(c_RDR, ch_RDR)] ( -- This used to use `if`, which interacts badly with RebindableSyntax. -- See #11396. nlHsApps and_RDR@@ -983,7 +1059,7 @@ read_nullary_cons = case nullary_cons of [] -> []- [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])]+ [con] -> [nlHsDo (DoExpr Nothing) (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@@ -1044,7 +1120,7 @@ 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_args = zipWithEqual "gen_Read_binds" read_arg as_needed (map scaledThing $ dataConOrigArgTys data_con) (read_a1:read_a2:_) = read_args prefix_prec = appPrecedence@@ -1057,7 +1133,7 @@ ------------------------------------------------------------------------ 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])]+ , nlHsDo (DoExpr Nothing) (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) @@ -1187,7 +1263,7 @@ where nm = wrapOpParens (unpackFS l) - show_args = zipWithEqual "gen_Show_binds" show_arg bs_needed arg_tys+ show_args = zipWithEqual "gen_Show_binds" show_arg bs_needed (map scaledThing arg_tys) (show_arg1:show_arg2:_) = show_args show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args @@ -1312,73 +1388,31 @@ -> 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) }+ = do { -- See Note [Auxiliary binders]+ dataT_RDR <- new_dataT_rdr_name loc rep_tc+ ; dataC_RDRs <- traverse (new_dataC_rdr_name loc) data_cons -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 ) )+ ; pure ( listToBag [ gfoldl_bind, gunfold_bind+ , toCon_bind dataC_RDRs, dataTypeOf_bind dataT_RDR ]+ `unionBags` gcast_binds+ -- Auxiliary definitions: the data type and constructors+ , listToBag $ map DerivAuxBind+ ( DerivDataDataType rep_tc dataT_RDR dataC_RDRs+ : zipWith (\data_con dataC_RDR ->+ DerivDataConstr data_con dataC_RDR dataT_RDR)+ data_cons dataC_RDRs )+ ) } 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)+ foldl' mk_k_app (z_Expr `nlHsApp` (eta_expand_data_con con)) as_needed) where con_name :: RdrName con_name = getRdrName con@@ -1398,9 +1432,18 @@ gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc) mk_unfold_rhs dc = foldr nlHsApp- (z_Expr `nlHsApp` nlHsVar (getRdrName dc))+ (z_Expr `nlHsApp` (eta_expand_data_con dc)) (replicate (dataConSourceArity dc) (nlHsVar k_RDR)) + eta_expand_data_con dc =+ mkHsLam eta_expand_pats+ (foldl nlHsApp (nlHsVar (getRdrName dc)) eta_expand_hsvars)+ where+ eta_expand_pats = map nlVarPat eta_expand_vars+ eta_expand_hsvars = map nlHsVar eta_expand_vars+ eta_expand_vars = take (dataConSourceArity dc) as_RDRs++ 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@@ -1410,16 +1453,18 @@ tag = dataConTag dc ------------ toConstr- toCon_bind = mkFunBindEC 1 loc toConstr_RDR id- (zipWith to_con_eqn data_cons constr_names)+ toCon_bind dataC_RDRs+ = mkFunBindEC 1 loc toConstr_RDR id+ (zipWith to_con_eqn data_cons dataC_RDRs) to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name) ------------ dataTypeOf- dataTypeOf_bind = mkSimpleGeneratedFunBind- loc- dataTypeOf_RDR- [nlWildPat]- (nlHsVar data_type_name)+ dataTypeOf_bind dataT_RDR+ = mkSimpleGeneratedFunBind+ loc+ dataTypeOf_RDR+ [nlWildPat]+ (nlHsVar dataT_RDR) ------------ gcast1/2 -- Make the binding dataCast1 x = gcast1 x -- if T :: * -> *@@ -1448,7 +1493,7 @@ kind1, kind2 :: Kind kind1 = typeToTypeKind-kind2 = liftedTypeKind `mkVisFunTy` kind1+kind2 = liftedTypeKind `mkVisFunTyMany` kind1 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR, mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,@@ -1845,7 +1890,7 @@ -- -- op :: forall c. a -> [T x] -> c -> Int L loc $ ClassOpSig noExtField False [loc_meth_RDR]- $ mkLHsSigType $ typeToLHsType to_ty+ $ mkLHsSigType $ nlHsCoreTy to_ty ) where Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id@@ -1901,13 +1946,16 @@ nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs nlHsAppType e s = noLoc (HsAppType noExtField e hs_ty) where- hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec (typeToLHsType s)+ hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec $ nlHsCoreTy s -nlExprWithTySig :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs+nlExprWithTySig :: LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs nlExprWithTySig e s = noLoc $ ExprWithTySig noExtField (parenthesizeHsExpr sigPrec e) hs_ty where- hs_ty = mkLHsSigWcType (typeToLHsType s)+ hs_ty = mkLHsSigWcType s +nlHsCoreTy :: Type -> LHsType GhcPs+nlHsCoreTy = noLoc . XHsType . NHsCoreTy+ mkCoerceClassMethEqn :: Class -- the class being derived -> [TyVar] -- the tvs in the instance head (this includes -- the tvs from both the class types and the@@ -1934,7 +1982,7 @@ {- ************************************************************************ * *-\subsection{Generating extra binds (@con2tag@ and @tag2con@)}+\subsection{Generating extra binds (@con2tag@, @tag2con@, etc.)} * * ************************************************************************ @@ -1950,80 +1998,142 @@ 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))+-- | Generate the full code for an auxiliary binding.+-- See @Note [Auxiliary binders] (Wrinkle: Reducing code duplication)@.+genAuxBindSpecOriginal :: DynFlags -> SrcSpan -> AuxBindSpec+ -> (LHsBind GhcPs, LSig GhcPs)+genAuxBindSpecOriginal dflags loc spec+ = (gen_bind spec,+ L loc (TypeSig noExtField [L loc (auxBindSpecRdrName spec)]+ (genAuxBindSpecSig loc spec))) where- rdr_name = con2tag_RDR dflags tycon+ gen_bind :: AuxBindSpec -> LHsBind GhcPs+ gen_bind (DerivCon2Tag tycon con2tag_RDR)+ = mkFunBindSE 0 loc con2tag_RDR eqns+ where+ lots_of_constructors = tyConFamilySize tycon > 8+ -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS+ -- but we don't do vectored returns any more. - sig_ty = mkLHsSigWcType $ L loc $ XHsType $ NHsCoreTy $- mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $- mkParentType tycon `mkVisFunTy` intPrimTy+ eqns | lots_of_constructors = [get_tag_eqn]+ | otherwise = map mk_eqn (tyConDataCons tycon) - lots_of_constructors = tyConFamilySize tycon > 8- -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS- -- but we don't do vectored returns any more.+ get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr) - eqns | lots_of_constructors = [get_tag_eqn]- | otherwise = map mk_eqn (tyConDataCons tycon)+ mk_eqn :: DataCon -> ([LPat GhcPs], LHsExpr GhcPs)+ mk_eqn con = ([nlWildConPat con],+ nlHsLit (HsIntPrim NoSourceText+ (toInteger ((dataConTag con) - fIRST_TAG)))) - get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)+ gen_bind (DerivTag2Con _ tag2con_RDR)+ = mkFunBindSE 0 loc tag2con_RDR+ [([nlConVarPat intDataCon_RDR [a_RDR]],+ nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)] - mk_eqn :: DataCon -> ([LPat GhcPs], LHsExpr GhcPs)- mk_eqn con = ([nlWildConPat con],- nlHsLit (HsIntPrim NoSourceText- (toInteger ((dataConTag con) - fIRST_TAG))))+ gen_bind (DerivMaxTag tycon maxtag_RDR)+ = mkHsVarBind loc maxtag_RDR rhs+ where+ rhs = nlHsApp (nlHsVar intDataCon_RDR)+ (nlHsLit (HsIntPrim NoSourceText max_tag))+ max_tag = case (tyConDataCons tycon) of+ data_cons -> toInteger ((length data_cons) - 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+ gen_bind (DerivDataDataType tycon dataT_RDR dataC_RDRs)+ = mkHsVarBind loc dataT_RDR rhs+ where+ ctx = initDefaultSDocContext dflags+ rhs = nlHsVar mkDataType_RDR+ `nlHsApp` nlHsLit (mkHsString (showSDocOneLine ctx (ppr tycon)))+ `nlHsApp` nlList (map nlHsVar dataC_RDRs) - rdr_name = tag2con_RDR dflags tycon+ gen_bind (DerivDataConstr dc dataC_RDR dataT_RDR)+ = mkHsVarBind loc dataC_RDR rhs+ where+ rhs = nlHsApps mkConstr_RDR constr_args -genAuxBindSpec dflags loc (DerivMaxTag tycon)- = (mkHsVarBind loc rdr_name rhs,- L loc (TypeSig noExtField [L loc rdr_name] sig_ty))+ constr_args+ = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag+ nlHsVar dataT_RDR -- 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++-- | Generate the code for an auxiliary binding that is a duplicate of another+-- auxiliary binding.+-- See @Note [Auxiliary binders] (Wrinkle: Reducing code duplication)@.+genAuxBindSpecDup :: SrcSpan -> RdrName -> AuxBindSpec+ -> (LHsBind GhcPs, LSig GhcPs)+genAuxBindSpecDup loc original_rdr_name dup_spec+ = (mkHsVarBind loc dup_rdr_name (nlHsVar original_rdr_name),+ L loc (TypeSig noExtField [L loc dup_rdr_name]+ (genAuxBindSpecSig loc dup_spec))) 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)+ dup_rdr_name = auxBindSpecRdrName dup_spec +-- | Generate the type signature of an auxiliary binding.+-- See @Note [Auxiliary binders]@.+genAuxBindSpecSig :: SrcSpan -> AuxBindSpec -> LHsSigWcType GhcPs+genAuxBindSpecSig loc spec = case spec of+ DerivCon2Tag tycon _+ -> mkLHsSigWcType $ L loc $ XHsType $ NHsCoreTy $+ mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $+ mkParentType tycon `mkVisFunTyMany` intPrimTy+ DerivTag2Con tycon _+ -> mkLHsSigWcType $ L loc $+ XHsType $ NHsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $+ intTy `mkVisFunTyMany` mkParentType tycon+ DerivMaxTag _ _+ -> mkLHsSigWcType (L loc (XHsType (NHsCoreTy intTy)))+ DerivDataDataType _ _ _+ -> mkLHsSigWcType (nlHsTyVar dataType_RDR)+ DerivDataConstr _ _ _+ -> mkLHsSigWcType (nlHsTyVar constr_RDR)+ type SeparateBagsDerivStuff =- -- AuxBinds and SYB bindings+ -- DerivAuxBinds ( Bag (LHsBind GhcPs, LSig GhcPs)- -- Extra family instances (used by Generic and DeriveAnyClass)- , Bag (FamInst) ) + -- Extra family instances (used by DeriveGeneric, DeriveAnyClass, and+ -- GeneralizedNewtypeDeriving)+ , Bag FamInst )++-- | Take a 'BagDerivStuff' and partition it into 'SeparateBagsDerivStuff'.+-- Also generate the code for auxiliary bindings based on the declarative+-- descriptions in the supplied 'AuxBindSpec's. See @Note [Auxiliary binders]@. genAuxBinds :: DynFlags -> SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff-genAuxBinds dflags loc b = genAuxBinds' b2 where+genAuxBinds dflags loc b = (gen_aux_bind_specs b1, 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+ splitDerivAuxBind (DerivFamInst t) = Right t - 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+ gen_aux_bind_specs = snd . foldr gen_aux_bind_spec (emptyOccEnv, emptyBag) - add1 x (a,b) = (x `consBag` a,b)- add2 x (a,b) = (a,x `consBag` b)+ -- Perform a CSE-like pass over the generated auxiliary bindings to avoid+ -- code duplication, as described in+ -- Note [Auxiliary binders] (Wrinkle: Reducing code duplication).+ -- The OccEnv remembers the first occurrence of each sort of auxiliary+ -- binding and maps it to the unique RdrName for that binding.+ gen_aux_bind_spec :: AuxBindSpec+ -> (OccEnv RdrName, Bag (LHsBind GhcPs, LSig GhcPs))+ -> (OccEnv RdrName, Bag (LHsBind GhcPs, LSig GhcPs))+ gen_aux_bind_spec spec (original_rdr_name_env, spec_bag) =+ case lookupOccEnv original_rdr_name_env spec_occ of+ Nothing+ -> ( extendOccEnv original_rdr_name_env spec_occ spec_rdr_name+ , genAuxBindSpecOriginal dflags loc spec `consBag` spec_bag )+ Just original_rdr_name+ -> ( original_rdr_name_env+ , genAuxBindSpecDup loc original_rdr_name spec `consBag` spec_bag )+ where+ spec_rdr_name = auxBindSpecRdrName spec+ spec_occ = rdrNameOcc spec_rdr_name mkParentType :: TyCon -> Type -- Turn the representation tycon of a family into@@ -2258,13 +2368,12 @@ 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)]+untag_Expr :: RdrName -> [(RdrName, RdrName)]+ -> LHsExpr GhcPs -> LHsExpr GhcPs+untag_Expr _ [] expr = expr+untag_Expr con2tag_RDR ((untag_this, put_tag_here) : more) expr+ = nlHsCase (nlHsPar (nlHsVarApps con2tag_RDR [untag_this])) {-of-}+ [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr con2tag_RDR more expr)] enum_from_to_Expr :: LHsExpr GhcPs -> LHsExpr GhcPs@@ -2376,54 +2485,251 @@ 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+new_con2tag_rdr_name, new_tag2con_rdr_name, new_maxtag_rdr_name+ :: SrcSpan -> TyCon -> TcM RdrName+-- Generates Exact RdrNames, for the binding positions+new_con2tag_rdr_name dflags tycon = new_tc_deriv_rdr_name dflags tycon mkCon2TagOcc+new_tag2con_rdr_name dflags tycon = new_tc_deriv_rdr_name dflags tycon mkTag2ConOcc+new_maxtag_rdr_name dflags tycon = new_tc_deriv_rdr_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+new_dataT_rdr_name :: SrcSpan -> TyCon -> TcM RdrName+new_dataT_rdr_name dflags tycon = new_tc_deriv_rdr_name dflags tycon mkDataTOcc -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+new_dataC_rdr_name :: SrcSpan -> DataCon -> TcM RdrName+new_dataC_rdr_name dflags dc = new_dc_deriv_rdr_name dflags dc mkDataCOcc +new_tc_deriv_rdr_name :: SrcSpan -> TyCon -> (OccName -> OccName) -> TcM RdrName+new_tc_deriv_rdr_name loc tycon occ_fun+ = newAuxBinderRdrName loc (tyConName tycon) occ_fun +new_dc_deriv_rdr_name :: SrcSpan -> DataCon -> (OccName -> OccName) -> TcM RdrName+new_dc_deriv_rdr_name loc dc occ_fun+ = newAuxBinderRdrName loc (dataConName dc) occ_fun++-- | Generate the name for an auxiliary binding, giving it a fresh 'Unique'.+-- Returns an 'Exact' 'RdrName' with an underlying 'System' 'Name'.+-- See @Note [Auxiliary binders]@.+newAuxBinderRdrName :: SrcSpan -> Name -> (OccName -> OccName) -> TcM RdrName+newAuxBinderRdrName loc parent occ_fun = do+ uniq <- newUnique+ pure $ Exact $ mkSystemNameAt uniq (occ_fun (nameOccName parent)) loc++ {- Note [Auxiliary binders] ~~~~~~~~~~~~~~~~~~~~~~~~-We often want to make a top-level auxiliary binding. E.g. for comparison we have+We often want to make top-level auxiliary bindings in derived instances.+For example, derived Eq instances sometimes generate code like this: + data T = ...+ deriving instance Eq T++ ==>++ instance Eq T where+ a == b = $con2tag_T a == $con2tag_T b++ $con2tag_T :: T -> Int+ $con2tag_T = ...code....++Note that multiple instances of the same type might need to use the same sort+of auxiliary binding. For example, $con2tag is used not only in derived Eq+instances, but also in derived Ord instances:++ deriving instance Ord T++ ==>+ instance Ord T where- compare a b = $con2tag a `compare` $con2tag b+ compare a b = $con2tag_T a `compare` $con2tag_T b - $con2tag :: T -> Int- $con2tag = ...code....+ $con2tag_T :: T -> Int+ $con2tag_T = ...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.)+How do we ensure that the two usages of $con2tag_T do not conflict with each+other? We do so by generating a separate $con2tag_T definition for each+instance, giving each definition an Exact RdrName with a separate Unique to+avoid name clashes: -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.+ instance Eq T where+ a == b = $con2tag_T{Uniq1} a == $con2tag_T{Uniq1} b -In the past we used the *unique* from the parent, but that's not stable across-recompilations as uniques are nondeterministic.+ instance Ord T where+ compare a b = $con2tag_T{Uniq2} a `compare` $con2tag_T{Uniq2} b++ -- $con2tag_T{Uniq1} and $con2tag_T{Uniq2} are Exact RdrNames with+ -- underyling System Names++ $con2tag_T{Uniq1} :: T -> Int+ $con2tag_T{Uniq1} = ...code....++ $con2tag_T{Uniq2} :: T -> Int+ $con2tag_T{Uniq2} = ...code....++Note that:++* This is /precisely/ the same mechanism that we use for+ Template Haskell–generated code.+ See Note [Binders in Template Haskell] in GHC.ThToHs.+ There we explain why we use a 'System' flavour of the Name we generate.++* See "Wrinkle: Reducing code duplication" for how we can avoid generating+ lots of duplicated code in common situations.++* See "Wrinkle: Why we sometimes do generated duplicate code" for why this+ de-duplication mechanism isn't perfect, so we fall back to CSE+ (which is very effective within a single module).++* Note that the "_T" part of "$con2tag_T" is just for debug-printing+ purposes. We could call them all "$con2tag", or even just "aux".+ The Unique is enough to keep them separate.++ This is important: we might be generating an Eq instance for two+ completely-distinct imported type constructors T.++At first glance, it might appear that this plan is infeasible, as it would+require generating multiple top-level declarations with the same OccName. But+what if auxiliary bindings /weren't/ top-level? Conceptually, we could imagine+that auxiliary bindings are /local/ to the instance declarations in which they+are used. Using some hypothetical Haskell syntax, it might look like this:++ let {+ $con2tag_T{Uniq1} :: T -> Int+ $con2tag_T{Uniq1} = ...code....++ $con2tag_T{Uniq2} :: T -> Int+ $con2tag_T{Uniq2} = ...code....+ } in {+ instance Eq T where+ a == b = $con2tag_T{Uniq1} a == $con2tag_T{Uniq1} b++ instance Ord T where+ compare a b = $con2tag_T{Uniq2} a `compare` $con2tag_T{Uniq2} b+ }++Making auxiliary bindings local is key to making this work, since GHC will+not reject local bindings with duplicate names provided that:++* Each binding has a distinct unique, and+* Each binding has an Exact RdrName with a System Name.++Even though the hypothetical Haskell syntax above does not exist, we can+accomplish the same end result through some sleight of hand in renameDeriv:+we rename auxiliary bindings with rnLocalValBindsLHS. (If we had used+rnTopBindsLHS instead, then GHC would spuriously reject auxiliary bindings+with the same OccName as duplicates.) Luckily, no special treatment is needed+to typecheck them; we can typecheck them as normal top-level bindings+(using tcTopBinds) without danger.++-----+-- Wrinkle: Reducing code duplication+-----++While the approach of generating copies of each sort of auxiliary binder per+derived instance is simpler, it can lead to code bloat if done naïvely.+Consider this example:++ data T = ...+ deriving instance Eq T+ deriving instance Ord T++ ==>++ instance Eq T where+ a == b = $con2tag_T{Uniq1} a == $con2tag_T{Uniq1} b++ instance Ord T where+ compare a b = $con2tag_T{Uniq2} a `compare` $con2tag_T{Uniq2} b++ $con2tag_T{Uniq1} :: T -> Int+ $con2tag_T{Uniq1} = ...code....++ $con2tag_T{Uniq2} :: T -> Int+ $con2tag_T{Uniq2} = ...code....++$con2tag_T{Uniq1} and $con2tag_T{Uniq2} are blatant duplicates of each other,+which is not ideal. Surely GHC can do better than that at the very least! And+indeed it does. Within the genAuxBinds function, GHC performs a small CSE-like+pass to define duplicate auxiliary binders in terms of the original one. On+the example above, that would look like this:++ $con2tag_T{Uniq1} :: T -> Int+ $con2tag_T{Uniq1} = ...code....++ $con2tag_T{Uniq2} :: T -> Int+ $con2tag_T{Uniq2} = $con2tag_T{Uniq1}++(Note that this pass does not cover all possible forms of code duplication.+See "Wrinkle: Why we sometimes do generate duplicate code" for situations+where genAuxBinds does not deduplicate code.)++To start, genAuxBinds is given a list of AuxBindSpecs, which describe the sort+of auxiliary bindings that must be generates along with their RdrNames. As+genAuxBinds processes this list, it marks the first occurrence of each sort of+auxiliary binding as the "original". For example, if genAuxBinds sees a+DerivCon2Tag for the first time (with the RdrName $con2tag_T{Uniq1}), then it+will generate the full code for a $con2tag binding:++ $con2tag_T{Uniq1} :: T -> Int+ $con2tag_T{Uniq1} = ...code....++Later, if genAuxBinds sees any additional DerivCon2Tag values, it will treat+them as duplicates. For example, if genAuxBinds later sees a DerivCon2Tag with+the RdrName $con2tag_T{Uniq2}, it will generate this code, which is much more+compact:++ $con2tag_T{Uniq2} :: T -> Int+ $con2tag_T{Uniq2} = $con2tag_T{Uniq1}++An alternative approach would be /not/ performing any kind of deduplication in+genAuxBinds at all and simply relying on GHC's simplifier to perform this kind+of CSE. But this is a more expensive analysis in general, while genAuxBinds can+accomplish the same result with a simple check.++-----+-- Wrinkle: Why we sometimes do generate duplicate code+-----++It is worth noting that deduplicating auxiliary binders is difficult in the+general case. Here are two particular examples where GHC cannot easily remove+duplicate copies of an auxiliary binding:++1. When derived instances are contained in different modules, as in the+ following example:++ module A where+ data T = ...+ module B where+ import A+ deriving instance Eq T+ module C where+ import B+ deriving instance Enum T++ The derived Eq and Enum instances for T make use of $con2tag_T, and since+ they are defined in separate modules, each module must produce its own copy+ of $con2tag_T.++2. When derived instances are separated by TH splices (#18321), as in the+ following example:++ module M where++ data T = ...+ deriving instance Eq T+ $(pure [])+ deriving instance Enum T++ Due to the way that GHC typechecks TyClGroups, genAuxBinds will run twice+ in this program: once for all the declarations before the TH splice, and+ once again for all the declarations after the TH splice. As a result,+ $con2tag_T will be generated twice, since genAuxBinds will be unable to+ recognize the presence of duplicates.++These situations are much rarer, so we do not spend any effort to deduplicate+auxiliary bindings there. Instead, we focus on the common case of multiple+derived instances within the same module, not separated by any TH splices.+(This is the case described in "Wrinkle: Reducing code duplication".) In+situation (1), we can at least fall back on GHC's simplifier to pick up+genAuxBinds' slack. -}
compiler/GHC/Tc/Deriv/Generics.hs view
@@ -29,6 +29,7 @@ import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom )+import GHC.Core.Multiplicity import GHC.Tc.Instance.Family import GHC.Unit.Module ( moduleName, moduleNameFS , moduleUnit, unitFS, getModule )@@ -168,7 +169,7 @@ -- 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))+ bad_con dc = if (any bad_arg_type (map scaledThing $ dataConOrigArgTys dc)) then (NotValid (ppr dc <+> text "must not have exotic unlifted or polymorphic arguments")) else (if (not (isVanillaDataCon dc))@@ -575,7 +576,7 @@ mkD a = mkTyConApp d1 [ k, metaDataTy, sumP (tyConDataCons a) ] mkC a = mkTyConApp c1 [ k , metaConsTy a- , prod (dataConInstOrigArgTys a+ , prod (map scaledThing . dataConInstOrigArgTys a . mkTyVarTys . tyConTyVars $ tycon) (dataConSrcBangs a) (dataConImplBangs a)@@ -741,7 +742,7 @@ argTys = dataConOrigArgTys datacon n_args = dataConSourceArity datacon - datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) argTys+ datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) (map scaledThing argTys) datacon_vars = map fst datacon_varTys datacon_rdr = getRdrName datacon
compiler/GHC/Tc/Deriv/Infer.hs view
@@ -186,10 +186,10 @@ dataConInstOrigArgTys data_con all_rep_tc_args -- No constraints for unlifted types -- See Note [Deriving and unboxed types]- , not (isUnliftedType arg_ty)+ , not (isUnliftedType (irrelevantMult arg_ty)) , let orig = DerivOriginDC data_con arg_n wildcard , preds_and_mbSubst- <- get_arg_constraints orig arg_t_or_k arg_ty+ <- get_arg_constraints orig arg_t_or_k (irrelevantMult arg_ty) ] preds = concat predss -- If the constraints require a subtype to be of kind
compiler/GHC/Tc/Deriv/Utils.hs view
@@ -48,6 +48,7 @@ import GHC.Tc.Utils.TcType import GHC.Builtin.Names.TH (liftClassKey) import GHC.Core.TyCon+import GHC.Core.Multiplicity import GHC.Core.TyCo.Ppr (pprSourceTyCon) import GHC.Core.Type import GHC.Utils.Misc@@ -59,7 +60,7 @@ 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+-- 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 @@ -99,7 +100,7 @@ , 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.+ -- ^ All arguments to 'denv_cls' in the derived instance. , denv_ctxt :: DerivContext -- ^ @'SupplyContext' theta@ for standalone deriving (where @theta@ is the -- context of the instance).@@ -590,6 +591,10 @@ = let (binds, deriv_stuff) = gen_fn loc tc in return (binds, deriv_stuff, []) + -- Like `simple`, but monadic. The only monadic thing that these functions+ -- do is allocate new Uniques, which are used for generating the names of+ -- auxiliary bindings.+ -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate. simpleM gen_fn loc tc _ = do { (binds, deriv_stuff) <- gen_fn loc tc ; return (binds, deriv_stuff, []) }@@ -853,7 +858,7 @@ = 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.+ | not (permissive || all isTauTy (map scaledThing $ dataConOrigArgTys con)) -- 5. = bad "has a higher-rank type" | otherwise = IsValid@@ -887,7 +892,7 @@ 2 (text "for type" <+> quotes (ppr ty))) where bad_args = [ arg_ty | con <- tyConDataCons rep_tc- , arg_ty <- dataConOrigArgTys con+ , Scaled _ arg_ty <- dataConOrigArgTys con , isLiftedType_maybe arg_ty /= Just True , not (ok_ty arg_ty) ]
compiler/GHC/Tc/Errors.hs view
@@ -166,7 +166,7 @@ -- 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)+-- (see Note [Fail fast on kind errors] in "GHC.Tc.Solver") -- and for simplifyDefault. reportAllUnsolved :: WantedConstraints -> TcM () reportAllUnsolved wanted@@ -183,7 +183,7 @@ -- | 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+-- "GHC.Tc.Solver" warnAllUnsolved :: WantedConstraints -> TcM () warnAllUnsolved wanted = do { ev_binds <- newTcEvBinds@@ -221,6 +221,7 @@ , text "Wanted:" <+> ppr wanted ] ; warn_redundant <- woptM Opt_WarnRedundantConstraints+ ; exp_syns <- goptM Opt_PrintExpandedSynonyms ; let err_ctxt = CEC { cec_encl = [] , cec_tidy = tidy_env , cec_defer_type_errors = type_errors@@ -234,6 +235,7 @@ -- See #15539 and c.f. setting ic_status -- in GHC.Tc.Solver.setImplicationStatus , cec_warn_redundant = warn_redundant+ , cec_expand_syns = exp_syns , cec_binds = binds_var } ; tc_lvl <- getTcLevel@@ -337,6 +339,7 @@ , cec_out_of_scope_holes :: HoleChoice -- Out of scope holes , cec_warn_redundant :: Bool -- True <=> -Wredundant-constraints+ , cec_expand_syns :: Bool -- True <=> -fprint-expanded-synonyms , cec_suppress :: Bool -- True <=> More important errors have occurred, -- so create bindings if need be, but@@ -351,6 +354,7 @@ , cec_type_holes = th , cec_out_of_scope_holes = osh , cec_warn_redundant = wr+ , cec_expand_syns = es , cec_suppress = sup }) = text "CEC" <+> braces (vcat [ text "cec_binds" <+> equals <+> ppr bvar@@ -359,6 +363,7 @@ , 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_expand_syns" <+> equals <+> ppr es , text "cec_suppress" <+> equals <+> ppr sup ]) -- | Returns True <=> the ReportErrCtxt indicates that something is deferred@@ -403,7 +408,7 @@ -} reportImplic :: ReportErrCtxt -> Implication -> TcM ()-reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_telescope = m_telescope+reportImplic ctxt implic@(Implic { ic_skols = tvs , ic_given = given , ic_wanted = wanted, ic_binds = evb , ic_status = status, ic_info = info@@ -417,10 +422,12 @@ | otherwise = do { traceTc "reportImplic" (ppr implic')+ ; when bad_telescope $ reportBadTelescope ctxt tcl_env info tvs+ -- Do /not/ use the tidied tvs because then are in the+ -- wrong order, so tidying will rename things wrongly ; reportWanteds ctxt' tc_lvl wanted ; when (cec_warn_redundant ctxt) $- warnRedundantConstraints ctxt' tcl_env info' dead_givens- ; when bad_telescope $ reportBadTelescope ctxt tcl_env m_telescope tvs }+ warnRedundantConstraints ctxt' tcl_env info' dead_givens } where tcl_env = ic_env implic insoluble = isInsolubleStatus status@@ -492,8 +499,8 @@ 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+reportBadTelescope :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [TcTyVar] -> TcM ()+reportBadTelescope ctxt env (ForAllSkol _ telescope) skols = do { msg <- mkErrorReport ctxt env (important doc) ; reportError msg } where@@ -503,8 +510,8 @@ sorted_tvs = scopedSort skols -reportBadTelescope _ _ Nothing skols- = pprPanic "reportBadTelescope" (ppr skols)+reportBadTelescope _ _ skol_info skols+ = pprPanic "reportBadTelescope" (ppr skol_info $$ ppr skols) {- Note [Redundant constraints in instance decls] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -752,8 +759,7 @@ report = important inaccessible_msg `mappend` mk_relevant_bindings binds_msg - ; err <- mkEqErr_help dflags ctxt report ct'- Nothing ty1 ty2+ ; err <- mkEqErr_help dflags ctxt report ct' ty1 ty2 ; traceTc "mkGivenErrorReporter" (ppr ct) ; reportWarning (Reason Opt_WarnInaccessibleCode) err }@@ -1126,7 +1132,7 @@ ; let orig = ctOrigin ct1 msg = couldNotDeduce (getUserGivens ctxt) (map ctPred cts, orig) ; mkErrorMsgFromCt ctxt ct1 $- important msg `mappend` mk_relevant_bindings binds_msg }+ msg `mappend` mk_relevant_bindings binds_msg } where (ct1:_) = cts @@ -1276,14 +1282,14 @@ preds = map ctPred cts givens = getUserGivens ctxt msg | null givens- = addArising orig $+ = important $ addArising orig $ sep [ text "Unbound implicit parameter" <> plural cts , nest 2 (pprParendTheta preds) ] | otherwise = couldNotDeduce givens (preds, orig) ; mkErrorMsgFromCt ctxt ct1 $- important msg `mappend` mk_relevant_bindings binds_msg }+ msg `mappend` mk_relevant_bindings binds_msg } where (ct1:_) = cts @@ -1356,56 +1362,17 @@ = 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+ ; let 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,- mk_relevant_bindings binds_msg]- ; if keep_going- then mkEqErr_help dflags ctxt report ct is_oriented ty1 ty2- else mkErrorMsgFromCt ctxt ct report }+ ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct))+ ; let report = mconcat [ important coercible_msg+ , mk_relevant_bindings binds_msg]+ ; mkEqErr_help dflags ctxt report ct ty1 ty2 } 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@@ -1453,76 +1420,43 @@ | 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+mkEqErr_help dflags ctxt report ct ty1 ty2 | Just (tv1, _) <- tcGetCastedTyVar_maybe ty1- = mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2+ = mkTyVarEqErr dflags ctxt report ct tv1 ty2 | Just (tv2, _) <- tcGetCastedTyVar_maybe ty2- = mkTyVarEqErr dflags ctxt report ct swapped tv2 ty1+ = mkTyVarEqErr dflags ctxt report ct tv2 ty1 | otherwise- = reportEqErr ctxt report ct oriented ty1 ty2- where- swapped = fmap flipSwap oriented+ = reportEqErr ctxt report ct ty1 ty2 reportEqErr :: ReportErrCtxt -> Report -> Ct- -> Maybe SwapFlag -- Nothing <=> not sure -> TcType -> TcType -> TcM ErrMsg-reportEqErr ctxt report ct oriented ty1 ty2+reportEqErr ctxt report ct ty1 ty2 = mkErrorMsgFromCt ctxt ct (mconcat [misMatch, report, eqInfo])- where misMatch = important $ misMatchOrCND ctxt ct oriented ty1 ty2- eqInfo = important $ mkEqInfoMsg ct ty1 ty2+ where+ misMatch = misMatchOrCND False ctxt ct ty1 ty2+ eqInfo = mkEqInfoMsg ct ty1 ty2 mkTyVarEqErr, mkTyVarEqErr' :: DynFlags -> ReportErrCtxt -> Report -> Ct- -> Maybe SwapFlag -> TcTyVar -> TcType -> TcM ErrMsg+ -> TcTyVar -> TcType -> TcM ErrMsg -- tv1 and ty2 are already tidied-mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2+mkTyVarEqErr dflags ctxt report ct tv1 ty2 = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr ty2)- ; mkTyVarEqErr' dflags ctxt report ct oriented tv1 ty2 }+ ; mkTyVarEqErr' dflags ctxt report ct 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+mkTyVarEqErr' dflags ctxt report ct tv1 ty2+ | isUserSkolem ctxt tv1 -- ty2 won't be a meta-tyvar; we would have+ -- swapped in Solver.Canonical.canEqTyVarHomo || isTyVarTyVar tv1 && not (isTyVarTy ty2) || ctEqRel ct == ReprEq- -- the cases below don't really apply to ReprEq (except occurs check)+ -- 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+ [ headline_msg+ , extraTyVarEqInfo ctxt tv1 ty2 , report ] @@ -1531,11 +1465,7 @@ -- 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+ = do { let extra2 = mkEqInfoMsg ct ty1 ty2 interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $ filter isTyVar $@@ -1549,17 +1479,16 @@ tyvar_binding tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv) ; mkErrorMsgFromCt ctxt ct $- mconcat [important main_msg, extra2, extra3, report] }+ mconcat [headline_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") ]+ , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) ] -- 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] } }+ ; mkErrorMsgFromCt ctxt ct $ mconcat [ headline_msg, important msg, report ] } -- If the immediately-enclosing implication has 'tv' a skolem, and -- we know by now its an InferSkol kind of skolem, then presumably@@ -1569,8 +1498,8 @@ , Implic { ic_skols = skols } <- implic , tv1 `elem` skols = mkErrorMsgFromCt ctxt ct $ mconcat- [ important $ misMatchMsg ct oriented ty1 ty2- , important $ extraTyVarEqInfo ctxt tv1 ty2+ [ misMatchMsg ctxt ct ty1 ty2+ , extraTyVarEqInfo ctxt tv1 ty2 , report ] @@ -1579,7 +1508,7 @@ , 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+ = do { let msg = misMatchMsg ctxt ct ty1 ty2 esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols <+> pprQuotedList esc_skols , text "would escape" <+>@@ -1607,7 +1536,7 @@ , 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+ do { let msg = misMatchMsg ctxt ct ty1 ty2 tclvl_extra = important $ nest 2 $ sep [ quotes (ppr tv1) <+> text "is untouchable"@@ -1615,33 +1544,38 @@ , 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+ tv_extra = extraTyVarEqInfo ctxt tv1 ty2+ add_sig = 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+ = reportEqErr ctxt report ct (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+ headline_msg = misMatchOrCND insoluble_occurs_check ctxt ct ty1 ty2+ 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"+ what = text $ levelString $+ ctLocTypeOrKind_maybe (ctLoc ct) `orElse` TypeLevel -mkEqInfoMsg :: Ct -> TcType -> TcType -> SDoc+levelString :: TypeOrKind -> String+levelString TypeLevel = "type"+levelString KindLevel = "kind"++mkEqInfoMsg :: Ct -> TcType -> TcType -> Report -- 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+ = important (tyfun_msg $$ ambig_msg) where mb_fun1 = isTyFun_maybe ty1 mb_fun2 = isTyFun_maybe ty2@@ -1669,29 +1603,34 @@ is_user_skol_info (InferSkol {}) = False is_user_skol_info _ = True -misMatchOrCND :: ReportErrCtxt -> Ct- -> Maybe SwapFlag -> TcType -> TcType -> SDoc+misMatchOrCND :: Bool -> ReportErrCtxt -> Ct+ -> TcType -> TcType -> Report -- 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+misMatchOrCND insoluble_occurs_check ctxt ct ty1 ty2+ | insoluble_occurs_check -- See Note [Insoluble occurs check]+ || (isRigidTy ty1 && isRigidTy ty2)+ || isGivenCt ct+ || null givens+ = -- If the equality is unconditionally insoluble+ -- or there is no context, don't report the context+ misMatchMsg ctxt ct ty1 ty2+ | otherwise- = couldNotDeduce givens ([eq_pred], orig)+ = mconcat [ couldNotDeduce givens ([eq_pred], orig)+ , important $ mk_supplementary_ea_msg ctxt level ty1 ty2 orig ] where ev = ctEvidence ct eq_pred = ctEvPred ev orig = ctEvOrigin ev+ level = ctLocTypeOrKind_maybe (ctEvLoc ev) `orElse` TypeLevel 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 :: [UserGiven] -> (ThetaType, CtOrigin) -> Report couldNotDeduce givens (wanteds, orig)- = vcat [ addArising orig (text "Could not deduce:" <+> pprTheta wanteds)+ = important $+ vcat [ addArising orig (text "Could not deduce:" <+> pprTheta wanteds) , vcat (pp_givens givens)] pp_givens :: [UserGiven] -> [SDoc]@@ -1763,11 +1702,11 @@ in GHC.Tc.TyCl.PatSyn). -} -extraTyVarEqInfo :: ReportErrCtxt -> TcTyVar -> TcType -> SDoc+extraTyVarEqInfo :: ReportErrCtxt -> TcTyVar -> TcType -> Report -- Add on extra info about skolem constants -- NB: The types themselves are already tidied extraTyVarEqInfo ctxt tv1 ty2- = extraTyVarInfo ctxt tv1 $$ ty_extra ty2+ = important (extraTyVarInfo ctxt tv1 $$ ty_extra ty2) where ty_extra ty = case tcGetCastedTyVar_maybe ty of Just (tv, _) -> extraTyVarInfo ctxt tv@@ -1781,15 +1720,15 @@ RuntimeUnk {} -> quotes (ppr tv) <+> text "is an interactive-debugger skolem" MetaTv {} -> empty -suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> SDoc+suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> Report -- See Note [Suggest adding a type signature] suggestAddSig ctxt ty1 ty2 | null inferred_bndrs- = empty+ = mempty | [bndr] <- inferred_bndrs- = text "Possible fix: add a type signature for" <+> quotes (ppr bndr)+ = important $ 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)+ = important $ 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@@ -1800,47 +1739,55 @@ = [] ---------------------misMatchMsg :: Ct -> Maybe SwapFlag -> TcType -> TcType -> SDoc+misMatchMsg :: ReportErrCtxt -> Ct -> TcType -> TcType -> Report -- 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+misMatchMsg ctxt ct ty1 ty2+ = important $+ addArising orig $+ pprWithExplicitKindsWhenMismatch ty1 ty2 orig $+ sep [ case orig of+ TypeEqOrigin {} -> tk_eq_msg ctxt ct ty1 ty2 orig+ KindEqOrigin {} -> tk_eq_msg ctxt ct ty1 ty2 orig+ _ -> headline_eq_msg False ct ty1 ty2+ , sameOccExtra ty2 ty1 ]+ where+ orig = ctOrigin ct - -- 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+headline_eq_msg :: Bool -> Ct -> Type -> Type -> SDoc+-- Generates the main "Could't match 't1' against 't2'+-- headline message+headline_eq_msg add_ea ct ty1 ty2 - | isLiftedRuntimeRep ty2- = lifted_vs_unlifted+ | (isLiftedRuntimeRep ty1 && isUnliftedRuntimeRep ty2) ||+ (isLiftedRuntimeRep ty2 && isUnliftedRuntimeRep ty1)+ = text "Couldn't match a lifted type with an unlifted type" - | otherwise -- So now we have Nothing or (Just IsSwapped)- -- For some reason we treat Nothing like IsSwapped- = addArising orig $- pprWithExplicitKindsWhenMismatch ty1 ty2 (ctOrigin ct) $+ | isAtomicTy ty1 || isAtomicTy ty2+ = -- Print with quotes sep [ text herald1 <+> quotes (ppr ty1) , nest padding $- text herald2 <+> quotes (ppr ty2)- , sameOccExtra ty2 ty1 ]+ text herald2 <+> quotes (ppr ty2) ]++ | otherwise+ = -- Print with vertical layout+ vcat [ text herald1 <> colon <+> ppr ty1+ , nest padding $+ text herald2 <> colon <+> ppr ty2 ] where herald1 = conc [ "Couldn't match"- , if is_repr then "representation of" else ""- , if is_oriented then "expected" else ""+ , if is_repr then "representation of" else ""+ , if add_ea then "expected" else "" , what ] herald2 = conc [ "with"- , if is_repr then "that of" else ""- , if is_oriented then ("actual " ++ what) else "" ]+ , if is_repr then "that of" else ""+ , if add_ea 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"+ what = levelString (ctLocTypeOrKind_maybe (ctLoc ct) `orElse` TypeLevel) conc :: [String] -> String conc = foldr1 add_space@@ -1850,114 +1797,49 @@ | 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+tk_eq_msg :: ReportErrCtxt+ -> Ct -> Type -> Type -> CtOrigin -> SDoc+tk_eq_msg ctxt ct ty1 ty2 orig@(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+ , uo_thing = mb_thing })+ -- We can use the TypeEqOrigin to+ -- improve the error message quite a lot - sort = case level of- TypeLevel -> text "type"- KindLevel -> text "kind"+ | isUnliftedTypeKind act, isLiftedTypeKind exp+ = sep [ text "Expecting a lifted type, but"+ , thing_msg mb_thing (text "an") (text "unlifted") ] - msg1 = case level of- KindLevel- | Just th <- maybe_thing- -> msg5 th+ | isLiftedTypeKind act, isUnliftedTypeKind exp+ = sep [ text "Expecting an unlifted type, but"+ , thing_msg mb_thing (text "a") (text "lifted") ] - _ | 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 ]+ | tcIsLiftedTypeKind exp+ = maybe_num_args_msg $$+ sep [ text "Expected a type, but"+ , case mb_thing of+ Nothing -> text "found something with kind"+ Just thing -> quotes thing <+> text "has kind"+ , quotes (pprWithTYPE act) ] - | otherwise- -> empty+ | Just nargs_msg <- num_args_msg+ = nargs_msg $$+ mk_ea_msg ctxt (Just ct) level orig - 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) ]+ | -- pprTrace "check" (ppr ea_looks_same $$ ppr exp $$ ppr act $$ ppr ty1 $$ ppr ty2) $+ ea_looks_same ty1 ty2 exp act+ = mk_ea_msg ctxt (Just ct) level orig - 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"+ | otherwise -- The mismatched types are /inside/ exp and act+ = vcat [ headline_eq_msg False ct ty1 ty2+ , mk_ea_msg ctxt Nothing level orig ] - -- TYPE t0- | Just arg <- kindRep_maybe exp- , tcIsTyVarTy arg = sdocOption sdocPrintExplicitRuntimeReps $ \case- True -> text "kind" <+> quotes (ppr exp)- False -> text "a type"+ where+ ct_loc = ctLoc ct+ level = ctLocTypeOrKind_maybe ct_loc `orElse` TypeLevel - | otherwise = text "kind" <+> quotes (ppr exp)+ thing_msg (Just thing) _ levity = quotes thing <+> text "is" <+> levity+ thing_msg Nothing an levity = text "got" <+> an <+> levity <+> text "type" num_args_msg = case level of KindLevel@@ -1970,7 +1852,7 @@ 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 thing <- mb_thing -> Just $ text "Expecting" <+> speakN (abs n) <+> more <+> quotes thing where@@ -1981,25 +1863,125 @@ _ -> Nothing - maybe_num_args_msg = case num_args_msg of- Nothing -> empty- Just m -> m+ maybe_num_args_msg = num_args_msg `orElse` empty 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- ]+tk_eq_msg ctxt ct ty1 ty2+ (KindEqOrigin cty1 mb_cty2 sub_o mb_sub_t_or_k)+ = vcat [ headline_eq_msg False ct ty1 ty2+ , supplementary_msg ]+ where+ sub_t_or_k = mb_sub_t_or_k `orElse` TypeLevel+ sub_whats = text (levelString sub_t_or_k) <> char 's'+ -- "types" or "kinds" + supplementary_msg+ = sdocOption sdocPrintExplicitCoercions $ \printExplicitCoercions ->+ case mb_cty2 of+ Just cty2+ | printExplicitCoercions+ || not (cty1 `pickyEqType` cty2)+ -> vcat [ hang (text "When matching" <+> sub_whats)+ 2 (vcat [ ppr cty1 <+> dcolon <+>+ ppr (tcTypeKind cty1)+ , ppr cty2 <+> dcolon <+>+ ppr (tcTypeKind cty2) ])+ , mk_supplementary_ea_msg ctxt sub_t_or_k cty1 cty2 sub_o ]+ _ -> text "When matching the kind of" <+> quotes (ppr cty1)++tk_eq_msg _ _ _ _ _ = panic "typeeq_mismatch_msg"++ea_looks_same :: Type -> Type -> Type -> Type -> Bool+-- True if the faulting types (ty1, ty2) look the same as+-- the expected/actual types (exp, act).+-- If so, we don't want to redundantly report the latter+ea_looks_same ty1 ty2 exp act+ = (act `looks_same` ty1 && exp `looks_same` ty2) ||+ (exp `looks_same` ty1 && act `looks_same` ty2)+ where+ looks_same t1 t2 = t1 `pickyEqType` t2+ || t1 `eqType` liftedTypeKind && t2 `eqType` liftedTypeKind+ -- pickyEqType is sensitive to synonyms, so only replies True+ -- when the types really look the same. However,+ -- (TYPE 'LiftedRep) and Type both print the same way.++mk_supplementary_ea_msg :: ReportErrCtxt -> TypeOrKind+ -> Type -> Type -> CtOrigin -> SDoc+mk_supplementary_ea_msg ctxt level ty1 ty2 orig+ | TypeEqOrigin { uo_expected = exp, uo_actual = act } <- orig+ , not (ea_looks_same ty1 ty2 exp act)+ = mk_ea_msg ctxt Nothing level orig+ | otherwise+ = empty++mk_ea_msg :: ReportErrCtxt -> Maybe Ct -> TypeOrKind -> CtOrigin -> SDoc+-- Constructs a "Couldn't match" message+-- The (Maybe Ct) says whether this is the main top-level message (Just)+-- or a supplementary message (Nothing)+mk_ea_msg ctxt at_top level+ (TypeEqOrigin { uo_actual = act, uo_expected = exp, uo_thing = mb_thing })+ | Just thing <- mb_thing+ , KindLevel <- level+ = hang (text "Expected" <+> kind_desc <> comma)+ 2 (text "but" <+> quotes thing <+> text "has kind" <+>+ quotes (ppr act))++ | otherwise+ = vcat [ case at_top of+ Just ct -> headline_eq_msg True ct exp act+ Nothing -> supplementary_ea_msg+ , ppWhen expand_syns expandedTys ]++ where+ supplementary_ea_msg = vcat [ text "Expected:" <+> ppr exp+ , text " Actual:" <+> ppr act ]++ kind_desc | tcIsConstraintKind exp = text "a constraint"+ | Just arg <- kindRep_maybe exp -- TYPE t0+ , tcIsTyVarTy arg = sdocOption sdocPrintExplicitRuntimeReps $ \case+ True -> text "kind" <+> quotes (ppr exp)+ False -> text "a type"+ | otherwise = text "kind" <+> quotes (ppr exp)++ expand_syns = cec_expand_syns ctxt++ 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"+mk_ea_msg _ _ _ _ = empty -{- Note [Insoluble occurs check wins]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- | 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++++{- Note [Insoluble occurs check]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 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@@ -2009,7 +1991,8 @@ just as insoluble as Int ~ Bool. Conclusion: if there's an insoluble occurs check (isInsolubleOccursCheck)-then report it first.+then report it directly, not in the "cannot deduce X from Y" form.+This is done in misMatchOrCND (via the insoluble_occurs_check arg) (NB: there are potentially-soluble ones, like (a ~ F a b), and we don't want to be as draconian with them.)@@ -2096,7 +2079,7 @@ (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) =+ go ty1@(FunTy _ w1 t1_1 t1_2) ty2@(FunTy _ w2 t2_1 t2_2) | w1 `eqType` w2 = 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' }@@ -2191,7 +2174,7 @@ | 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) $+ , ppUnless (same_pkg || pkg == mainUnit) $ nest 4 $ text "in package" <+> quotes (ppr pkg) ]) where pkg = moduleUnit mod
compiler/GHC/Tc/Errors/Hole.hs view
@@ -43,7 +43,7 @@ import GHC.Tc.Solver ( simpl_top, runTcSDeriveds )-import GHC.Tc.Utils.Unify ( tcSubType_NC )+import GHC.Tc.Utils.Unify ( tcSubTypeSigma ) import GHC.HsToCore.Docs ( extractDocs ) import qualified Data.Map as Map@@ -111,7 +111,7 @@ (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.+in scope for whether their type can be instantiated to 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] @@ -122,10 +122,10 @@ 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+apply by type application to the type of the fit 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+what other fits, and then outputting those fits which 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. @@ -462,7 +462,7 @@ -- into [m, a] unwrapTypeVars :: Type -> [TyCoVarBinder] unwrapTypeVars t = vars ++ case splitFunTy_maybe unforalled of- Just (_, unfunned) -> unwrapTypeVars unfunned+ Just (_, _, unfunned) -> unwrapTypeVars unfunned _ -> [] where (vars, unforalled) = splitForAllVarBndrs t holeVs = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) hfMatches@@ -600,7 +600,7 @@ ; return (tidy_env, vMsg $$ refMsg) } where -- We extract the type, the tcLevel and the types free variables- -- from from the constraint.+ -- from the constraint. hole_fvs :: FV hole_fvs = tyCoFVsOfType hole_ty hole_lvl = ctLocLevel ct_loc@@ -620,7 +620,7 @@ where newTyVars = replicateM refLvl $ setLvl <$> (newOpenTypeKind >>= newFlexiTyVar) setLvl = flip setMetaTyVarTcLevel hole_lvl- wrapWithVars vars = mkVisFunTys (map mkTyVarTy vars) hole_ty+ wrapWithVars vars = mkVisFunTysMany (map mkTyVarTy vars) hole_ty sortFits :: SortingAlg -- How we should sort the hole fits -> [HoleFit] -- The subs to sort@@ -758,34 +758,34 @@ do { traceTc "lookingUp" $ ppr el ; maybeThing <- lookup el ; case maybeThing of- Just id | not_trivial id ->- do { fits <- fitsHole ty (idType id)+ Just (id, id_ty) | not_trivial id ->+ do { fits <- fitsHole ty id_ty ; case fits of- Just (wrp, matches) -> keep_it id wrp matches+ Just (wrp, matches) -> keep_it id id_ty 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 :: HoleFitCandidate -> TcM (Maybe (Id, Type))+ lookup (IdHFCand id) = return (Just (id, idType id)) lookup hfc = do { thing <- tcLookup name ; return $ case thing of- ATcId {tct_id = id} -> Just id- AGlobal (AnId id) -> Just id+ ATcId {tct_id = id} -> Just (id, idType id)+ AGlobal (AnId id) -> Just (id, idType id) AGlobal (AConLike (RealDataCon con)) ->- Just (dataConWrapId con)+ Just (dataConWrapId con, dataConNonlinearType 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)+ keep_it eid eid_ty wrp ms = go (fit:subs) (extendVarSet seen eid) ((\n -> n - 1) <$> maxleft) ty elts where- fit = HoleFit { hfId = eid, hfCand = el, hfType = (idType eid)+ fit = HoleFit { hfId = eid, hfCand = el, hfType = eid_ty , hfRefLvl = length (snd ty) , hfWrap = wrp, hfMatches = ms , hfDoc = Nothing }@@ -933,7 +933,7 @@ -- imp is the innermost implication (imp:_) -> return (ic_tclvl imp) ; (wrap, wanted) <- setTcLevel innermost_lvl $ captureConstraints $- tcSubType_NC ExprSigCtxt ty hole_ty+ tcSubTypeSigma ExprSigCtxt ty hole_ty ; traceTc "Checking hole fit {" empty ; traceTc "wanteds are: " $ ppr wanted ; if isEmptyWC wanted && isEmptyBag th_relevant_cts
compiler/GHC/Tc/Gen/Arrow.hs view
@@ -14,7 +14,8 @@ import GHC.Prelude -import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcLExpr, tcInferRho, tcSyntaxOp, tcCheckId, tcCheckExpr )+import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcCheckMonoExpr, tcInferRho, tcSyntaxOp+ , tcCheckId, tcCheckPolyExpr ) import GHC.Hs import GHC.Tc.Gen.Match@@ -28,6 +29,7 @@ import GHC.Tc.Utils.Env import GHC.Tc.Types.Origin import GHC.Tc.Types.Evidence+import GHC.Core.Multiplicity import GHC.Types.Id( mkLocalId ) import GHC.Tc.Utils.Instantiate import GHC.Builtin.Types@@ -83,7 +85,7 @@ tcProc :: LPat GhcRn -> LHsCmdTop GhcRn -- proc pat -> expr -> ExpRhoType -- Expected type of whole proc expression- -> TcM (LPat GhcTc, LHsCmdTop GhcTcId, TcCoercion)+ -> TcM (LPat GhcTc, LHsCmdTop GhcTc, TcCoercion) tcProc pat cmd exp_ty = newArrowScope $@@ -91,7 +93,7 @@ ; (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 $+ ; (pat', cmd') <- tcCheckPat ProcExpr pat (unrestricted arg_ty) $ tcCmdTop cmd_env cmd (unitTy, res_ty) ; let res_co = mkTcTransCo co (mkTcAppCo co1 (mkTcNomReflCo res_ty))@@ -121,7 +123,7 @@ tcCmdTop :: CmdEnv -> LHsCmdTop GhcRn -> CmdType- -> TcM (LHsCmdTop GhcTcId)+ -> TcM (LHsCmdTop GhcTc) tcCmdTop env (L loc (HsCmdTop names cmd)) cmd_ty@(cmd_stk, res_ty) = setSrcSpan loc $@@ -130,14 +132,14 @@ ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names') cmd') } -----------------------------------------tcCmd :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTcId)+tcCmd :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTc) -- 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 :: CmdEnv -> HsCmd GhcRn -> CmdType -> TcM (HsCmd GhcTc) tc_cmd env (HsCmdPar x cmd) res_ty = do { cmd' <- tcCmd env cmd res_ty ; return (HsCmdPar x cmd') }@@ -161,7 +163,7 @@ 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)+ = do { pred' <- tcCheckMonoExpr pred boolTy ; b1' <- tcCmd env b1 res_ty ; b2' <- tcCmd env b2 res_ty ; return (HsCmdIf x NoSyntaxExprTc pred' b1' b2')@@ -178,8 +180,8 @@ (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)+ (mkCheckExpType r_ty) $ \ _ _ ->+ tcCheckMonoExpr pred pred_ty ; b1' <- tcCmd env b1 res_ty ; b2' <- tcCmd env b2 res_ty@@ -206,9 +208,9 @@ = 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))+ ; fun' <- select_arrow_scope (tcCheckMonoExpr fun fun_ty) - ; arg' <- tcLExpr arg (mkCheckExpType arg_ty)+ ; arg' <- tcCheckMonoExpr arg arg_ty ; return (HsCmdArrApp fun_ty fun' arg' ho_app lr) } where@@ -233,7 +235,7 @@ = addErrCtxt (cmdCtxt cmd) $ do { arg_ty <- newOpenFlexiTyVarTy ; fun' <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty)- ; arg' <- tcLExpr arg (mkCheckExpType arg_ty)+ ; arg' <- tcCheckMonoExpr arg arg_ty ; return (HsCmdApp x fun' arg') } -------------------------------------------@@ -253,13 +255,13 @@ -- Check the patterns, and the GRHSs inside ; (pats', grhss') <- setSrcSpan mtch_loc $- tcPats LambdaExpr pats (map mkCheckExpType arg_tys) $+ tcPats LambdaExpr pats (map (unrestricted . 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'+ arg_tys = map (unrestricted . hsLPatType) pats' cmd' = HsCmdLam x (MG { mg_alts = L l [match'] , mg_ext = MatchGroupTc arg_tys res_ty , mg_origin = origin })@@ -308,13 +310,13 @@ do { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args -- We use alphaTyVar for 'w' ; let e_ty = mkInfForAllTy alphaTyVar $- mkVisFunTys cmd_tys $+ mkVisFunTysMany cmd_tys $ mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty- ; expr' <- tcCheckExpr expr e_ty+ ; expr' <- tcCheckPolyExpr expr e_ty ; return (HsCmdArrForm x expr' f fixity cmd_args') } where- tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTcId, TcType)+ tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTc, TcType) tc_cmd_arg cmd = do { arr_ty <- newFlexiTyVarTy arrowTyConKind ; stk_ty <- newFlexiTyVarTy liftedTypeKind@@ -337,9 +339,9 @@ -> TcType -- ^ type of the scrutinee -> MatchGroup GhcRn (LHsCmd GhcRn) -- ^ case alternatives -> CmdType- -> TcM (MatchGroup GhcTcId (LHsCmd GhcTcId))+ -> TcM (MatchGroup GhcTc (LHsCmd GhcTc)) tcCmdMatches env scrut_ty matches (stk, res_ty)- = tcMatchesCase match_ctxt scrut_ty matches (mkCheckExpType res_ty)+ = tcMatchesCase match_ctxt (unrestricted scrut_ty) matches (mkCheckExpType res_ty) where match_ctxt = MC { mc_what = CaseAlt, mc_body = mc_body }@@ -381,7 +383,7 @@ 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 $+ ; (pat', thing) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $ thing_inside res_ty ; return (mkTcBindStmt pat' rhs', thing) } @@ -389,7 +391,7 @@ , 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+ ; let tup_ids = zipWith (\n p -> mkLocalId n Many p) tup_names tup_elt_tys -- Many because it's a recursive definition ; tcExtendIdEnv tup_ids $ do { (stmts', tup_rets) <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty $ \ _res_ty' ->@@ -421,7 +423,7 @@ tcArrDoStmt _ _ stmt _ _ = pprPanic "tcArrDoStmt: unexpected Stmt" (ppr stmt) -tc_arr_rhs :: CmdEnv -> LHsCmd GhcRn -> TcM (LHsCmd GhcTcId, TcType)+tc_arr_rhs :: CmdEnv -> LHsCmd GhcRn -> TcM (LHsCmd GhcTc, TcType) tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind ; rhs' <- tcCmd env rhs (unitTy, ty) ; return (rhs', ty) }@@ -438,7 +440,7 @@ mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2] arrowTyConKind :: Kind -- *->*->*-arrowTyConKind = mkVisFunTys [liftedTypeKind, liftedTypeKind] liftedTypeKind+arrowTyConKind = mkVisFunTysMany [liftedTypeKind, liftedTypeKind] liftedTypeKind {- ************************************************************************
compiler/GHC/Tc/Gen/Bind.hs view
@@ -23,8 +23,9 @@ import GHC.Prelude import {-# SOURCE #-} GHC.Tc.Gen.Match ( tcGRHSsPat, tcMatchesFun )-import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcLExpr )+import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcCheckMonoExpr ) import {-# SOURCE #-} GHC.Tc.TyCl.PatSyn ( tcPatSynDecl, tcPatSynBuilderBind )+ import GHC.Core (Tickish (..)) import GHC.Types.CostCentre (mkUserCC, CCFlavour(DeclCC)) import GHC.Driver.Session@@ -40,6 +41,7 @@ import GHC.Tc.Gen.HsType import GHC.Tc.Gen.Pat import GHC.Tc.Utils.TcMType+import GHC.Core.Multiplicity import GHC.Core.FamInstEnv( normaliseType ) import GHC.Tc.Instance.Family( tcGetFamInstEnvs ) import GHC.Core.TyCon@@ -213,7 +215,7 @@ -- 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+-- 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@@ -321,7 +323,7 @@ ------------------------ tcLocalBinds :: HsLocalBinds GhcRn -> TcM thing- -> TcM (HsLocalBinds GhcTcId, thing)+ -> TcM (HsLocalBinds GhcTc, thing) tcLocalBinds (EmptyLocalBinds x) thing_inside = do { thing <- thing_inside@@ -354,7 +356,7 @@ = do { ty <- newOpenFlexiTyVarTy ; let p = mkStrLitTy $ hsIPNameFS ip ; ip_id <- newDict ipClass [ p, ty ]- ; expr' <- tcLExpr expr (mkCheckExpType ty)+ ; expr' <- tcCheckMonoExpr expr 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"@@ -382,29 +384,35 @@ tcValBinds :: TopLevelFlag -> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM thing- -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing)+ -> TcM ([(RecFlag, LHsBinds GhcTc)], 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 :: <type> -- might relate to more than one SCC- ; (poly_ids, sig_fn) <- tcAddPatSynPlaceholders patsyns $+ (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) }}+ -- 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+ -- See Note [Relevant bindings and the binder stack]+ --+ -- For the moment, let bindings and top-level bindings introduce+ -- only unrestricted variables.+ ; 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)@@ -412,7 +420,7 @@ ------------------------ tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv -> [(RecFlag, LHsBinds GhcRn)] -> TcM thing- -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing)+ -> TcM ([(RecFlag, LHsBinds GhcTc)], thing) -- Typecheck a whole lot of value bindings, -- one strongly-connected component at a time -- Here a "strongly connected component" has the straightforward@@ -453,7 +461,7 @@ tc_group :: forall thing. TopLevelFlag -> TcSigFun -> TcPragEnv -> (RecFlag, LHsBinds GhcRn) -> IsGroupClosed -> TcM thing- -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing)+ -> TcM ([(RecFlag, LHsBinds GhcTc)], thing) -- Typecheck one strongly-connected component of the original program. -- We get a list of groups back, because there may@@ -476,7 +484,7 @@ -- 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.+ -- See Note [Polymorphic recursion] in "GHC.Hs.Binds". do { traceTc "tc_group rec" (pprLHsBinds binds) ; whenIsJust mbFirstPatSyn $ \lpat_syn -> recursivePatSynErr (getLoc lpat_syn) binds@@ -491,11 +499,12 @@ sccs :: [SCC (LHsBind GhcRn)] sccs = stronglyConnCompFromEdgedVerticesUniq (mkEdges sig_fn binds) - go :: [SCC (LHsBind GhcRn)] -> TcM (LHsBinds GhcTcId, thing)+ go :: [SCC (LHsBind GhcRn)] -> TcM (LHsBinds GhcTc, thing) go (scc:sccs) = do { (binds1, ids1) <- tc_scc scc- ; (binds2, thing) <- tcExtendLetEnv top_lvl sig_fn- closed ids1 $- go sccs+ -- recursive bindings must be unrestricted+ -- (the ids added to the environment here are the name of the recursive definitions).+ ; (binds2, thing) <- tcExtendLetEnv top_lvl sig_fn closed ids1+ (go sccs) ; return (binds1 `unionBags` binds2, thing) } go [] = do { thing <- thing_inside; return (emptyBag, thing) } @@ -523,7 +532,7 @@ tc_single :: forall thing. TopLevelFlag -> TcSigFun -> TcPragEnv -> LHsBind GhcRn -> IsGroupClosed -> TcM thing- -> TcM (LHsBinds GhcTcId, thing)+ -> TcM (LHsBinds GhcTc, thing) tc_single _top_lvl sig_fn _prag_fn (L _ (PatSynBind _ psb@PSB{ psb_id = L _ name })) _ thing_inside@@ -537,6 +546,8 @@ NonRecursive NonRecursive closed [lbind]+ -- since we are defining a non-recursive binding, it is not necessary here+ -- to define an unrestricted binding. But we do so until toplevel linear bindings are supported. ; thing <- tcExtendLetEnv top_lvl sig_fn closed ids thing_inside ; return (binds1, thing) } @@ -544,7 +555,7 @@ type BKey = Int -- Just number off the bindings mkEdges :: TcSigFun -> LHsBinds GhcRn -> [Node BKey (LHsBind GhcRn)]--- See Note [Polymorphic recursion] in HsBinds.+-- See Note [Polymorphic recursion] in "GHC.Hs.Binds". mkEdges sig_fn binds = [ DigraphNode bind key [key | n <- nonDetEltsUniqSet (bind_fvs (unLoc bind)), Just key <- [lookupNameEnv key_map n], no_sig n ]@@ -574,7 +585,7 @@ -- dependencies based on type signatures -> IsGroupClosed -- Whether the group is closed -> [LHsBind GhcRn] -- None are PatSynBind- -> TcM (LHsBinds GhcTcId, [TcId])+ -> TcM (LHsBinds GhcTc, [TcId]) -- Typechecks a single bunch of values bindings all together, -- and generalises them. The bunch may be only part of a recursive@@ -618,7 +629,7 @@ -- 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 :: [Name] -> TcSigFun -> TcM (LHsBinds GhcTc, [Id]) recoveryCode binder_names sig_fn = do { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names) ; let poly_ids = map mk_dummy binder_names@@ -629,7 +640,7 @@ , Just poly_id <- completeSigPolyId_maybe sig = poly_id | otherwise- = mkLocalId name forall_a_a+ = mkLocalId name Many forall_a_a forall_a_a :: TcType -- At one point I had (forall r (a :: TYPE r). a), but of course@@ -651,7 +662,7 @@ -- dependencies based on type signatures -> TcPragEnv -> TcSigFun -> [LHsBind GhcRn]- -> TcM (LHsBinds GhcTcId, [TcId])+ -> TcM (LHsBinds GhcTc, [TcId]) tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn@@ -678,7 +689,7 @@ tcPolyCheck :: TcPragEnv -> TcIdSigInfo -- Must be a complete signature -> LHsBind GhcRn -- Must be a FunBind- -> TcM (LHsBinds GhcTcId, [TcId])+ -> TcM (LHsBinds GhcTc, [TcId]) -- There is just one binding, -- it is a FunBind -- it has a complete type signature,@@ -686,50 +697,60 @@ (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]+ (L bind_loc (FunBind { fun_id = L nm_loc name+ , fun_matches = matches }))+ = do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc) ; 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+ ; (wrap_gen, (wrap_res, matches'))+ <- setSrcSpan sig_loc $ -- Sets the binding location for the skolems+ tcSkolemiseScoped ctxt (idType poly_id) $ \rho_ty ->+ -- Unwraps multiple layers; e.g+ -- f :: forall a. Eq a => forall b. Ord b => blah+ -- NB: tcSkolemise makes fresh type variables+ -- See Note [Instantiate sig with fresh variables] - ; (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 mono_id = mkLocalId mono_name (varMult poly_id) rho_ty in+ tcExtendBinderStack [TcIdBndr mono_id NotTopLevel] $+ -- Why mono_id in the BinderStack?+ -- See Note [Relevant bindings and the binder stack] + setSrcSpan bind_loc $+ tcMatchesFun (L nm_loc mono_name) matches+ (mkCheckExpType rho_ty)++ -- We make a funny AbsBinds, abstracting over nothing,+ -- just so we haev somewhere to put the SpecPrags.+ -- Otherwise we could just use the FunBind+ -- Hence poly_id2 is just a clone of poly_id;+ -- We re-use mono-name, but we could equally well use a fresh one+ ; let prag_sigs = lookupPragEnv prag_fn name- ; spec_prags <- tcSpecPrags poly_id prag_sigs+ poly_id2 = mkLocalId mono_name (idMult poly_id) (idType poly_id)+ ; 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+ ; tick <- funBindTicks nm_loc poly_id mod prag_sigs++ ; let bind' = FunBind { fun_id = L nm_loc poly_id2 , fun_matches = matches'- , fun_ext = co_fn+ , fun_ext = wrap_gen <.> wrap_res , fun_tick = tick } export = ABE { abe_ext = noExtField , abe_wrap = idHsWrapper , abe_poly = poly_id- , abe_mono = mono_id+ , abe_mono = poly_id2 , abe_prags = SpecPrags spec_prags } - abs_bind = L loc $+ abs_bind = L bind_loc $ AbsBinds { abs_ext = noExtField- , abs_tvs = skol_tvs- , abs_ev_vars = ev_vars- , abs_ev_binds = [ev_binds]+ , abs_tvs = []+ , abs_ev_vars = []+ , abs_ev_binds = [] , abs_exports = [export]- , abs_binds = unitBag (L loc bind')+ , abs_binds = unitBag (L bind_loc bind') , abs_sig = True } ; return (unitBag abs_bind, [poly_id]) }@@ -782,7 +803,7 @@ -> TcPragEnv -> TcSigFun -> Bool -- True <=> apply the monomorphism restriction -> [LHsBind GhcRn]- -> TcM (LHsBinds GhcTcId, [TcId])+ -> TcM (LHsBinds GhcTc, [TcId]) tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list = do { (tclvl, wanted, (binds', mono_infos)) <- pushLevelAndCaptureConstraints $@@ -862,7 +883,7 @@ -- 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+ tcSubTypeSigma sig_ctxt sel_poly_ty poly_ty ; warn_missing_sigs <- woptM Opt_WarnMissingLocalSignatures ; when warn_missing_sigs $@@ -919,7 +940,7 @@ -- do this check; otherwise (#14000) we may report an ambiguity -- error for a rather bogus type. - ; return (mkLocalId poly_name inferred_poly_ty) }+ ; return (mkLocalId poly_name Many inferred_poly_ty) } chooseInferredQuantifiers :: TcThetaType -- inferred@@ -943,9 +964,13 @@ , sig_inst_theta = annotated_theta , sig_inst_skols = annotated_tvs })) = -- Choose quantifiers for a partial type signature- do { psig_qtvbndr_prs <- zonkTyVarTyVarPairs annotated_tvs- ; let psig_qtv_prs = mapSnd binderVar psig_qtvbndr_prs+ do { let (psig_qtv_nms, psig_qtv_bndrs) = unzip annotated_tvs+ ; psig_qtv_bndrs <- mapM zonkInvisTVBinder psig_qtv_bndrs+ ; let psig_qtvs = map binderVar psig_qtv_bndrs+ psig_qtv_set = mkVarSet psig_qtvs+ psig_qtv_prs = psig_qtv_nms `zip` psig_qtvs + -- Check whether the quantified variables of the -- partial signature have been unified together -- See Note [Quantified variables in partial type signatures]@@ -958,17 +983,14 @@ ; mapM_ report_mono_sig_tv_err [ n | (n,tv) <- psig_qtv_prs , not (tv `elem` qtvs) ] - ; let psig_qtvbndrs = map snd psig_qtvbndr_prs- psig_qtvs = mkVarSet (map snd psig_qtv_prs)- ; annotated_theta <- zonkTcTypes annotated_theta- ; (free_tvs, my_theta) <- choose_psig_context psig_qtvs annotated_theta wcx+ ; (free_tvs, my_theta) <- choose_psig_context psig_qtv_set annotated_theta wcx - ; let keep_me = free_tvs `unionVarSet` psig_qtvs+ ; let keep_me = free_tvs `unionVarSet` psig_qtv_set final_qtvs = [ mkTyVarBinder vis tv | tv <- qtvs -- Pulling from qtvs maintains original order , tv `elemVarSet` keep_me- , let vis = case lookupVarBndr tv psig_qtvbndrs of+ , let vis = case lookupVarBndr tv psig_qtv_bndrs of Just spec -> spec Nothing -> InferredSpec ] @@ -1250,7 +1272,7 @@ -- we are not rescued by a type signature -> TcSigFun -> LetBndrSpec -> [LHsBind GhcRn]- -> TcM (LHsBinds GhcTcId, [MonoBindInfo])+ -> TcM (LHsBinds GhcTc, [MonoBindInfo]) tcMonoBinds is_rec sig_fn no_gen [ L b_loc (FunBind { fun_id = L nm_loc name , fun_matches = matches })]@@ -1273,7 +1295,7 @@ -- 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+ ; mono_id <- newLetBndr no_gen name Many rhs_ty ; return (unitBag $ L b_loc $ FunBind { fun_id = L nm_loc mono_id, fun_matches = matches',@@ -1323,7 +1345,7 @@ data TcMonoBind -- Half completed; LHS done, RHS not done = TcFunBind MonoBindInfo SrcSpan (MatchGroup GhcRn (LHsExpr GhcRn))- | TcPatBind [MonoBindInfo] (LPat GhcTcId) (GRHSs GhcRn (LHsExpr GhcRn))+ | TcPatBind [MonoBindInfo] (LPat GhcTc) (GRHSs GhcRn (LHsExpr GhcRn)) TcSigmaType tcLhs :: TcSigFun -> LetBndrSpec -> HsBind GhcRn -> TcM TcMonoBind@@ -1346,7 +1368,10 @@ | otherwise -- No type signature = do { mono_ty <- newOpenFlexiTyVarTy- ; mono_id <- newLetBndr no_gen name mono_ty+ ; mono_id <- newLetBndr no_gen name Many mono_ty+ -- This ^ generates a binder with Many multiplicity because all+ -- let/where-binders are unrestricted. When we introduce linear let+ -- binders, we will need to retrieve the multiplicity information. ; let mono_info = MBI { mbi_poly_name = name , mbi_sig = Nothing , mbi_mono_id = mono_id }@@ -1364,7 +1389,10 @@ ; ((pat', nosig_mbis), pat_ty) <- addErrCtxt (patMonoBindsCtxt pat grhss) $ tcInfer $ \ exp_ty ->- tcLetPat inst_sig_fun no_gen pat exp_ty $+ tcLetPat inst_sig_fun no_gen pat (unrestricted exp_ty) $+ -- The above inferred type get an unrestricted multiplicity. It may be+ -- worth it to try and find a finer-grained multiplicity here+ -- if examples warrant it. mapM lookup_info nosig_names ; let mbis = sig_mbis ++ nosig_mbis@@ -1411,10 +1439,13 @@ | 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+ = newLetBndr no_gen name Many tau+ -- Binders with a signature are currently always of multiplicity+ -- Many. Because they come either from toplevel, let, or where+ -- declarations. Which are all unrestricted currently. --------------------tcRhs :: TcMonoBind -> TcM (HsBind GhcTcId)+tcRhs :: TcMonoBind -> TcM (HsBind GhcTc) tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id }) loc matches) = tcExtendIdBinderStackForRhs [info] $@@ -1435,6 +1466,12 @@ tcExtendIdBinderStackForRhs infos $ do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty) ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $+ tcScalingUsage Many $+ -- Like in tcMatchesFun, this scaling happens because all+ -- let bindings are unrestricted. A difference, here, is+ -- that when this is not the case, any more, we will have to+ -- make sure that the pattern is strict, otherwise this will+ -- be desugar to incorrect code. tcGRHSsPat grhss pat_ty ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss' , pat_ext = NPatBindTc emptyNameSet pat_ty@@ -1454,17 +1491,7 @@ 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+-- See Note [Relevant bindings and the binder stack] tcExtendIdBinderStackForRhs infos thing_inside = tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel | MBI { mbi_mono_id = mono_id } <- infos ]@@ -1480,7 +1507,22 @@ get_info (TcPatBind infos _ _ _) rest = infos ++ rest -{- Note [Typechecking pattern bindings]+{- Note [Relevant bindings and the binder stack]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When typecking a binding we 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.+(See TcErrors.relevantBindings.)++Note [Typechecking pattern bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Look at: - typecheck/should_compile/ExPat@@ -1567,7 +1609,7 @@ generalisation step will do the checking and impedance matching against the signature. - - If for some some reason we are not generalising (plan = NoGen), the+ - If for 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
compiler/GHC/Tc/Gen/Default.hs view
@@ -70,8 +70,8 @@ tc_default_ty :: [Class] -> LHsType GhcRn -> TcM Type tc_default_ty deflt_clss hs_ty- = do { (ty, _kind) <- solveEqualities $- tcLHsType hs_ty+ = do { ty <- solveEqualities $+ tcInferLHsType hs_ty ; ty <- zonkTcTypeToType ty -- establish Type invariants ; checkValidType DefaultDeclCtxt ty
compiler/GHC/Tc/Gen/Expr.hs view
@@ -13,20 +13,15 @@ {-# 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+ ( tcCheckPolyExpr,+ tcCheckMonoExpr, tcCheckMonoExprNC, tcMonoExpr, tcMonoExprNC,+ tcInferSigma, tcInferRho, tcInferRhoNC,+ tcExpr,+ tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,+ tcCheckId,+ addAmbiguousNameErr,+ getFixedTyVars ) where #include "GhclibHsVersions.h" @@ -40,6 +35,8 @@ import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Unify import GHC.Types.Basic+import GHC.Core.Multiplicity+import GHC.Core.UsageEnv import GHC.Tc.Utils.Instantiate import GHC.Tc.Gen.Bind ( chooseInferredQuantifiers, tcLocalBinds ) import GHC.Tc.Gen.Sig ( tcUserTypeSig, tcInstSig )@@ -101,25 +98,35 @@ ************************************************************************ -} -tcCheckExpr, tcCheckExprNC++tcCheckPolyExpr, tcCheckPolyExprNC :: 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)+-- tcCheckPolyExpr 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+tcCheckPolyExpr expr res_ty = tcPolyExpr expr (mkCheckExpType res_ty)+tcCheckPolyExprNC expr res_ty = tcPolyExprNC expr (mkCheckExpType res_ty)++-- These versions take an ExpType+tcPolyExpr, tcPolyExprNC+ :: LHsExpr GhcRn -> ExpSigmaType+ -> TcM (LHsExpr GhcTc)++tcPolyExpr expr res_ty = addExprCtxt expr $- tcCheckExprNC expr res_ty+ do { traceTc "tcPolyExpr" (ppr res_ty)+ ; tcPolyExprNC expr res_ty } -tcCheckExprNC (L loc expr) res_ty+tcPolyExprNC (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)+ do { traceTc "tcPolyExprNC" (ppr res_ty)+ ; (wrap, expr') <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty ->+ tcExpr expr res_ty ; return $ L loc (mkHsWrap wrap expr') } ---------------@@ -134,6 +141,30 @@ ; return (L loc (applyHsArgs fun args), ty) } ---------------+tcCheckMonoExpr, tcCheckMonoExprNC+ :: LHsExpr GhcRn -- Expression to type check+ -> TcRhoType -- Expected type+ -- Definitely no foralls at the top+ -> TcM (LHsExpr GhcTc)+tcCheckMonoExpr expr res_ty = tcMonoExpr expr (mkCheckExpType res_ty)+tcCheckMonoExprNC expr res_ty = tcMonoExprNC expr (mkCheckExpType res_ty)++tcMonoExpr, tcMonoExprNC+ :: LHsExpr GhcRn -- Expression to type check+ -> ExpRhoType -- Expected type+ -- Definitely no foralls at the top+ -> TcM (LHsExpr GhcTc)++tcMonoExpr expr res_ty+ = addExprCtxt expr $+ tcMonoExprNC expr res_ty++tcMonoExprNC (L loc expr) res_ty+ = setSrcSpan loc $+ do { expr' <- tcExpr expr res_ty+ ; return (L loc expr') }++--------------- tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType) -- Infer a *rho*-type. The return type is always instantiated. tcInferRho le = addExprCtxt le (tcInferRhoNC le)@@ -144,15 +175,11 @@ ; 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@@ -193,8 +220,8 @@ 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)+ \[arg_ty] [arg_mult] ->+ tcScalingUsage arg_mult $ tcLExpr expr (mkCheckExpType arg_ty) ; return (NegApp x expr' neg_expr') } tcExpr e@(HsIPVar _ x) res_ty@@ -241,7 +268,7 @@ (mkEmptyWildCardBndrs (L loc (HsTyLit noExtField (HsStrTy NoSourceText l)))) tcExpr (HsLam x match) res_ty- = do { (match', wrap) <- tcMatchLambda herald match_ctxt match res_ty+ = do { (wrap, match') <- tcMatchLambda herald match_ctxt match res_ty ; return (mkHsWrap wrap (HsLam x match')) } where match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody }@@ -252,7 +279,7 @@ text "has"] tcExpr e@(HsLamCase x matches) res_ty- = do { (matches', wrap)+ = do { (wrap, matches') <- tcMatchLambda msg match_ctxt matches res_ty -- The laziness annotation is because we don't want to fail here -- if there are multiple arguments@@ -335,8 +362,15 @@ ; 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+ matchActualFunTysRho doc orig1 (Just (unLoc arg1)) 1 arg1_ty + ; mult_wrap <- tcSubMult AppOrigin Many (scaledMult arg2_sigma)+ -- See Note [tcSubMult's wrapper] in TcUnify.+ --+ -- When ($) becomes multiplicity-polymorphic, then the above check will+ -- need to go. But in the meantime, it would produce ill-typed+ -- desugared code to accept linear functions to the left of a ($).+ -- We have (arg1 $ arg2) -- So: arg1_ty = arg2_ty -> op_res_ty -- where arg2_sigma maybe polymorphic; that's the point@@ -347,11 +381,11 @@ -- ($) :: 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+ ; _ <- unifyKind (Just (XHsType $ NHsCoreTy (scaledThing arg2_sigma)))+ (tcTypeKind (scaledThing 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)+ -- (because otherwise matchActualFunTysRho would fail) -- So this 'unifyKind' will either succeed with Refl, or will -- produce an insoluble constraint * ~ #, which we'll report later. @@ -360,14 +394,14 @@ ; op_id <- tcLookupId op_name ; let op' = L loc (mkHsWrap (mkWpTyApps [ getRuntimeRep op_res_ty- , arg2_sigma+ , scaledThing 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'+ expr' = OpApp fix (mkLHsWrap (wrap_arg1 <.> mult_wrap) arg1') op' arg2' ; tcWrapResult expr expr' op_res_ty res_ty } @@ -385,7 +419,8 @@ ; (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+ <- matchActualFunTysRho (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.@@ -404,13 +439,14 @@ 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+ ; (wrap_fun, [Scaled arg1_mult arg1_ty, arg2_ty], op_res_ty)+ <- matchActualFunTysRho (mk_op_msg op) fn_orig+ (Just (unLoc op)) 2 op_ty ; arg2' <- tcArg (unLoc op) arg2 arg2_ty 2- ; return ( mkHsWrap wrap_res $- SectionR x (mkLHsWrap wrap_fun op') arg2' ) }+ ; let expr' = SectionR x (mkLHsWrap wrap_fun op') arg2'+ act_res_ty = mkVisFunTy arg1_mult arg1_ty op_res_ty+ ; tcWrapResultMono expr expr' act_res_ty res_ty }+ where fn_orig = lexprCtOrigin op -- It's important to use the origin of 'op', so that call-stacks@@ -424,13 +460,12 @@ | 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+ <- matchActualFunTysRho (mk_op_msg op) fn_orig+ (Just (unLoc op)) n_reqd_args op_ty ; arg1' <- tcArg (unLoc op) arg1 arg1_ty 1- ; return ( mkHsWrap wrap_res $- SectionL x arg1' (mkLHsWrap wrap_fn op') ) }+ ; let expr' = SectionL x arg1' (mkLHsWrap wrap_fn op')+ act_res_ty = mkVisFunTys arg_tys op_res_ty+ ; tcWrapResultMono expr expr' act_res_ty res_ty } where fn_orig = lexprCtOrigin op -- It's important to use the origin of 'op', so that call-stacks@@ -460,27 +495,29 @@ ; 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) }+ ; let expr' = ExplicitTuple x tup_args1 boxity+ missing_tys = [Scaled mult ty | (L _ (Missing (Scaled mult _)), ty) <- zip tup_args1 arg_tys] + -- See Note [Linear fields generalization]+ act_res_ty+ = mkVisFunTys missing_tys (mkTupleTy1 boxity arg_tys)+ -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make++ ; traceTc "ExplicitTuple" (ppr act_res_ty $$ ppr res_ty)++ ; tcWrapResultMono expr expr' act_res_ty res_ty }+ 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))+ ; expr' <- tcCheckPolyExpr expr (arg_tys' `getNth` (alt - 1)) ; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) } -- This will see the empty list only when -XOverloadedLists.@@ -496,13 +533,19 @@ Just fln -> do { ((exprs', elt_ty), fln') <- tcSyntaxOp ListOrigin fln [synKnownType intTy, SynList] res_ty $- \ [elt_ty] ->+ \ [elt_ty] [_int_mul, list_mul] ->+ -- We ignore _int_mul because the integer (first+ -- argument of fromListN) is statically known: it+ -- is desugared to a literal. Therefore there is+ -- no variable of which to scale the usage in that+ -- first argument, and `_int_mul` is completely+ -- free in this expression. do { exprs' <-- mapM (tc_elt elt_ty) exprs+ mapM (tcScalingUsage list_mul . 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+ where tc_elt elt_ty expr = tcCheckPolyExpr expr elt_ty {- ************************************************************************@@ -527,10 +570,20 @@ -- -- 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+ let mult = Many+ -- There is not yet syntax or inference mechanism for case+ -- expressions to be anything else than unrestricted. + -- Typecheck the scrutinee. We use tcInferRho but tcInferSigma+ -- would also be possible (tcMatchesCase accepts sigma-types)+ -- Interesting litmus test: do these two behave the same?+ -- case id of {..}+ -- case (\v -> v) of {..}+ -- This design choice is discussed in #17790+ ; (scrut', scrut_ty) <- tcScalingUsage mult $ tcInferRho scrut+ ; traceTc "HsCase" (ppr scrut_ty)- ; matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty+ ; matches' <- tcMatchesCase match_ctxt (Scaled mult scrut_ty) matches res_ty ; return (HsCase x scrut' matches') } where match_ctxt = MC { mc_what = CaseAlt,@@ -542,17 +595,18 @@ -- 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+ ; (u1,b1') <- tcCollectingUsage $ tcLExpr b1 res_ty+ ; (u2,b2') <- tcCollectingUsage $ tcLExpr b2 res_ty+ ; tcEmitBindingUsage (supUE u1 u2) ; 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+ \ [pred_ty, b1_ty, b2_ty] [pred_mult, b1_mult, b2_mult] ->+ do { pred' <- tcScalingUsage pred_mult $ tcCheckPolyExpr pred pred_ty+ ; b1' <- tcScalingUsage b1_mult $ tcCheckPolyExpr b1 b1_ty+ ; b2' <- tcScalingUsage b2_mult $ tcCheckPolyExpr b2 b2_ty ; return (pred', b1', b2') } ; return (HsIf x fun' pred' b1' b2') } @@ -591,7 +645,7 @@ addErrCtxt (hang (text "In the body of a static form:") 2 (ppr expr) ) $- tcCheckExprNC expr expr_ty+ tcCheckPolyExprNC 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@@ -637,26 +691,32 @@ ; checkMissingFields con_like rbinds ; (con_expr, con_sigma) <- tcInferId con_name- ; (con_wrap, con_tau) <-- topInstantiate (OccurrenceOf con_name) con_sigma+ ; (con_wrap, con_tau) <- topInstantiate orig 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' } } }+ ; case conLikeWrapId_maybe con_like of {+ Nothing -> nonBidirectionalErr (conLikeName con_like) ;+ Just con_id -> + do { rbinds' <- tcRecordBinds con_like (map scaledThing arg_tys) rbinds+ -- It is currently not possible for a record to have+ -- multiplicities. When they do, `tcRecordBinds` will take+ -- scaled types instead. Meanwhile, it's safe to take+ -- `scaledThing` above, as we know all the multiplicities are+ -- Many.+ ; let rcon_tc = RecordConTc+ { rcon_con_like = con_like+ , rcon_con_expr = mkHsWrap con_wrap con_expr }+ expr' = RecordCon { rcon_ext = rcon_tc+ , rcon_con_name = L loc con_id+ , rcon_flds = rbinds' }++ ; tcWrapResultMono expr expr' actual_res_ty res_ty } } }+ where+ orig = OccurrenceOf con_name+ {- Note [Type of a record update] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -795,7 +855,20 @@ 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+ (record_expr', record_rho) <- tcScalingUsage Many $ tcInferRho record_expr+ -- Record update drops some of the content of the record (namely the+ -- content of the field being updated). As a consequence, unless the+ -- field being updated is unrestricted in the record, or we need an+ -- unrestricted record. Currently, we simply always require an+ -- unrestricted record.+ --+ -- Consider the following example:+ --+ -- data R a = R { self :: a }+ -- bad :: a ⊸ ()+ -- bad x = let r = R x in case r { self = () } of { R x' -> x' }+ --+ -- This should definitely *not* typecheck. -- STEP -1 See Note [Disambiguating record fields] -- After this we know that rbinds is unambiguous@@ -852,8 +925,13 @@ -- Take apart a representative constructor ; let con1 = ASSERT( not (null relevant_cons) ) head relevant_cons- (con1_tvs, _, _, _prov_theta, req_theta, con1_arg_tys, _)+ (con1_tvs, _, _, _prov_theta, req_theta, scaled_con1_arg_tys, _) = conLikeFullSig con1+ con1_arg_tys = map scaledThing scaled_con1_arg_tys+ -- We can safely drop the fields' multiplicities because+ -- they are currently always 1: there is no syntax for record+ -- fields with other multiplicities yet. This way we don't need+ -- to handle it in the rest of the function con1_flds = map flLabel $ conLikeFieldLabels con1 con1_tv_tys = mkTyVarTys con1_tvs con1_res_ty = case mtycon of@@ -906,8 +984,6 @@ 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@@ -937,17 +1013,17 @@ ; 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 }} }+ ; let upd_tc = RecordUpdTc { rupd_cons = relevant_cons+ , rupd_in_tys = scrut_inst_tys+ , rupd_out_tys = result_inst_tys+ , rupd_wrap = req_wrap }+ expr' = RecordUpd { rupd_expr = mkLHsWrap fam_co $+ mkLHsWrapCo co_scrut record_expr'+ , rupd_flds = rbinds'+ , rupd_ext = upd_tc } + ; tcWrapResult expr expr' rec_res_ty res_ty }+ tcExpr e@(HsRecFld _ f) res_ty = tcCheckRecSelId e f res_ty @@ -1037,36 +1113,36 @@ -> TcM (HsExpr GhcTc) tcArithSeq witness seq@(From expr) res_ty- = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty- ; expr' <- tcCheckExpr expr elt_ty+ = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty+ ; expr' <-tcScalingUsage elt_mult $ tcCheckPolyExpr 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+ = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty+ ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty+ ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr 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+ = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty+ ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty+ ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr 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+ = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty+ ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty+ ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty+ ; expr3' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr3 elt_ty ; eft <- newMethodFromName (ArithSeqOrigin seq) enumFromThenToName [elt_ty] ; return $ mkHsWrap wrap $@@ -1074,16 +1150,16 @@ ----------------- arithSeqEltType :: Maybe (SyntaxExpr GhcRn) -> ExpRhoType- -> TcM (HsWrapper, TcType, Maybe (SyntaxExpr GhcTc))+ -> TcM (HsWrapper, Mult, 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) }+ ; return (mkWpCastN coi, One, elt_ty, Nothing) } arithSeqEltType (Just fl) res_ty- = do { (elt_ty, fl')+ = do { ((elt_mult, elt_ty), fl') <- tcSyntaxOp ListOrigin fl [SynList] res_ty $- \ [elt_ty] -> return elt_ty- ; return (idHsWrapper, elt_ty, Just fl') }+ \ [elt_ty] [elt_mult] -> return (elt_mult, elt_ty)+ ; return (idHsWrapper, elt_mult, elt_ty, Just fl') } {- ************************************************************************@@ -1251,13 +1327,11 @@ 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 { (tc_args, actual_res_ty) <- tcArgs rn_fun fun_sigma rn_args ; return (tc_fun, tc_args, actual_res_ty) }@@ -1316,7 +1390,7 @@ _ -> False go :: Int -- Which argment number this is (incl type args)- -> [TcSigmaType] -- Value args to which applied so far+ -> [Scaled 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)@@ -1364,9 +1438,9 @@ _ -> 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+ = do { (wrap, arg_ty, res_ty)+ <- matchActualFunTySigma herald fun_orig (Just fun)+ (n_val_args, so_far) 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'@@ -1461,25 +1535,25 @@ ---------------- tcArg :: HsExpr GhcRn -- The function (for error messages) -> LHsExpr GhcRn -- Actual arguments- -> TcSigmaType -- expected arg type+ -> Scaled 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' }+tcArg fun arg (Scaled mult ty) arg_no+ = addErrCtxt (funAppCtxt fun arg arg_no) $+ do { traceTc "tcArg" $+ vcat [ ppr arg_no <+> text "of" <+> ppr fun+ , text "arg type:" <+> ppr ty+ , text "arg:" <+> ppr arg ]+ ; tcScalingUsage mult $ tcCheckPolyExprNC arg ty } ---------------- 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+ go (L l (Missing {}), arg_ty) = do { mult <- newFlexiTyVarTy multiplicityTy+ ; return (L l (Missing (Scaled mult arg_ty))) }+ go (L l (Present x expr), arg_ty) = do { expr' <- tcCheckPolyExpr expr arg_ty ; return (L l (Present x expr')) } ---------------------------@@ -1488,7 +1562,10 @@ -> SyntaxExprRn -> [SyntaxOpType] -- ^ shape of syntax operator arguments -> ExpRhoType -- ^ overall result type- -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments+ -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ Type check any arguments,+ -- takes a type per hole and a+ -- multiplicity per arrow in+ -- the shape. -> TcM (a, SyntaxExprTc) -- ^ Typecheck a syntax operator -- The operator is a variable or a lambda at this stage (i.e. renamer@@ -1502,7 +1579,7 @@ -> SyntaxExprRn -> [SyntaxOpType] -> SyntaxOpType- -> ([TcSigmaType] -> TcM a)+ -> ([TcSigmaType] -> [Mult] -> TcM a) -> TcM (a, SyntaxExprTc) tcSyntaxOpGen orig (SyntaxExprRn op) arg_tys res_ty thing_inside = do { (expr, sigma) <- tcInferAppHead op@@ -1531,36 +1608,36 @@ tcSynArgE :: CtOrigin -> TcSigmaType -> SyntaxOpType -- ^ shape it is expected to have- -> ([TcSigmaType] -> TcM a) -- ^ check the arguments+ -> ([TcSigmaType] -> [Mult] -> 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 ->+ <- 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]+ = 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]+ = 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]+ ; 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) $+ = do { ( match_wrapper -- :: (arg_ty -> res_ty) "->" rho_ty+ , ( ( (result, arg_ty, res_ty, op_mult)+ , res_wrapper ) -- :: res_ty_out "->" res_ty+ , arg_wrapper1, [], arg_wrapper2 ) ) -- :: arg_ty "->" arg_ty_out+ <- matchExpectedFunTys herald GenSigCtxt 1 (mkCheckExpType rho_ty) $ \ [arg_ty] res_ty ->- do { arg_tc_ty <- expTypeToType arg_ty+ do { arg_tc_ty <- expTypeToType (scaledThing arg_ty) ; res_tc_ty <- expTypeToType res_ty -- another nested arrow is too much for now,@@ -1571,24 +1648,25 @@ , text "Too many nested arrows in SyntaxOpType" $$ pprCtOrigin orig ) + ; let arg_mult = scaledMult arg_ty ; tcSynArgA orig arg_tc_ty [] arg_shape $- \ arg_results ->+ \ arg_results arg_res_mults -> 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) }}+ \ res_results res_res_mults ->+ do { result <- thing_inside (arg_results ++ res_results) ([arg_mult] ++ arg_res_mults ++ res_res_mults)+ ; return (result, arg_tc_ty, res_tc_ty, arg_mult) }} ; return ( result , match_wrapper <.> mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper- arg_ty res_ty doc ) }+ (Scaled op_mult 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 []+ ; result <- thing_inside [] [] ; return (result, wrap) } -- works on "actual" types, instantiating where necessary@@ -1597,34 +1675,35 @@ -> TcSigmaType -> [SyntaxOpType] -- ^ argument shapes -> SyntaxOpType -- ^ result shape- -> ([TcSigmaType] -> TcM a) -- ^ check the arguments+ -> ([TcSigmaType] -> [Mult] -> 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+ <- matchActualFunTysRho 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_args_e (map scaledThing arg_tys) arg_shapes $ \ arg_results arg_res_mults -> tc_syn_arg res_ty res_shape $ \ res_results ->- thing_inside (arg_results ++ res_results)+ thing_inside (arg_results ++ res_results) (map scaledMult arg_tys ++ arg_res_mults) ; 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)+ -> ([TcSigmaType] -> [Mult] -> 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)+ <- tcSynArgE orig arg_ty arg_shape $ \ arg1_results arg1_mults ->+ tc_syn_args_e arg_tys arg_shapes $ \ args_results args_mults ->+ thing_inside (arg1_results ++ args_results) (arg1_mults ++ args_mults) ; return (result, arg_wrap : arg_wraps) }- tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside []+ tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside [] [] tc_syn_arg :: TcSigmaType -> SyntaxOpType -> ([TcSigmaType] -> TcM a)@@ -1634,7 +1713,7 @@ = 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+ = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty -- inst_wrap :: res_ty "->" rho_ty ; result <- thing_inside [rho_ty] ; return (result, inst_wrap) }@@ -1648,7 +1727,7 @@ 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+ = do { wrap <- tcSubType orig GenSigCtxt res_ty the_ty ; result <- thing_inside [] ; return (result, wrap) } @@ -1687,22 +1766,10 @@ 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) }+ do { let poly_ty = idType poly_id+ ; (wrap, expr') <- tcSkolemiseScoped ExprSigCtxt poly_ty $ \rho_ty ->+ tcCheckMonoExprNC expr rho_ty+ ; return (mkLHsWrap wrap expr', poly_ty) } tcExprSig expr sig@(PartialSig { psig_name = name, sig_loc = loc }) = setSrcSpan loc $ -- Sets the location for the implication constraint@@ -1711,7 +1778,7 @@ do { sig_inst <- tcInstSig sig ; expr' <- tcExtendNameTyVarEnv (mapSnd binderVar $ sig_inst_skols sig_inst) $ tcExtendNameTyVarEnv (sig_inst_wcs sig_inst) $- tcCheckExprNC expr (sig_inst_tau sig_inst)+ tcCheckPolyExprNC expr (sig_inst_tau sig_inst) ; return (expr', sig_inst) } -- See Note [Partial expression signatures] ; let tau = sig_inst_tau sig_inst@@ -1735,7 +1802,7 @@ 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+ else tcSubTypeSigma ExprSigCtxt inferred_sigma my_sigma ; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma) ; let poly_wrap = wrap@@ -1799,7 +1866,7 @@ 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+ Just (arg, _) -> do { sel_name <- disambiguateSelector lbl (scaledThing arg) ; tcCheckRecSelId rn_expr (Unambiguous sel_name lbl) res_ty } @@ -1844,6 +1911,7 @@ ATcId { tct_id = id } -> do { check_naughty id -- Note [Local record selectors] ; checkThLocalId id+ ; tcEmitBindingUsage $ unitUE id_name One ; return_id id } AGlobal (AnId id)@@ -1863,26 +1931,48 @@ 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)+ = do { let tvs = dataConUserTyVarBinders con+ theta = dataConOtherTheta con+ args = dataConOrigArgTys con+ res = dataConOrigResTy con - | 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') }+ -- See Note [Linear fields generalization]+ ; mul_vars <- newFlexiTyVarTys (length args) multiplicityTy+ ; let scaleArgs args' = zipWithEqual "return_data_con" combine mul_vars args'+ combine var (Scaled One ty) = Scaled var ty+ combine _ scaled_ty = scaled_ty+ -- The combine function implements the fact that, as+ -- described in Note [Linear fields generalization], if a+ -- field is not linear (last line) it isn't made polymorphic. - where- con_ty = dataConUserType con- stupid_theta = dataConStupidTheta con+ etaWrapper arg_tys = foldr (\scaled_ty wr -> WpFun WpHole wr scaled_ty empty) WpHole arg_tys + -- See Note [Instantiating stupid theta]+ ; let shouldInstantiate = (not (null (dataConStupidTheta con)) ||+ isKindLevPoly (tyConResKind (dataConTyCon con)))+ ; case shouldInstantiate of+ True -> do { (subst, tvs') <- newMetaTyVars (binderVars tvs)+ ; let tys' = mkTyVarTys tvs'+ theta' = substTheta subst theta+ args' = substScaledTys subst args+ res' = substTy subst res+ ; wrap <- instCall (OccurrenceOf id_name) tys' theta'+ ; let scaled_arg_tys = scaleArgs args'+ eta_wrap = etaWrapper scaled_arg_tys+ ; addDataConStupidTheta con tys'+ ; return ( mkHsWrap (eta_wrap <.> wrap)+ (HsConLikeOut noExtField (RealDataCon con))+ , mkVisFunTys scaled_arg_tys res')+ }+ False -> let scaled_arg_tys = scaleArgs args+ wrap1 = mkWpTyApps (mkTyVarTys $ binderVars tvs)+ eta_wrap = etaWrapper (map unrestricted theta ++ scaled_arg_tys)+ wrap2 = mkWpTyLams $ binderVars tvs+ in return ( mkHsWrap (wrap2 <.> eta_wrap <.> wrap1)+ (HsConLikeOut noExtField (RealDataCon con))+ , mkInvisForAllTys tvs $ mkInvisFunTysMany theta $ mkVisFunTys scaled_arg_tys res)+ }+ check_naughty id | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl) | otherwise = return ()@@ -1900,7 +1990,7 @@ tcUnboundId rn_expr occ res_ty = do { ty <- newOpenFlexiTyVarTy -- Allow Int# etc (#12531) ; name <- newSysName occ- ; let ev = mkLocalId name ty+ ; let ev = mkLocalId name Many ty ; emitNewExprHole occ ev ty ; tcWrapResultO (UnboundOccurrenceOf occ) rn_expr (HsVar noExtField (noLoc ev)) ty res_ty }@@ -1954,6 +2044,42 @@ a data constructor sporting a stupid theta. I won't feel so bad for the users that complain. +Note [Linear fields generalization]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As per Note [Polymorphisation of linear fields], linear field of data+constructors get a polymorphic type when the data constructor is used as a term.++ Just :: forall {p} a. a #p-> Maybe a++This rule is known only to the typechecker: Just keeps its linear type in Core.++In order to desugar this generalised typing rule, we simply eta-expand:++ \a (x # p :: a) -> Just @a x++has the appropriate type. We insert these eta-expansion with WpFun wrappers.++A small hitch: if the constructor is levity-polymorphic (unboxed tuples, sums,+certain newtypes with -XUnliftedNewtypes) then this strategy produces++ \r1 r2 a b (x # p :: a) (y # q :: b) -> (# a, b #)++Which has type++ forall r1 r2 a b. a #p-> b #q-> (# a, b #)++Which violates the levity-polymorphism restriction see Note [Levity polymorphism+checking] in DsMonad.++So we really must instantiate r1 and r2 rather than quantify over them. For+simplicity, we just instantiate the entire type, as described in Note+[Instantiating stupid theta]. It breaks visible type application with unboxed+tuples, sums and levity-polymorphic newtypes, but this doesn't appear to be used+anywhere.++A better plan: let's force all representation variable to be *inferred*, so that+they are not subject to visible type applications. Then we can instantiate+inferred argument eagerly. -} isTagToEnum :: HsExpr GhcTc -> Bool@@ -2020,8 +2146,8 @@ 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+-- in 'GHC.Rename.Splice.checkThLocalName', so don't repeat that here.+-- Here we just add constraints fro cross-stage lifting checkThLocalId id = do { mb_local_use <- getStageAndBindLevel (idName id) ; case mb_local_use of@@ -2104,7 +2230,7 @@ errors in a polymorphic situation. If this check fails (which isn't impossible) we get another chance; see-Note [Converting strings] in Convert.hs+Note [Converting strings] in "GHC.ThToHs" Local record selectors ~~~~~~~~~~~~~~~~~~~~~~@@ -2131,7 +2257,7 @@ ++ prov_theta ++ req_theta flds = conLikeFieldLabels con- fixed_tvs = exactTyCoVarsOfTypes fixed_tys+ fixed_tvs = exactTyCoVarsOfTypes (map scaledThing fixed_tys) -- fixed_tys: See Note [Type of a record update] `unionVarSet` tyCoVarsOfTypes theta -- Universally-quantified tyvars that@@ -2476,10 +2602,10 @@ 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+ do { rhs' <- tcCheckPolyExprNC rhs field_ty ; let field_id = mkUserLocal (nameOccName sel_name) (nameUnique sel_name)- field_ty loc+ Many 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@@ -2584,7 +2710,7 @@ -- 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.+ -- an ExpRhoTy, i.e., it's already instantiated. (_, _, env_tau) = tcSplitSigmaTy env' (args_fun, res_fun) = tcSplitFunTys fun_tau (args_env, res_env) = tcSplitFunTys env_tau
compiler/GHC/Tc/Gen/Expr.hs-boot view
@@ -4,32 +4,43 @@ 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 )+import GHC.Core.Type ( Mult )+import GHC.Hs.Extension ( GhcRn, GhcTc ) -tcCheckExpr :: LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)+tcCheckPolyExpr ::+ LHsExpr GhcRn+ -> TcSigmaType+ -> TcM (LHsExpr GhcTc) -tcLExpr, tcLExprNC- :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)-tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId)+tcMonoExpr, tcMonoExprNC ::+ LHsExpr GhcRn+ -> ExpRhoType+ -> TcM (LHsExpr GhcTc)+tcCheckMonoExpr, tcCheckMonoExprNC ::+ LHsExpr GhcRn+ -> TcRhoType+ -> TcM (LHsExpr GhcTc) -tcInferRho, tcInferRhoNC- :: LHsExpr GhcRn-> TcM (LHsExpr GhcTcId, TcRhoType)+tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) -tcInferSigma :: LHsExpr GhcRn-> TcM (LHsExpr GhcTcId, TcSigmaType)+tcInferSigma :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType) +tcInferRho, tcInferRhoNC ::+ LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType)+ tcSyntaxOp :: CtOrigin -> SyntaxExprRn -> [SyntaxOpType] -- ^ shape of syntax operator arguments -> ExpType -- ^ overall result type- -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments+ -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ Type check any arguments -> TcM (a, SyntaxExprTc) tcSyntaxOpGen :: CtOrigin -> SyntaxExprRn -> [SyntaxOpType] -> SyntaxOpType- -> ([TcSigmaType] -> TcM a)+ -> ([TcSigmaType] -> [Mult] -> TcM a) -> TcM (a, SyntaxExprTc) -tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTcId)+tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTc)
compiler/GHC/Tc/Gen/Foreign.hs view
@@ -7,7 +7,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} --- | Typechecking \tr{foreign} declarations+-- | Typechecking @foreign@ declarations -- -- A foreign declaration is used to either give an externally -- implemented function a Haskell type (and calling interface) or@@ -46,6 +46,7 @@ import GHC.Core.FamInstEnv import GHC.Core.Coercion import GHC.Core.Type+import GHC.Core.Multiplicity import GHC.Types.ForeignCall import GHC.Utils.Error import GHC.Types.Id@@ -93,20 +94,6 @@ 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@@ -120,33 +107,31 @@ normaliseFfiType' fam_envs ty normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)-normaliseFfiType' env ty0 = go initRecTc ty0+normaliseFfiType' env ty0 = go Representational initRecTc ty0 where- go :: RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)- go rec_nts ty+ go :: Role -> RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)+ go role rec_nts ty | Just ty' <- tcView ty -- Expand synonyms- = go rec_nts ty'+ = go role rec_nts ty' | Just (tc, tys) <- splitTyConApp_maybe ty- = go_tc_app rec_nts tc tys+ = go_tc_app role rec_nts tc tys | (bndrs, inner_ty) <- splitForAllVarBndrs ty , not (null bndrs)- = do (coi, nty1, gres1) <- go rec_nts inner_ty+ = do (coi, nty1, gres1) <- go role 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)+ = return (mkReflCo role ty, ty, emptyBag) - go_tc_app :: RecTcChecker -> TyCon -> [Type]+ go_tc_app :: Role -> RecTcChecker -> TyCon -> [Type] -> TcM (Coercion, Type, Bag GlobalRdrElt)- go_tc_app rec_nts tc tys+ go_tc_app role 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@@ -160,13 +145,13 @@ = do { rdr_env <- getGlobalRdrEnv ; case checkNewtypeFFI rdr_env tc of Nothing -> nothing- Just gre -> do { (co', ty', gres) <- go rec_nts' nt_rhs+ Just gre -> do { (co', ty', gres) <- go role 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+ , (co, ty) <- normaliseTcApp env role tc tys , not (isReflexiveCo co)- = do (co', ty', gres) <- go rec_nts ty+ = do (co', ty', gres) <- go role rec_nts ty return (mkTransCo co co', ty', gres) | otherwise@@ -174,19 +159,15 @@ where tc_key = getUnique tc children_only- = do xs <- mapM (go rec_nts) tys+ = do xs <- zipWithM (\ty r -> go r rec_nts ty) tys (tyConRolesX role tc) 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'+ return ( mkTyConAppCo role tc cos , mkTyConApp tc tys', unionManyBags gres)- nt_co = mkUnbranchedAxInstCo Representational (newTyConCo tc) tys []+ nt_co = mkUnbranchedAxInstCo role (newTyConCo tc) tys [] nt_rhs = newTyConInstRhs tc tys ty = mkTyConApp tc tys- nothing = return (mkRepReflCo ty, ty, emptyBag)+ nothing = return (mkReflCo role ty, ty, emptyBag) checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt checkNewtypeFFI rdr_env tc@@ -251,12 +232,12 @@ -- 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+ id = mkLocalId nm Many 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+ ; imp_decl' <- tcCheckFIType (map scaledThing 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@@ -275,7 +256,7 @@ = 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)+ check (isFFILabelTy (mkVisFunTysMany arg_tys res_ty)) (illegalForeignTyErr Outputable.empty) cconv' <- checkCConv cconv return (CImport (L lc cconv') safety mh l src) @@ -287,7 +268,7 @@ checkCg checkCOrAsmOrLlvmOrInterp cconv' <- checkCConv cconv case arg_tys of- [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys+ [arg1_ty] -> do checkForeignArgs isFFIExternalTy (map scaledThing arg1_tys) checkForeignRes nonIOok checkSafe isFFIExportResultTy res1_ty checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty where@@ -305,7 +286,7 @@ 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+ let curried_res_ty = mkVisFunTysMany arg_tys res_ty check (isFFIDynTy curried_res_ty arg1_ty) (illegalForeignTyErr argument) checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys@@ -367,12 +348,12 @@ -} tcForeignExports :: [LForeignDecl GhcRn]- -> TcM (LHsBinds GhcTcId, [LForeignDecl GhcTcId], Bag GlobalRdrElt)+ -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt) tcForeignExports decls = getHooked tcForeignExportsHook tcForeignExports' >>= ($ decls) tcForeignExports' :: [LForeignDecl GhcRn]- -> TcM (LHsBinds GhcTcId, [LForeignDecl GhcTcId], Bag GlobalRdrElt)+ -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt) -- For the (Bag GlobalRdrElt) result, -- see Note [Newtype constructor usage in foreign declarations] tcForeignExports' decls@@ -388,7 +369,7 @@ = addErrCtxt (foreignDeclCtxt fo) $ do sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty- rhs <- tcCheckExpr (nlHsVar nm) sig_ty+ rhs <- tcCheckPolyExpr (nlHsVar nm) sig_ty (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty @@ -418,7 +399,7 @@ checkCg checkCOrAsmOrLlvm checkTc (isCLabelString str) (badCName str) cconv' <- checkCConv cconv- checkForeignArgs isFFIExternalTy arg_tys+ checkForeignArgs isFFIExternalTy (map scaledThing arg_tys) checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty return (CExport (L l (CExportStatic esrc str cconv')) src) where
compiler/GHC/Tc/Gen/HsType.hs view
@@ -31,3507 +31,3815 @@ 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 "GhclibHsVersions.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 <extra> <type>)--- prints In the type signature for 'f':--- f :: <type>--- The <extra> 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, mkInfForAllTys 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 (mkInfForAllTys 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 emitAnonTypeHole-on these anonymous wildcards. However, this would trigger-error/warning when an anonymous wildcard is passed in as a visible type-argument, which we do not want because users should be able to write-@_ 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.Type--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, (inv_tv_bndrs, ty'))- <- pushLevelAndCaptureConstraints $- bindExplicitTKBndrs_Skol hs_tvs $- tc_lhs_type mode ty exp_kind- -- Do not kind-generalise here! See Note [Kind generalisation]- -- Why exp_kind? See Note [Body kind of HsForAllTy]- ; let skol_info = ForAllSkol (ppr forall)- m_telescope = Just (sep (map ppr hs_tvs))-- ; tv_bndrs <- mapM construct_bndr inv_tv_bndrs-- ; emitResidualTvConstraint skol_info m_telescope (binderVars tv_bndrs) tclvl wanted-- ; return (mkForAllTys tv_bndrs ty') }- where- construct_bndr :: TcInvisTVBinder -> TcM TcTyVarBinder- construct_bndr (Bndr tv spec) = do { argf <- spec_to_argf spec- ; return $ mkTyVarBinder argf tv }-- -- See Note [Variable Specificity and Forall Visibility]- spec_to_argf :: Specificity -> TcM ArgFlag- spec_to_argf SpecifiedSpec = case fvf of- ForallVis -> return Required- ForallInvis -> return Specified- spec_to_argf InferredSpec = case fvf of- ForallVis -> do { addErrTc (hang (text "Unexpected inferred variable in visible forall binder:")- 2 (ppr forall))- ; return Required }- ForallInvis -> return Inferred--tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind- | null (unLoc ctxt)- = tc_lhs_type mode rn_ty exp_kind-- -- 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.Type--- See Note [Inferring tuple kinds]-tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind- -- (NB: not zonking before looking at exp_k, to avoid left-right bias)- | 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--{--Note [Variable Specificity and Forall Visibility]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A HsForAllTy contains a ForAllVisFlag to denote the visibility of the forall-binder. Furthermore, each bound variable also has a Specificity. Together these-determine the variable binders (ArgFlag) for each variable in the generated-ForAllTy type.--This table summarises this relation:----------------------------------------------------------------------------| User-written type ForAllVisFlag Specificity ArgFlag-|--------------------------------------------------------------------------| f :: forall a. type ForallInvis SpecifiedSpec Specified-| f :: forall {a}. type ForallInvis InferredSpec Inferred-| f :: forall a -> type ForallVis SpecifiedSpec Required-| f :: forall {a} -> type ForallVis InferredSpec /-| This last form is non-sensical and is thus rejected.-----------------------------------------------------------------------------For more information regarding the interpretation of the resulting ArgFlag, see-Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep.--}---------------------------------------------tc_fun_type :: TcTyMode -> LHsType GhcRn -> LHsType GhcRn -> TcKind- -> TcM TcType-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) $- emitAnonTypeHole 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 emitNamedTypeHole in tcHsPartialSigType on all HsWildCardBndrs?-The solution then is to neither rename nor include unnamed wildcards in HsWildCardBndrs,-but instead give every anonymous wildcard a fresh wild tyvar in tcAnonWildCardOcc.-And whenever we see a '@', we automatically turn on PartialTypeSignatures and-turn off hole constraint warnings, and do not call emitAnonTypeHole-under these conditions.-See related Note [Wildcards in visible type application] here and-Note [The wildcard story for types] in GHC.Hs.Type--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 Solo a = Solo a--Note that `Solo a` is *not* the same thing as `a`, since Solo is boxed and-lazy. Therefore, the presence of `Solo` matters semantically. On the other-hand, suppose we had a unary constraint tuple:-- class a => Solo% a--This compiles down a newtype (i.e., a cast) in Core, so `Solo% a` is-semantically equivalent to `a`. Therefore, a 1-tuple constraint would have-no user-visible impact, nor would it allow you to express anything that-you couldn't otherwise.--We could simply add Solo% for consistency with tuples (Solo) and unboxed-tuples (Solo#), but that would require even more magic to wire in another-magical class, so we opt not to do so. We must be careful, however, since-one can try to sneak in uses of unary constraint tuples through Template-Haskell, such as in this program (from #17511):-- f :: $(pure (ForallT [] [TupleT 1 `AppT` (ConT ''Show `AppT` ConT ''Int)]- (ConT ''String)))- -- f :: Solo% (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-"Solo% 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.Type-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 _ (Invisible _)) -> False- Named (Bndr _ Required) -> True- Anon InvisArg _ -> False- Anon VisArg _ -> True- in- zip_binders (zb:acc) ki' bs'--tooManyBindersErr :: Kind -> [LHsTyVarBndr () GhcRn] -> SDoc-tooManyBindersErr 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- :: (OutputableBndrFlag flag)- => [LHsTyVarBndr flag GhcRn]- -> TcM a- -> TcM ([VarBndr TyVar flag], 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_Q (tcHsQTyVarBndr ctxt_kind newSkolemTyVar)-bindExplicitTKBndrs_Q_Tv ctxt_kind = bindExplicitTKBndrsX_Q (tcHsQTyVarBndr ctxt_kind newTyVarTyVar)- -- See Note [Non-cloning for tyvar binders]--bindExplicitTKBndrsX_Q- :: (HsTyVarBndr () GhcRn -> TcM TcTyVar)- -> [LHsTyVarBndr () GhcRn]- -> TcM a- -> TcM ([TcTyVar], a) -- Returned [TcTyVar] are in 1-1 correspondence- -- with the passed-in [LHsTyVarBndr]-bindExplicitTKBndrsX_Q tc_tv hs_tvs thing_inside- = do { (tv_bndrs,res) <- bindExplicitTKBndrsX tc_tv hs_tvs thing_inside- ; return ((binderVars tv_bndrs),res) }--bindExplicitTKBndrsX :: (OutputableBndrFlag flag)- => (HsTyVarBndr flag GhcRn -> TcM TcTyVar)- -> [LHsTyVarBndr flag GhcRn]- -> TcM a- -> TcM ([VarBndr TyVar flag], a) -- Returned [TcTyVar] are in 1-1 correspondence- -- with the passed-in [LHsTyVarBndr]-bindExplicitTKBndrsX tc_tv hs_tvs thing_inside- = do { traceTc "bindExplicTKBndrs" (ppr hs_tvs)- ; go hs_tvs }- 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 ((Bndr tv (hsTyVarBndrFlag hs_tv)):tvs, res) }--------------------tcHsTyVarBndr :: (Name -> Kind -> TcM TyVar)- -> HsTyVarBndr flag GhcRn -> TcM TcTyVar-tcHsTyVarBndr new_tv (UserTyVar _ _ (L _ tv_nm))- = do { kind <- newMetaKindVar- ; new_tv tv_nm kind }-tcHsTyVarBndr new_tv (KindedTyVar _ _ (L _ tv_nm) lhs_kind)- = 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,InvisTVBinder)] -- 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_tvbndrs, (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) }-- ; let implicit_tvbndrs = map (mkTyVarBinder SpecifiedSpec) implicit_tvs-- -- No kind-generalization here:- ; kindGeneralizeNone (mkInvisForAllTys implicit_tvbndrs $- mkInvisForAllTys explicit_tvbndrs $- mkPhiTy theta $- tau)-- -- Spit out the wildcards (including the extra-constraints one)- -- as "hole" constraints, so that they'll be reported if necessary- -- See Note [Extra-constraint holes in partial type signatures]- ; mapM_ emitNamedTypeHole wcs-- -- Zonk, so that any nested foralls can "see" their occurrences- -- See Note [Checking partial type signatures], in- -- the bullet on Nested foralls.- ; theta <- mapM zonkTcType theta- ; tau <- zonkTcType tau-- -- We return a proper (Name,InvisTVBinder) environment, to be sure that- -- we bring the right name into scope in the function body.- -- Test case: partial-sigs/should_compile/LocalDefinitionBug- ; let tv_prs = (implicit_hs_tvs `zip` implicit_tvbndrs)- ++ (hsLTyVarNames explicit_hs_tvs `zip` explicit_tvbndrs)-- -- NB: checkValidType on the final inferred type will be- -- done later by checkInferredPolyId. We can't do it- -- 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- -> HsPatSigType 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--- See Note [Pattern signature binders and scoping] in GHC.Hs.Type------ This may emit constraints--- See Note [Recipe for checking a signature]-tcHsPatSigType ctxt- (HsPS { hsps_ext = HsPSRn { hsps_nwcs = sig_wcs, hsps_imp_tvs = sig_ns }- , hsps_body = hs_ty })- = addSigCtxt ctxt hs_ty $- do { sig_tkv_prs <- mapM new_implicit_tv sig_ns- ; (wcs, sig_ty)- <- 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) }-- ; mapM_ emitNamedTypeHole 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 [Typechecking pattern signature binders]- -- NB: tv's Name may be fresh (in the case of newPatSigTyVar)- ; return (name, tv) }--{- Note [Typechecking 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)) = <blah>--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 '<blah>' 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). <blah>).- -- <more blah>- -- When instantiating p's kind at occurrences of p in <more blah>- -- 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+ -- Type checking type and class decls, and instances thereof+ bindTyClTyVars, tcFamTyPats,+ etaExpandAlgTyCon, tcbVisibilities,++ -- tyvars+ zonkAndScopedSort,++ -- Kind-checking types+ -- No kind generalisation, no checkValidType+ InitialKindStrategy(..),+ SAKS_or_CUSK(..),+ kcDeclHeader,+ tcNamedWildCardBinders,+ tcHsLiftedType, tcHsOpenType,+ tcHsLiftedTypeNC, tcHsOpenTypeNC,+ tcInferLHsTypeKind, tcInferLHsType, tcInferLHsTypeUnsaturated,+ tcCheckLHsType,+ tcHsMbContext, tcHsContext, tcLHsPredType,+ failIfEmitsConstraints,+ solveEqualities, -- useful re-export++ kindGeneralizeAll, kindGeneralizeSome, kindGeneralizeNone,++ -- Sort-checking kinds+ tcLHsKindSig, checkDataKindSig, DataSort(..),+ checkClassKindSig,++ -- Multiplicity+ tcMult,++ -- Pattern type signatures+ tcHsPatSigType,++ -- Error messages+ funAppCtxt, addTyConFlavCtxt+ ) where++#include "GhclibHsVersions.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.Instantiate( tcInstInvisibleTyBinders )+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 ( tcInstInvisibleTyBindersN, tcInstInvisibleTyBinder )+import GHC.Core.Type+import GHC.Builtin.Types.Prim+import GHC.Types.Name.Env+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.FM+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 GHC.Data.Bag( unitBag )+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+* *+************************************************************************++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.++-}++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 <extra> <type>)+-- prints In the type signature for 'f':+-- f :: <type>+-- The <extra> 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 $+ tcLHsType hs_ty liftedTypeKind++ ; emitResidualTvConstraint skol_info 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) $+ do { (implic, ty) <- tc_hs_sig_type skol_info sig_ty (TheKind liftedTypeKind)+ ; emitImplication implic+ ; return ty }+ -- 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]+ ; (implic, ty) <- tc_hs_sig_type skol_info sig_ty (expectedKindInCtxt ctxt)++ -- Spit out the implication (and perhaps fail fast)+ -- See Note [Failure in local type signatures] in GHC.Tc.Solver+ ; emitFlatConstraints (mkImplicWC (unitBag implic))++ ; ty <- zonkTcType ty+ ; checkValidType ctxt ty+ ; traceTc "end tcHsSigType }" (ppr ty)+ ; return ty }+ where+ skol_info = SigTypeSkol ctxt++tc_hs_sig_type :: SkolemInfo -> LHsSigType GhcRn+ -> ContextKind -> TcM (Implication, 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 an implication for the unsolved constraints+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" $+ -- See Note [Failure in local type signatures]+ bindImplicitTKBndrs_Skol sig_vars $+ do { kind <- newExpectedKind ctxt_kind+ ; tcLHsType 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++ -- Build an implication for any as-yet-unsolved kind equalities+ -- See Note [Skolem escape in type signatures]+ ; implic <- buildTvImplication skol_info (kvs ++ spec_tkvs) tc_lvl wanted++ ; return (implic, mkInfForAllTys kvs ty1) }++{- Note [Skolem escape in type signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+tcHsSigType is tricky. Consider (T11142)+ foo :: forall b. (forall k (a :: k). SameKind a b) -> ()+This is ill-kinded becuase of a nested skolem-escape.++That will show up as an un-solvable constraint in the implication+returned by buildTvImplication in tc_hs_sig_type. See Note [Skolem+escape prevention] in GHC.Tc.Utils.TcType for why it is unsolvable+(the unification variable for b's kind is untouchable).++Then, in GHC.Tc.Solver.emitFlatConstraints (called from tcHsSigType)+we'll try to float out the constraint, be unable to do so, and fail.+See GHC.Tc.Solver Note [Failure in local type signatures] for more+detail on this.++The separation between tcHsSigType and tc_hs_sig_type is because+tcClassSigType wants to use the latter, but *not* fail fast, because+there are skolems from the class decl which are in scope; but it's fine+not to because tcClassDecl1 has a solveEqualities wrapped around all+the tcClassSigType calls.++That's why tcHsSigType does emitFlatConstraints (which fails fast) but+tcClassSigType just does emitImplication (which does not). Ugh.++c.f. see also Note [Skolem escape and forall-types]. The difference+is that we don't need to simplify at a forall type, only at the+top level of a signature.+-}++-- 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 { let mode = mkMode KindLevel+ ; kind <- tc_top_lhs_type mode ksig (expectedKindInCtxt ctxt)+ ; checkValidType ctxt kind+ ; return (name, kind) }+++tcTopLHsType :: LHsSigType GhcRn -> ContextKind -> TcM Type+tcTopLHsType hs_ty ctxt_kind+ = tc_top_lhs_type (mkMode TypeLevel) hs_ty ctxt_kind++tc_top_lhs_type :: 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+-- Used for both types and kinds+tc_top_lhs_type 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 (mkInfForAllTys 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 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, map scaledThing 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 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 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 { mode <- mkHoleMode TypeLevel HM_VTA+ -- HM_VTA: See Note [Wildcards in visible type application]+ ; ty <- addTypeCtxt hs_ty $+ solveLocalEqualities "tcHsTypeApp" $+ -- We are looking at a user-written type, very like a+ -- signature so we want to solve its equalities right now+ tcNamedWildCardBinders sig_wcs $ \ _ ->+ tc_lhs_type mode hs_ty 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 emitAnonTypeHole+on these anonymous wildcards. However, this would trigger+error/warning when an anonymous wildcard is passed in as a visible type+argument, which we do not want because users should be able to write+@_ 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.Type++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.++-}++tcFamTyPats :: TyCon+ -> HsTyPats GhcRn -- Patterns+ -> TcM (TcType, TcKind) -- (lhs_type, lhs_kind)+-- Check the LHS of a type/data family instance+-- e.g. type instance F ty1 .. tyn = ...+-- Used for both type and data families+tcFamTyPats fam_tc hs_pats+ = do { traceTc "tcFamTyPats {" $+ vcat [ ppr fam_tc, text "arity:" <+> ppr fam_arity ]++ ; mode <- mkHoleMode TypeLevel HM_FamPat+ -- HM_FamPat: See Note [Wildcards in family instances] in+ -- GHC.Rename.Module+ ; let fun_ty = mkTyConApp fam_tc []+ ; (fam_app, res_kind) <- tcInferTyApps mode 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))++{-+************************************************************************+* *+ 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 hs_ty = addTypeCtxt hs_ty $ tcHsOpenTypeNC hs_ty+tcHsLiftedType hs_ty = addTypeCtxt hs_ty $ tcHsLiftedTypeNC hs_ty++tcHsOpenTypeNC hs_ty = do { ek <- newOpenTypeKind; tcLHsType hs_ty ek }+tcHsLiftedTypeNC hs_ty = tcLHsType hs_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+ ; tcLHsType hs_ty ek }++tcInferLHsType :: LHsType GhcRn -> TcM TcType+tcInferLHsType hs_ty+ = do { (ty,_kind) <- tcInferLHsTypeKind hs_ty+ ; return ty }++tcInferLHsTypeKind :: LHsType GhcRn -> TcM (TcType, TcKind)+-- Called from outside: set the context+-- Eagerly instantiate any trailing invisible binders+tcInferLHsTypeKind lhs_ty@(L loc hs_ty)+ = addTypeCtxt lhs_ty $+ setSrcSpan loc $ -- Cover the tcInstInvisibleTyBinders+ do { (res_ty, res_kind) <- tc_infer_hs_type (mkMode TypeLevel) hs_ty+ ; tcInstInvisibleTyBinders res_ty res_kind }+ -- See Note [Do not always instantiate eagerly in types]++-- Used to check the argument of GHCi :kind+-- Allow and report wildcards, e.g. :kind T _+-- Do not saturate family applications: see Note [Dealing with :kind]+-- Does not instantiate eagerly; See Note [Do not always instantiate eagerly in types]+tcInferLHsTypeUnsaturated :: LHsType GhcRn -> TcM (TcType, TcKind)+tcInferLHsTypeUnsaturated hs_ty+ = addTypeCtxt hs_ty $+ do { mode <- mkHoleMode TypeLevel HM_Sig -- Allow and report holes+ ; case splitHsAppTys (unLoc hs_ty) of+ Just (hs_fun_ty, hs_args)+ -> do { (fun_ty, _ki) <- tcInferTyAppHead mode hs_fun_ty+ ; tcInferTyApps_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]+ Nothing -> tc_infer_lhs_type mode hs_ty }++{- 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 tcInferTyApps), 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 tcInferLHsTypeUnsaturated does a little special case for top level+applications. Actually the common case is a bare variable, as above.++Note [Do not always instantiate eagerly in types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Terms are eagerly instantiated. This means that if you say++ x = id++then `id` gets instantiated to have type alpha -> alpha. The variable+alpha is then unconstrained and regeneralized. But we cannot do this+in types, as we have no type-level lambda. So, when we are sure+that we will not want to regeneralize later -- because we are done+checking a type, for example -- we can instantiate. But we do not+instantiate at variables, nor do we in tcInferLHsTypeUnsaturated,+which is used by :kind in GHCi.++************************************************************************+* *+ 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.++-}++tcMult :: HsArrow GhcRn -> TcM Mult+tcMult hc = tc_mult (mkMode TypeLevel) hc++-- | 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_tyki'+--+-- This data type is purely local, not exported from this module+data TcTyMode+ = TcTyMode { mode_tyki :: TypeOrKind++ -- See Note [Levels for wildcards]+ -- Nothing <=> no wildcards expected+ , mode_holes :: Maybe (TcLevel, HoleMode)+ }++-- HoleMode says how to treat the occurrences+-- of anonymous wildcards; see tcAnonWildCardOcc+data HoleMode = HM_Sig -- Partial type signatures: f :: _ -> Int+ | HM_FamPat -- Family instances: F _ Int = Bool+ | HM_VTA -- Visible type and kind application:+ -- f @(Maybe _)+ -- Maybe @(_ -> _)++mkMode :: TypeOrKind -> TcTyMode+mkMode tyki = TcTyMode { mode_tyki = tyki, mode_holes = Nothing }++mkHoleMode :: TypeOrKind -> HoleMode -> TcM TcTyMode+mkHoleMode tyki hm+ = do { lvl <- getTcLevel+ ; return (TcTyMode { mode_tyki = tyki+ , mode_holes = Just (lvl,hm) }) }++kindLevel :: TcTyMode -> TcTyMode+kindLevel mode = mode { mode_tyki = KindLevel }++instance Outputable HoleMode where+ ppr HM_Sig = text "HM_Sig"+ ppr HM_FamPat = text "HM_FamPat"+ ppr HM_VTA = text "HM_VTA"++instance Outputable TcTyMode where+ ppr (TcTyMode { mode_tyki = tyki, mode_holes = hm })+ = text "TcTyMode" <+> braces (sep [ ppr tyki <> comma+ , ppr hm ])++{-+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) <- tcInferTyAppHead mode hs_fun_ty+ ; tcInferTyApps mode hs_fun_ty fun_ty hs_args }++tc_infer_hs_type mode (HsKindSig _ ty sig)+ = do { let mode' = mode { mode_tyki = KindLevel }+ ; sig' <- tc_lhs_kind_sig mode' 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++-- See Note [Typechecking NHsCoreTys]+tc_infer_hs_type _ (XHsType (NHsCoreTy ty))+ = do env <- getLclEnv+ let subst_prs = [ (nm, tv)+ | ATyVar nm tv <- nameEnvElts (tcl_env env) ]+ subst = mkTvSubst+ (mkInScopeSet $ mkVarSet $ map snd subst_prs)+ (listToUFM $ map (liftSnd mkTyVarTy) subst_prs)+ ty' = substTy subst 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) }++{-+Note [Typechecking NHsCoreTys]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+NHsCoreTy is an escape hatch that allows embedding Core Types in HsTypes.+As such, there's not much to be done in order to typecheck an NHsCoreTy,+since it's already been typechecked to some extent. There is one thing that+we must do, however: we must substitute the type variables from the tcl_env.+To see why, consider GeneralizedNewtypeDeriving, which is one of the main+clients of NHsCoreTy (example adapted from #14579):++ newtype T a = MkT a deriving newtype Eq++This will produce an InstInfo GhcPs that looks roughly like this:++ instance forall a_1. Eq a_1 => Eq (T a_1) where+ (==) = coerce @( a_1 -> a_1 -> Bool) -- The type within @(...) is an NHsCoreTy+ @(T a_1 -> T a_1 -> Bool) -- So is this+ (==)++This is then fed into the renamer. Since all of the type variables in this+InstInfo use Exact RdrNames, the resulting InstInfo GhcRn looks basically+identical. Things get more interesting when the InstInfo is fed into the+typechecker, however. GHC will first generate fresh skolems to instantiate+the instance-bound type variables with. In the example above, we might generate+the skolem a_2 and use that to instantiate a_1, which extends the local type+environment (tcl_env) with [a_1 :-> a_2]. This gives us:++ instance forall a_2. Eq a_2 => Eq (T a_2) where ...++To ensure that the body of this instance is well scoped, every occurrence of+the `a` type variable should refer to a_2, the new skolem. However, the+NHsCoreTys mention a_1, not a_2. Luckily, the tcl_env provides exactly the+substitution we need ([a_1 :-> a_2]) to fix up the scoping. We apply this+substitution to each NHsCoreTy and all is well:++ instance forall a_2. Eq a_2 => Eq (T a_2) where+ (==) = coerce @( a_2 -> a_2 -> Bool)+ @(T a_2 -> T a_2 -> Bool)+ (==)+-}++------------------------------------------+tcLHsType :: LHsType GhcRn -> TcKind -> TcM TcType+tcLHsType hs_ty exp_kind+ = tc_lhs_type (mkMode TypeLevel) hs_ty exp_kind++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 ty@(HsFunTy _ mult ty1 ty2) exp_kind+ | mode_tyki mode == KindLevel && not (isUnrestricted mult)+ = failWithTc (text "Linear arrows disallowed in kinds:" <+> ppr ty)+ | otherwise+ = tc_fun_type mode mult ty1 ty2 exp_kind++tc_hs_type mode (HsOpTy _ ty1 (L _ op) ty2) exp_kind+ | op `hasKey` funTyConKey+ = tc_fun_type mode HsUnrestrictedArrow ty1 ty2 exp_kind++--------- Foralls+tc_hs_type mode forall@(HsForAllTy { hst_tele = tele, hst_body = ty }) exp_kind+ = do { (tclvl, wanted, (tv_bndrs, ty'))+ <- pushLevelAndCaptureConstraints $+ bindExplicitTKTele_Skol_M mode tele $+ -- The _M variant passes on the mode from the type, to+ -- any wildards in kind signatures on the forall'd variables+ -- e.g. f :: _ -> Int -> forall (a :: _). blah+ tc_lhs_type mode ty exp_kind+ -- Why exp_kind? See Note [Body kind of HsForAllTy]++ -- Do not kind-generalise here! See Note [Kind generalisation]++ ; let skol_info = ForAllSkol (ppr forall) $ sep $ case tele of+ HsForAllVis { hsf_vis_bndrs = hs_tvs } ->+ map ppr hs_tvs+ HsForAllInvis { hsf_invis_bndrs = hs_tvs } ->+ map ppr hs_tvs+ tv_bndrs' = construct_bndrs tv_bndrs+ skol_tvs = binderVars tv_bndrs'+ ; implic <- buildTvImplication skol_info skol_tvs tclvl wanted+ ; emitImplication implic+ -- /Always/ emit this implication even if wanted is empty+ -- We need the implication so that we check for a bad telescope+ -- See Note [Skolem escape and forall-types]++ ; return (mkForAllTys tv_bndrs' ty') }+ where+ construct_bndrs :: Either [TcReqTVBinder] [TcInvisTVBinder]+ -> [TcTyVarBinder]+ construct_bndrs (Left req_tv_bndrs) =+ map (mkTyVarBinder Required . binderVar) req_tv_bndrs+ construct_bndrs (Right inv_tv_bndrs) =+ map tyVarSpecToBinder inv_tv_bndrs++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.Type+-- See Note [Inferring tuple kinds]+tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind+ -- (NB: not zonking before looking at exp_k, to avoid left-right bias)+ | 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_tyki 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 mode ty@(HsWildCardTy _) ek = tcAnonWildCardOcc mode ty ek++{-+Note [Variable Specificity and Forall Visibility]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A HsForAllTy contains an HsForAllTelescope to denote the visibility of the forall+binder. Furthermore, each invisible type variable binder also has a+Specificity. Together, these determine the variable binders (ArgFlag) for each+variable in the generated ForAllTy type.++This table summarises this relation:+----------------------------------------------------------------------------+| User-written type HsForAllTelescope Specificity ArgFlag+|---------------------------------------------------------------------------+| f :: forall a. type HsForAllInvis SpecifiedSpec Specified+| f :: forall {a}. type HsForAllInvis InferredSpec Inferred+| f :: forall a -> type HsForAllVis SpecifiedSpec Required+| f :: forall {a} -> type HsForAllVis InferredSpec /+| This last form is non-sensical and is thus rejected.+----------------------------------------------------------------------------++For more information regarding the interpretation of the resulting ArgFlag, see+Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep".+-}++------------------------------------------+tc_mult :: TcTyMode -> HsArrow GhcRn -> TcM Mult+tc_mult mode ty = tc_lhs_type mode (arrowToHsType ty) multiplicityTy+------------------------------------------+tc_fun_type :: TcTyMode -> HsArrow GhcRn -> LHsType GhcRn -> LHsType GhcRn -> TcKind+ -> TcM TcType+tc_fun_type mode mult ty1 ty2 exp_kind = case mode_tyki 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+ ; mult' <- tc_mult mode mult+ ; checkExpectedKind (HsFunTy noExtField mult ty1 ty2) (mkVisFunTy mult' 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+ ; mult' <- tc_mult mode mult+ ; checkExpectedKind (HsFunTy noExtField mult ty1 ty2) (mkVisFunTy mult' ty1' ty2')+ liftedTypeKind exp_kind }++{- Note [Skolem escape and forall-types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also Note [Checking telescopes].++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+buildTvImplication/emitImplication 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.++* We can't use emitResidualTvConstraint, because that has a fast-path+ for empty constraints. We can't take that fast path here, because+ we must do the bad-telescope check even if there are no inner wanted+ constraints. See Note [Checking telescopes] in+ GHC.Tc.Types.Constraint. Lacking this check led to #16247.+-}++{- *********************************************************************+* *+ 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 Solo a = Solo a++Note that `Solo a` is *not* the same thing as `a`, since Solo is boxed and+lazy. Therefore, the presence of `Solo` matters semantically. On the other+hand, suppose we had a unary constraint tuple:++ class a => Solo% a++This compiles down a newtype (i.e., a cast) in Core, so `Solo% a` is+semantically equivalent to `a`. Therefore, a 1-tuple constraint would have+no user-visible impact, nor would it allow you to express anything that+you couldn't otherwise.++We could simply add Solo% for consistency with tuples (Solo) and unboxed+tuples (Solo#), but that would require even more magic to wire in another+magical class, so we opt not to do so. We must be careful, however, since+one can try to sneak in uses of unary constraint tuples through Template+Haskell, such as in this program (from #17511):++ f :: $(pure (ForallT [] [TupleT 1 `AppT` (ConT ''Show `AppT` ConT ''Int)]+ (ConT ''String)))+ -- f :: Solo% (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+"Solo% 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)++---------------------------+tcInferTyAppHead :: 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 tcInferTyApps and family+-- saturation+tcInferTyAppHead mode (L _ (HsTyVar _ _ (L _ tv)))+ = tcTyVar mode tv+tcInferTyAppHead 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.+--+-- tcInferTyApps also arranges to saturate any trailing invisible arguments+-- of a type-family application, which is usually the right thing to do+-- tcInferTyApps_nosat does not do this saturation; it is used only+-- by ":kind" in GHCi+tcInferTyApps, tcInferTyApps_nosat+ :: TcTyMode+ -> LHsType GhcRn -- ^ Function (for printing only)+ -> TcType -- ^ Function+ -> [LHsTypeArg GhcRn] -- ^ Args+ -> TcM (TcType, TcKind) -- ^ (f args, args, result kind)+tcInferTyApps mode hs_ty fun hs_args+ = do { (f_args, res_k) <- tcInferTyApps_nosat mode hs_ty fun hs_args+ ; saturateFamApp f_args res_k }++tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args+ = do { traceTc "tcInferTyApps {" (ppr orig_hs_ty $$ ppr orig_hs_args)+ ; (f_args, res_k) <- go_init 1 fun orig_hs_args+ ; traceTc "tcInferTyApps }" (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 "tcInferTyApps (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+ ; arg_mode <- mkHoleMode KindLevel HM_VTA+ -- HM_VKA: see Note [Wildcards in visible kind application]+ ; ki_arg <- addErrCtxt (funAppCtxt orig_hs_ty hs_ki_arg n) $+ tc_lhs_type arg_mode hs_ki_arg exp_kind++ ; traceTc "tcInferTyApps (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 "tcInferTyApps (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 "tcInferTyApps (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 "tcInferTyApps (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 "tcInferTyApps (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 tcInferTyApps 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 tcInferTyApps. 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, instantiate 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') <- tcInstInvisibleTyBindersN 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') <- tcInstInvisibleTyBindersN 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 cxt = tc_hs_context (mkMode TypeLevel) cxt++tcLHsPredType :: LHsType GhcRn -> TcM PredType+tcLHsPredType pred = tc_lhs_pred (mkMode TypeLevel) pred++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+-- This does not instantiate. See Note [Do not always instantiate eagerly in types]+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_tyki 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_tyki 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 *).++-}++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+* *+********************************************************************* -}++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.Type+tcNamedWildCardBinders wc_names thing_inside+ = do { wcs <- mapM newNamedWildTyVar wc_names+ ; let wc_prs = wc_names `zip` wcs+ ; tcExtendNameTyVarEnv wc_prs $+ thing_inside wc_prs }++newNamedWildTyVar :: Name -> TcM TcTyVar+-- ^ New unification variable '_' for a wildcard+newNamedWildTyVar _name -- Currently ignoring the "_x" wildcard name used in the type+ = do { kind <- newMetaKindVar+ ; details <- newMetaDetails TauTv+ ; wc_name <- newMetaTyVarName (fsLit "w") -- See Note [Wildcard names]+ ; let tyvar = mkTcTyVar wc_name kind details+ ; traceTc "newWildTyVar" (ppr tyvar)+ ; return tyvar }++---------------------------+tcAnonWildCardOcc :: TcTyMode -> HsType GhcRn -> Kind -> TcM TcType+tcAnonWildCardOcc (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) })+ ty exp_kind+ -- hole_lvl: see Note [Checking partial type signatures]+ -- esp the bullet on nested forall types+ = do { kv_details <- newTauTvDetailsAtLevel hole_lvl+ ; kv_name <- newMetaTyVarName (fsLit "k")+ ; wc_details <- newTauTvDetailsAtLevel hole_lvl+ ; wc_name <- newMetaTyVarName (fsLit wc_nm)+ ; let kv = mkTcTyVar kv_name liftedTypeKind kv_details+ wc_kind = mkTyVarTy kv+ wc_tv = mkTcTyVar wc_name wc_kind wc_details++ ; traceTc "tcAnonWildCardOcc" (ppr hole_lvl <+> ppr emit_holes)+ ; when emit_holes $+ emitAnonTypeHole wc_tv+ -- Why the 'when' guard?+ -- See Note [Wildcards in visible kind application]++ -- You might think that this would always just unify+ -- wc_kind with exp_kind, so we could avoid even creating kv+ -- But the level numbers might not allow that unification,+ -- so we have to do it properly (T14140a)+ ; checkExpectedKind ty (mkTyVarTy wc_tv) wc_kind exp_kind }+ where+ -- See Note [Wildcard names]+ wc_nm = case hole_mode of+ HM_Sig -> "w"+ HM_FamPat -> "_"+ HM_VTA -> "w"++ emit_holes = case hole_mode of+ HM_Sig -> True+ HM_FamPat -> False+ HM_VTA -> False++tcAnonWildCardOcc mode ty _+-- mode_holes is Nothing. Should not happen, because renamer+-- should already have rejected holes in unexpected places+ = pprPanic "tcWildCardOcc" (ppr mode $$ ppr ty)++{- Note [Wildcard names]+~~~~~~~~~~~~~~~~~~~~~~~~+So we hackily use the mode_holes flag to control the name used+for wildcards:++* For proper holes (whether in a visible type application (VTA) or no),+ we rename the '_' to 'w'. This is so that we see variables like 'w0'+ or 'w1' in error messages, a vast improvement upon '_0' and '_1'. For+ example, we prefer+ Found type wildcard ‘_’ standing for ‘w0’+ over+ Found type wildcard ‘_’ standing for ‘_1’++ Even in the VTA case, where we do not emit an error to be printed, we+ want to do the renaming, as the variables may appear in other,+ non-wildcard error messages.++* However, holes in the left-hand sides of type families ("type+ patterns") stand for type variables which we do not care to name --+ much like the use of an underscore in an ordinary term-level+ pattern. When we spot these, we neither wish to generate an error+ message nor to rename the variable. We don't rename the variable so+ that we can pretty-print a type family LHS as, e.g.,+ F _ Int _ = ...+ and not+ F w1 Int w2 = ...++ See also Note [Wildcards in family instances] in+ GHC.Rename.Module. The choice of HM_FamPat is made in+ tcFamTyPats. There is also some unsavory magic, relying on that+ underscore, in GHC.Core.Coercion.tidyCoAxBndrsForUser.++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 emitNamedTypeHole in+tcHsPartialSigType on all HsWildCardBndrs? The solution 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 set mode_holes to HM_VKA, so that+we do not call emitAnonTypeHole in tcAnonWildCardOcc.+See related Note [Wildcards in visible type application] here and+Note [The wildcard story for types] in GHC.Hs.Type+-}++{- *********************************************************************+* *+ 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 (scaledThing 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 (scaledThing 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 _ (Invisible _)) -> False+ Named (Bndr _ Required) -> True+ Anon InvisArg _ -> False+ Anon VisArg _ -> True+ in+ zip_binders (zb:acc) ki' bs'++tooManyBindersErr :: Kind -> [LHsTyVarBndr () GhcRn] -> SDoc+tooManyBindersErr 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+--------------------------------------++-- | Skolemise the 'HsTyVarBndr's in an 'LHsForAllTelescope.+-- Returns 'Left' for visible @forall@s and 'Right' for invisible @forall@s.+bindExplicitTKTele_Skol_M+ :: TcTyMode+ -> HsForAllTelescope GhcRn+ -> TcM a+ -> TcM (Either [TcReqTVBinder] [TcInvisTVBinder], a)+bindExplicitTKTele_Skol_M mode tele thing_inside = case tele of+ HsForAllVis { hsf_vis_bndrs = bndrs } -> do+ (req_tv_bndrs, thing) <- bindExplicitTKBndrs_Skol_M mode bndrs thing_inside+ pure (Left req_tv_bndrs, thing)+ HsForAllInvis { hsf_invis_bndrs = bndrs } -> do+ (inv_tv_bndrs, thing) <- bindExplicitTKBndrs_Skol_M mode bndrs thing_inside+ pure (Right inv_tv_bndrs, thing)++bindExplicitTKBndrs_Skol, bindExplicitTKBndrs_Tv+ :: (OutputableBndrFlag flag)+ => [LHsTyVarBndr flag GhcRn]+ -> TcM a+ -> TcM ([VarBndr TyVar flag], a)++bindExplicitTKBndrs_Skol_M, bindExplicitTKBndrs_Tv_M+ :: (OutputableBndrFlag flag)+ => TcTyMode+ -> [LHsTyVarBndr flag GhcRn]+ -> TcM a+ -> TcM ([VarBndr TyVar flag], a)++bindExplicitTKBndrs_Skol = bindExplicitTKBndrsX (tcHsTyVarBndr (mkMode KindLevel) newSkolemTyVar)+bindExplicitTKBndrs_Skol_M mode = bindExplicitTKBndrsX (tcHsTyVarBndr (kindLevel mode) newSkolemTyVar)+bindExplicitTKBndrs_Tv = bindExplicitTKBndrsX (tcHsTyVarBndr (mkMode KindLevel) cloneTyVarTyVar)+bindExplicitTKBndrs_Tv_M mode = bindExplicitTKBndrsX (tcHsTyVarBndr (kindLevel mode) 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_Q (tcHsQTyVarBndr ctxt_kind newSkolemTyVar)+bindExplicitTKBndrs_Q_Tv ctxt_kind = bindExplicitTKBndrsX_Q (tcHsQTyVarBndr ctxt_kind newTyVarTyVar)+ -- See Note [Non-cloning for tyvar binders]++bindExplicitTKBndrsX_Q+ :: (HsTyVarBndr () GhcRn -> TcM TcTyVar)+ -> [LHsTyVarBndr () GhcRn]+ -> TcM a+ -> TcM ([TcTyVar], a) -- Returned [TcTyVar] are in 1-1 correspondence+ -- with the passed-in [LHsTyVarBndr]+bindExplicitTKBndrsX_Q tc_tv hs_tvs thing_inside+ = do { (tv_bndrs,res) <- bindExplicitTKBndrsX tc_tv hs_tvs thing_inside+ ; return ((binderVars tv_bndrs),res) }++bindExplicitTKBndrsX :: (OutputableBndrFlag flag)+ => (HsTyVarBndr flag GhcRn -> TcM TcTyVar)+ -> [LHsTyVarBndr flag GhcRn]+ -> TcM a+ -> TcM ([VarBndr TyVar flag], a) -- Returned [TcTyVar] are in 1-1 correspondence+ -- with the passed-in [LHsTyVarBndr]+bindExplicitTKBndrsX tc_tv hs_tvs thing_inside+ = do { traceTc "bindExplicTKBndrs" (ppr hs_tvs)+ ; go hs_tvs }+ 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 ((Bndr tv (hsTyVarBndrFlag hs_tv)):tvs, res) }++-----------------+tcHsTyVarBndr :: TcTyMode -> (Name -> Kind -> TcM TyVar)+ -> HsTyVarBndr flag GhcRn -> TcM TcTyVar+tcHsTyVarBndr _ new_tv (UserTyVar _ _ (L _ tv_nm))+ = do { kind <- newMetaKindVar+ ; new_tv tv_nm kind }+tcHsTyVarBndr mode new_tv (KindedTyVar _ _ (L _ tv_nm) lhs_kind)+ = do { kind <- tc_lhs_kind_sig mode (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)++ ; _ <- promoteTyVarSet 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:" <+> ppr to_promote+ , 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 (scaledThing 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 -- any arguments in the kind are stripped off+ -> TcM ()+checkDataKindSig data_sort kind+ = do { dflags <- getDynFlags+ ; traceTc "checkDataKindSig" (ppr kind)+ ; checkTc (is_TYPE_or_Type dflags || is_kind_var)+ (err_msg dflags) }+ where+ res_kind = snd (tcSplitPiTys kind)+ -- Look for the result kind after+ -- peeling off any foralls and arrows++ 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 res_kind++ is_Type :: Bool+ is_Type = tcIsLiftedTypeKind res_kind++ is_TYPE_or_Type :: DynFlags -> Bool+ is_TYPE_or_Type dflags | tYPE_ok dflags = is_TYPE+ | otherwise = is_Type++ -- 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 res_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 res_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,InvisTVBinder)] -- 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 { mode <- mkHoleMode TypeLevel HM_Sig+ ; (implicit_tvs, (explicit_tvbndrs, (wcs, wcx, theta, tau)))+ <- solveLocalEqualities "tcHsPartialSigType" $+ -- See Note [Failure in local type signatures]+ tcNamedWildCardBinders sig_wcs $ \ wcs ->+ bindImplicitTKBndrs_Tv implicit_hs_tvs $+ bindExplicitTKBndrs_Tv_M mode explicit_hs_tvs $+ do { -- Instantiate the type-class context; but if there+ -- is an extra-constraints wildcard, just discard it here+ (theta, wcx) <- tcPartialContext mode hs_ctxt++ ; ek <- newOpenTypeKind+ ; tau <- addTypeCtxt hs_tau $+ tc_lhs_type mode hs_tau ek++ ; return (wcs, wcx, theta, tau) }++ ; let implicit_tvbndrs = map (mkTyVarBinder SpecifiedSpec) implicit_tvs++ -- No kind-generalization here:+ ; kindGeneralizeNone (mkInvisForAllTys implicit_tvbndrs $+ mkInvisForAllTys explicit_tvbndrs $+ mkPhiTy theta $+ tau)++ -- Spit out the wildcards (including the extra-constraints one)+ -- as "hole" constraints, so that they'll be reported if necessary+ -- See Note [Extra-constraint holes in partial type signatures]+ ; mapM_ emitNamedTypeHole wcs++ -- Zonk, so that any nested foralls can "see" their occurrences+ -- See Note [Checking partial type signatures], and in particular+ -- Note [Levels for wildcards]+ ; implicit_tvbndrs <- mapM zonkInvisTVBinder implicit_tvbndrs+ ; explicit_tvbndrs <- mapM zonkInvisTVBinder explicit_tvbndrs+ ; theta <- mapM zonkTcType theta+ ; tau <- zonkTcType tau++ -- We return a proper (Name,InvisTVBinder) environment, to be sure that+ -- we bring the right name into scope in the function body.+ -- Test case: partial-sigs/should_compile/LocalDefinitionBug+ ; let tv_prs = (implicit_hs_tvs `zip` implicit_tvbndrs)+ ++ (hsLTyVarNames explicit_hs_tvs `zip` explicit_tvbndrs)++ -- NB: checkValidType on the final inferred type will be+ -- done later by checkInferredPolyId. We can't do it+ -- here because we don't have a complete type to check++ ; traceTc "tcHsPartialSigType" (ppr tv_prs)+ ; return (wcs, wcx, tv_prs, theta, tau) }++tcPartialContext :: TcTyMode -> HsContext GhcRn -> TcM (TcThetaType, Maybe TcType)+tcPartialContext mode hs_theta+ | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta+ , L wc_loc ty@(HsWildCardTy _) <- ignoreParens hs_ctxt_last+ = do { wc_tv_ty <- setSrcSpan wc_loc $+ tcAnonWildCardOcc mode ty constraintKind+ ; theta <- mapM (tc_lhs_pred mode) hs_theta1+ ; return (theta, Just wc_tv_ty) }+ | otherwise+ = do { theta <- mapM (tc_lhs_pred mode) 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. See Note [Levels for wildcards]++* Just as for ordinary signatures, we must solve local equalities and+ 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 [Levels for wildcards]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+ f :: forall b. (forall a. a -> _) -> b+We do /not/ allow the "_" to be instantiated to 'a'; although we do+(as before) allow it to be instantiated to the (top level) 'b'.+Why not? Suppose+ f x = (x True, x 'c')++During typecking the RHS we must instantiate that (forall a. a -> _),+so we must know /precisely/ where all the a's are; they must not be+hidden under (possibly-not-yet-filled-in) unification variables!++We achieve this as follows:++- For /named/ wildcards such sas+ g :: forall b. (forall la. a -> _x) -> b+ there is no problem: we create them at the outer level (ie the+ ambient level of teh signature itself), and push the level when we+ go inside a forall. So now the unification variable for the "_x"+ can't unify with skolem 'a'.++- For /anonymous/ wildcards, such as 'f' above, we carry the ambient+ level of the signature to the hole in the TcLevel part of the+ mode_holes field of TcTyMode. Then, in tcAnonWildCardOcc we us that+ level (and /not/ the level ambient at the occurrence of "_") to+ create the unification variable for the wildcard. That is the sole+ purpose of the TcLevel in the mode_holes field: to transport the+ ambient level of the signature down to the anonymous wildcard+ occurrences.++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+ -> HsPatSigType 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+-- See Note [Pattern signature binders and scoping] in GHC.Hs.Type+--+-- This may emit constraints+-- See Note [Recipe for checking a signature]+tcHsPatSigType ctxt+ (HsPS { hsps_ext = HsPSRn { hsps_nwcs = sig_wcs, hsps_imp_tvs = sig_ns }+ , hsps_body = hs_ty })+ = addSigCtxt ctxt hs_ty $+ do { sig_tkv_prs <- mapM new_implicit_tv sig_ns+ ; mode <- mkHoleMode TypeLevel HM_Sig+ ; (wcs, sig_ty)+ <- addTypeCtxt hs_ty $+ solveLocalEqualities "tcHsPatSigType" $+ -- See Note [Failure in local type signatures]+ -- and c.f #16033+ tcNamedWildCardBinders sig_wcs $ \ wcs ->+ tcExtendNameTyVarEnv sig_tkv_prs $+ do { ek <- newOpenTypeKind+ ; sig_ty <- tc_lhs_type mode hs_ty ek+ ; return (wcs, sig_ty) }++ ; mapM_ emitNamedTypeHole 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 [Typechecking pattern signature binders]+ -- NB: tv's Name may be fresh (in the case of newPatSigTyVar)+ ; return (name, tv) }++{- Note [Typechecking 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)) = <blah>++Here+ * The pattern (MkT p1 p2) creates a *skolem* type variable 'a_sk',+ It must be a skolem so 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 '<blah>' 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+ = tc_lhs_kind_sig (mkMode KindLevel) ctxt hs_kind++tc_lhs_kind_sig :: TcTyMode -> UserTypeCtxt -> LHsKind GhcRn -> TcM Kind+tc_lhs_kind_sig mode ctxt hs_kind+-- See Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType+-- Result is zonked+ = do { kind <- addErrCtxt (text "In the kind" <+> quotes (ppr hs_kind)) $+ solveLocalEqualities "tcLHsKindSig" $+ tc_lhs_type mode hs_kind liftedTypeKind+ ; 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). <blah>).+ -- <more blah>+ -- When instantiating p's kind at occurrences of p in <more blah>+ -- 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 } promotionErr :: Name -> PromotionErr -> TcM a promotionErr name err
compiler/GHC/Tc/Gen/Match.hs view
@@ -36,9 +36,10 @@ import GHC.Prelude -import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcInferRhoNC, tcInferRho- , tcCheckId, tcLExpr, tcLExprNC, tcExpr- , tcCheckExpr )+import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcInferRho, tcInferRhoNC+ , tcMonoExpr, tcMonoExprNC, tcExpr+ , tcCheckMonoExpr, tcCheckMonoExprNC+ , tcCheckPolyExpr, tcCheckId ) import GHC.Types.Basic (LexicalFixity(..)) import GHC.Hs@@ -50,6 +51,8 @@ import GHC.Tc.Gen.Bind import GHC.Tc.Utils.Unify import GHC.Tc.Types.Origin+import GHC.Core.Multiplicity+import GHC.Core.UsageEnv import GHC.Types.Name import GHC.Builtin.Types import GHC.Types.Id@@ -79,18 +82,12 @@ @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))+ -> ExpRhoType -- Expected type of function+ -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) -- Returns type of body tcMatchesFun fn@(L _ fun_name) matches exp_ty = do { -- Check that they all have the same no of arguments@@ -102,20 +99,24 @@ 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) }+ ; matchExpectedFunTys herald ctxt arity exp_ty $ \ pat_tys rhs_ty ->+ -- NB: exp_type may be polymorphic, but+ -- matchExpectedFunTys can cope with that+ tcScalingUsage Many $+ -- toplevel bindings and let bindings are, at the+ -- moment, always unrestricted. The value being bound+ -- must, accordingly, be unrestricted. Hence them+ -- being scaled by Many. When let binders come with a+ -- multiplicity, then @tcMatchesFun@ will have to take+ -- a multiplicity argument, and scale accordingly.+ tcMatches match_ctxt pat_tys rhs_ty matches } where- arity = matchGroupArity matches+ 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 }+ ctxt = GenSigCtxt -- Was: FunSigCtxt fun_name True+ -- But that's wrong for f :: Int -> forall a. blah+ 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@@ -131,23 +132,23 @@ tcMatchesCase :: (Outputable (body GhcRn)) => TcMatchCtxt body -- Case context- -> TcSigmaType -- Type of scrutinee+ -> Scaled TcSigmaType -- Type of scrutinee -> MatchGroup GhcRn (Located (body GhcRn)) -- The case alternatives -> ExpRhoType -- Type of whole case expressions- -> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))+ -> TcM (MatchGroup GhcTc (Located (body GhcTc))) -- 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+tcMatchesCase ctxt (Scaled scrut_mult scrut_ty) matches res_ty+ = tcMatches ctxt [Scaled scrut_mult (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)+ -> ExpRhoType+ -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) tcMatchLambda herald match_ctxt match res_ty- = matchExpectedFunTys herald n_pats res_ty $ \ pat_tys rhs_ty ->+ = matchExpectedFunTys herald GenSigCtxt 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@@ -156,7 +157,7 @@ -- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@. tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> TcRhoType- -> TcM (GRHSs GhcTcId (LHsExpr GhcTcId))+ -> TcM (GRHSs GhcTc (LHsExpr GhcTc)) -- Used for pattern bindings tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss (mkCheckExpType res_ty) where@@ -205,33 +206,35 @@ -- expected type into TauTvs. -- See Note [Case branches must never infer a non-tau type] tauifyMultipleMatches :: [LMatch id body]- -> [ExpType] -> TcM [ExpType]+ -> [Scaled ExpType] -> TcM [Scaled ExpType] tauifyMultipleMatches group exp_tys | isSingletonMatchGroup group = return exp_tys- | otherwise = mapM tauifyExpType exp_tys+ | otherwise = mapM (\(Scaled m t) ->+ fmap (Scaled m) (tauifyExpType t)) 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+ -> [Scaled ExpSigmaType] -- Expected pattern types -> ExpRhoType -- Expected result-type of the Match. -> MatchGroup GhcRn (Located (body GhcRn))- -> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))+ -> TcM (MatchGroup GhcTc (Located (body GhcTc))) 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)) }-+ -> TcM (Located (body GhcTc)) } 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)+ = do { (Scaled _ rhs_ty):pat_tys <- tauifyMultipleMatches matches ((Scaled One rhs_ty):pat_tys) -- return type has implicitly multiplicity 1, it doesn't matter all that much in this case since it isn't used and is eliminated immediately. -- 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+ ; umatches <- mapM (tcCollectingUsage . tcMatch ctxt pat_tys rhs_ty) matches+ ; let (usages,matches') = unzip umatches+ ; tcEmitBindingUsage $ supUEs usages+ ; pat_tys <- mapM (\(Scaled m t) -> fmap (Scaled m) (readExpType t)) pat_tys ; rhs_ty <- readExpType rhs_ty ; return (MG { mg_alts = L l matches' , mg_ext = MatchGroupTc pat_tys rhs_ty@@ -239,10 +242,10 @@ ------------- tcMatch :: (Outputable (body GhcRn)) => TcMatchCtxt body- -> [ExpSigmaType] -- Expected pattern types+ -> [Scaled ExpSigmaType] -- Expected pattern types -> ExpRhoType -- Expected result-type of the Match. -> LMatch GhcRn (Located (body GhcRn))- -> TcM (LMatch GhcTcId (Located (body GhcTcId)))+ -> TcM (LMatch GhcTc (Located (body GhcTc))) tcMatch ctxt pat_tys rhs_ty match = wrapLocM (tc_match ctxt pat_tys rhs_ty) match@@ -265,7 +268,7 @@ ------------- tcGRHSs :: TcMatchCtxt body -> GRHSs GhcRn (Located (body GhcRn)) -> ExpRhoType- -> TcM (GRHSs GhcTcId (Located (body GhcTcId)))+ -> TcM (GRHSs GhcTc (Located (body GhcTc))) -- Notice that we pass in the full res_ty, so that we get -- good inference from simple things like@@ -274,15 +277,16 @@ -- but we don't need to do that any more tcGRHSs ctxt (GRHSs _ grhss (L l binds)) res_ty- = do { (binds', grhss')+ = do { (binds', ugrhss) <- tcLocalBinds binds $- mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss-+ mapM (tcCollectingUsage . wrapLocM (tcGRHS ctxt res_ty)) grhss+ ; let (usages, grhss') = unzip ugrhss+ ; tcEmitBindingUsage $ supUEs usages ; return (GRHSs noExtField grhss' (L l binds')) } ------------- tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (Located (body GhcRn))- -> TcM (GRHS GhcTcId (Located (body GhcTcId)))+ -> TcM (GRHS GhcTc (Located (body GhcTc))) tcGRHS ctxt res_ty (GRHS _ guards rhs) = do { (guards', rhs')@@ -303,7 +307,7 @@ tcDoStmts :: HsStmtContext GhcRn -> Located [LStmt GhcRn (LHsExpr GhcRn)] -> ExpRhoType- -> TcM (HsExpr GhcTcId) -- Returns a HsDo+ -> TcM (HsExpr GhcTc) -- Returns a HsDo tcDoStmts ListComp (L l stmts) res_ty = do { res_ty <- expTypeToType res_ty ; (co, elt_ty) <- matchExpectedListTy res_ty@@ -312,15 +316,15 @@ (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+tcDoStmts doExpr@(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')) }+ ; return (HsDo res_ty doExpr (L l stmts')) } -tcDoStmts MDoExpr (L l stmts) res_ty- = do { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty+tcDoStmts mDoExpr@(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')) }+ ; return (HsDo res_ty mDoExpr (L l stmts')) } tcDoStmts MonadComp (L l stmts) res_ty = do { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty@@ -329,10 +333,10 @@ tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt) -tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)+tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc) tcBody body res_ty = do { traceTc "tcBody" (ppr res_ty)- ; tcLExpr body res_ty+ ; tcMonoExpr body res_ty } {-@@ -351,13 +355,13 @@ -> 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)+ -> TcM (Stmt GhcTc (Located (body GhcTc)), 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))]+ -> TcM [LStmt GhcTc (Located (body GhcTc))] tcStmts ctxt stmt_chk stmts res_ty = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $ const (return ())@@ -368,7 +372,7 @@ -> [LStmt GhcRn (Located (body GhcRn))] -> rho_type -> (rho_type -> TcM thing)- -> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)+ -> TcM ([LStmt GhcTc (Located (body GhcTc))], thing) -- Note the higher-rank type. stmt_chk is applied at different -- types in the equations for tcStmts@@ -412,7 +416,7 @@ tcGuardStmt :: TcExprStmtChecker tcGuardStmt _ (BodyStmt _ guard _ _) res_ty thing_inside- = do { guard' <- tcLExpr guard (mkCheckExpType boolTy)+ = do { guard' <- tcCheckMonoExpr guard boolTy ; thing <- thing_inside res_ty ; return (BodyStmt boolTy guard' noSyntaxExpr noSyntaxExpr, thing) } @@ -420,7 +424,7 @@ = do { (rhs', rhs_ty) <- tcInferRhoNC rhs -- Stmt has a context already ; (pat', thing) <- tcCheckPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs)- pat rhs_ty $+ pat (unrestricted rhs_ty) $ thing_inside res_ty ; return (mkTcBindStmt pat' rhs', thing) } @@ -445,21 +449,21 @@ -> TcExprStmtChecker tcLcStmt _ _ (LastStmt x body noret _) elt_ty thing_inside- = do { body' <- tcLExprNC body elt_ty+ = 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' <- tcLExpr rhs (mkCheckExpType $ mkTyConApp m_tc [pat_ty])- ; (pat', thing) <- tcCheckPat (StmtCtxt ctxt) pat pat_ty $+ ; rhs' <- tcCheckMonoExpr rhs (mkTyConApp m_tc [pat_ty])+ ; (pat', thing) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted 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)+ = do { rhs' <- tcCheckMonoExpr rhs boolTy ; thing <- thing_inside elt_ty ; return (BodyStmt boolTy rhs' noSyntaxExpr noSyntaxExpr, thing) } @@ -469,7 +473,7 @@ ; return (ParStmt unitTy pairs' noExpr noSyntaxExpr, thing) } where -- loop :: [([LStmt GhcRn], [GhcRn])]- -- -> TcM ([([LStmt GhcTcId], [GhcTcId])], thing)+ -- -> TcM ([([LStmt GhcTc], [GhcTc])], thing) loop [] = do { thing <- thing_inside elt_ty ; return ([], thing) } -- matching in the branches @@ -508,23 +512,23 @@ 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+ Just (_,e_ty) -> \ty -> (alphaTy `mkVisFunTyMany` e_ty) `mkVisFunTyMany` ty tup_ty = mkBigCoreVarTupTy bndr_ids poly_arg_ty = m_app alphaTy poly_res_ty = m_app (n_app alphaTy) using_poly_ty = mkInfForAllTy alphaTyVar $ by_arrow $- poly_arg_ty `mkVisFunTy` poly_res_ty+ poly_arg_ty `mkVisFunTyMany` poly_res_ty - ; using' <- tcCheckExpr using using_poly_ty+ ; using' <- tcCheckPolyExpr 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))+ mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name Many (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`@@ -558,8 +562,8 @@ 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)+ \ [a_ty] [mult]->+ tcScalingUsage mult $ tcCheckMonoExprNC body a_ty ; thing <- thing_inside (panic "tcMcStmt: thing_inside") ; return (LastStmt x body' noret return_op', thing) } @@ -571,14 +575,14 @@ 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')+ = do { ((rhs', pat_mult, 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 $+ \ [rhs_ty, pat_ty, new_res_ty] [rhs_mult, fun_mult, pat_mult] ->+ do { rhs' <- tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty+ ; (pat', thing) <- tcScalingUsage fun_mult $ tcCheckPat (StmtCtxt ctxt) pat (Scaled pat_mult pat_ty) $ thing_inside (mkCheckExpType new_res_ty)- ; return (rhs', pat', thing, new_res_ty) }+ ; return (rhs', pat_mult, 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 ->@@ -587,6 +591,7 @@ ; let xbstc = XBindStmtTc { xbstc_bindOp = bind_op' , xbstc_boundResultType = new_res_ty+ , xbstc_boundResultMult = pat_mult , xbstc_failOp = fail_op' } ; return (BindStmt xbstc pat' rhs', thing) }@@ -602,13 +607,14 @@ -- 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] ->+ \ [rhs_ty, new_res_ty] [rhs_mult, fun_mult] -> do { (rhs', guard_op')- <- tcSyntaxOp MCompOrigin guard_op [SynAny]+ <- tcScalingUsage rhs_mult $+ tcSyntaxOp MCompOrigin guard_op [SynAny] (mkCheckExpType rhs_ty) $- \ [test_ty] ->- tcLExpr rhs (mkCheckExpType test_ty)- ; thing <- thing_inside (mkCheckExpType new_res_ty)+ \ [test_ty] [test_mult] ->+ tcScalingUsage test_mult $ tcCheckMonoExpr rhs test_ty+ ; thing <- tcScalingUsage fun_mult $ thing_inside (mkCheckExpType new_res_ty) ; return (thing, rhs', rhs_ty, guard_op') } ; return (BodyStmt rhs_ty rhs' then_op' guard_op', thing) } @@ -648,7 +654,7 @@ -- or res ('by' absent) by_arrow = case by of Nothing -> \res -> res- Just {} -> \res -> (alphaTy `mkVisFunTy` by_e_ty) `mkVisFunTy` res+ Just {} -> \res -> (alphaTy `mkVisFunTyMany` by_e_ty) `mkVisFunTyMany` res poly_arg_ty = m1_ty `mkAppTy` alphaTy using_arg_ty = m1_ty `mkAppTy` tup_ty@@ -656,7 +662,7 @@ using_res_ty = m2_ty `mkAppTy` n_app tup_ty using_poly_ty = mkInfForAllTy alphaTyVar $ by_arrow $- poly_arg_ty `mkVisFunTy` poly_res_ty+ poly_arg_ty `mkVisFunTyMany` poly_res_ty -- 'stmts' returns a result of type (m1_ty tuple_ty), -- typically something like [(Int,Bool,Int)]@@ -667,8 +673,7 @@ (mkCheckExpType using_arg_ty) $ \res_ty' -> do { by' <- case by of Nothing -> return Nothing- Just e -> do { e' <- tcLExpr e- (mkCheckExpType by_e_ty)+ Just e -> do { e' <- tcCheckMonoExpr e by_e_ty ; return (Just e') } -- Find the Ids (and hence types) of all old binders@@ -678,7 +683,7 @@ -- return :: (a,b,c,..) -> m (a,b,c,..) ; (_, return_op') <- tcSyntaxOp MCompOrigin return_op [synKnownType (mkBigCoreVarTupTy bndr_ids)]- res_ty' $ \ _ -> return ()+ res_ty' $ \ _ _ -> return () ; return (bndr_ids, by', return_op') } @@ -687,28 +692,28 @@ ; 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 ()+ , synKnownType (n_app tup_ty `mkVisFunTyMany` new_res_ty) ]+ res_ty $ \ _ _ -> return () --------------- Typecheck the 'fmap' function ------------- ; fmap_op' <- case form of ThenForm -> return noExpr- _ -> fmap unLoc . tcCheckExpr (noLoc fmap_op) $+ _ -> fmap unLoc . tcCheckPolyExpr (noLoc fmap_op) $ mkInfForAllTy alphaTyVar $ mkInfForAllTy betaTyVar $- (alphaTy `mkVisFunTy` betaTy)- `mkVisFunTy` (n_app alphaTy)- `mkVisFunTy` (n_app betaTy)+ (alphaTy `mkVisFunTyMany` betaTy)+ `mkVisFunTyMany` (n_app alphaTy)+ `mkVisFunTyMany` (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+ ; using' <- tcCheckPolyExpr 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))+ mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name Many (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`@@ -761,11 +766,11 @@ ; let mzip_ty = mkInfForAllTys [alphaTyVar, betaTyVar] $ (m_ty `mkAppTy` alphaTy)- `mkVisFunTy`+ `mkVisFunTyMany` (m_ty `mkAppTy` betaTy)- `mkVisFunTy`+ `mkVisFunTyMany` (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy])- ; mzip_op' <- unLoc `fmap` tcCheckExpr (noLoc mzip_op) mzip_ty+ ; mzip_op' <- unLoc `fmap` tcCheckPolyExpr (noLoc mzip_op) mzip_ty -- type dummies since we don't know all binder types yet ; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind))@@ -779,7 +784,7 @@ <- tcSyntaxOp MCompOrigin bind_op [ synKnownType (m_ty `mkAppTy` tuple_ty) , SynFun (synKnownType tuple_ty) SynRho ] res_ty $- \ [inner_res_ty] ->+ \ [inner_res_ty] _ -> do { stuff <- loop m_ty (mkCheckExpType inner_res_ty) tup_tys bndr_stmts_s ; return (stuff, inner_res_ty) }@@ -793,7 +798,7 @@ -- -> ExpRhoType -- inner_res_ty -- -> [TcType] -- tup_tys -- -> [ParStmtBlock Name]- -- -> TcM ([([LStmt GhcTcId], [GhcTcId])], thing)+ -- -> TcM ([([LStmt GhcTc], [TcId])], thing) loop _ inner_res_ty [] [] = do { thing <- thing_inside inner_res_ty ; return ([], thing) } -- matching in the branches@@ -809,7 +814,7 @@ ; (_, return_op') <- tcSyntaxOp MCompOrigin return_op [synKnownType tup_ty] m_tup_ty' $- \ _ -> return ()+ \ _ _ -> 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) }@@ -827,23 +832,23 @@ tcDoStmt :: TcExprStmtChecker tcDoStmt _ (LastStmt x body noret _) res_ty thing_inside- = do { body' <- tcLExprNC body res_ty+ = do { body' <- tcMonoExprNC 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+ -- (>>=) :: rhs_ty ->_rhs_mult (pat_ty ->_pat_mult new_res_ty) ->_fun_mult 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')+ ((rhs', pat_mult, 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 $+ \ [rhs_ty, pat_ty, new_res_ty] [rhs_mult,fun_mult,pat_mult] ->+ do { rhs' <-tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty+ ; (pat', thing) <- tcScalingUsage fun_mult $ tcCheckPat (StmtCtxt ctxt) pat (Scaled pat_mult pat_ty) $ thing_inside (mkCheckExpType new_res_ty)- ; return (rhs', pat', new_res_ty, thing) }+ ; return (rhs', pat_mult, 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 ->@@ -851,6 +856,7 @@ ; let xbstc = XBindStmtTc { xbstc_bindOp = bind_op' , xbstc_boundResultType = new_res_ty+ , xbstc_boundResultMult = pat_mult , xbstc_failOp = fail_op' } ; return (BindStmt xbstc pat' rhs', thing) }@@ -863,7 +869,7 @@ Just join_op -> second Just <$> (tcSyntaxOp DoOrigin join_op [SynRho] res_ty $- \ [rhs_ty] -> tc_app_stmts (mkCheckExpType rhs_ty))+ \ [rhs_ty] [rhs_mult] -> tcScalingUsage rhs_mult $ tc_app_stmts (mkCheckExpType rhs_ty)) ; return (ApplicativeStmt body_ty pairs' mb_join', thing) } @@ -872,9 +878,9 @@ -- (>>) :: 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)+ \ [rhs_ty, new_res_ty] [rhs_mult,fun_mult] ->+ do { rhs' <- tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty+ ; thing <- tcScalingUsage fun_mult $ thing_inside (mkCheckExpType new_res_ty) ; return (rhs', rhs_ty, thing) } ; return (BodyStmt rhs_ty rhs' then_op' noSyntaxExpr, thing) } @@ -884,7 +890,8 @@ 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+ ; let tup_ids = zipWith (\n t -> mkLocalId n Many t) tup_names tup_elt_tys+ -- Many because it's a recursive definition tup_ty = mkBigCoreTupTy tup_elt_tys ; tcExtendIdEnv tup_ids $ do@@ -897,21 +904,21 @@ -- be polymorphic) with those of "knot-tied" Ids ; (_, ret_op') <- tcSyntaxOp DoOrigin ret_op [synKnownType tup_ty]- inner_res_ty $ \_ -> return ()+ 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 ()+ [synKnownType (mkVisFunTyMany 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 ]+ , SynFun (synKnownType tup_ty) SynRho ] res_ty $- \ [new_res_ty] ->+ \ [new_res_ty] _ -> do { thing <- thing_inside (mkCheckExpType new_res_ty) ; return (thing, new_res_ty) } @@ -941,13 +948,13 @@ -- 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.+-- "GHC.Tc.Errors". tcMonadFailOp :: CtOrigin- -> LPat GhcTcId+ -> LPat GhcTc -> SyntaxExpr GhcRn -- The fail op -> TcType -- Type of the whole do-expression- -> TcRn (FailOperator GhcTcId) -- Typechecked fail op+ -> TcRn (FailOperator GhcTc) -- 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@@ -958,7 +965,7 @@ = return Nothing | otherwise = Just . snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy]- (mkCheckExpType res_ty) $ \_ -> return ())+ (mkCheckExpType res_ty) $ \_ _ -> return ()) {- Note [Treat rebindable syntax first]@@ -994,7 +1001,7 @@ -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)] -> ExpRhoType -- rhs_ty -> (TcRhoType -> TcM t) -- thing_inside- -> TcM ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], Type, t)+ -> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Type, t) tcApplicativeStmts ctxt pairs rhs_ty thing_inside = do { body_ty <- newFlexiTyVarTy liftedTypeKind@@ -1002,7 +1009,7 @@ ; 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+ ; let fun_ty = mkVisFunTysMany pat_tys body_ty -- NB. do the <$>,<*> operators first, we don't want type errors here -- i.e. goOps before goArgs@@ -1027,13 +1034,13 @@ = do { (_, op') <- tcSyntaxOp DoOrigin op [synKnownType t_left, synKnownType exp_ty] t_i $- \ _ -> return ()+ \ _ _ -> return () ; t_i <- readExpType t_i ; ops' <- goOps t_i ops ; return (op' : ops') } goArg :: Type -> (ApplicativeArg GhcRn, Type, Type)- -> TcM (ApplicativeArg GhcTcId)+ -> TcM (ApplicativeArg GhcTc) goArg body_ty (ApplicativeArgOne { xarg_app_arg_one = fail_op@@ -1043,8 +1050,8 @@ }, 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 $+ do { rhs' <- tcCheckMonoExprNC rhs exp_ty+ ; (pat', _) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $ return () ; fail_op' <- fmap join . forM fail_op $ \fail -> tcMonadFailOp (DoPatOrigin pat) pat' fail body_ty@@ -1056,18 +1063,18 @@ , .. } ) } - goArg _body_ty (ApplicativeArgMany x stmts ret pat, pat_ty, exp_ty)+ goArg _body_ty (ApplicativeArgMany x stmts ret pat ctxt, 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 $+ ; (pat', _) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $ return () ; return (ret', pat') }- ; return (ApplicativeArgMany x stmts' ret' pat') }+ ; return (ApplicativeArgMany x stmts' ret' pat' ctxt) } - get_arg_bndrs :: ApplicativeArg GhcTcId -> [Id]+ get_arg_bndrs :: ApplicativeArg GhcTc -> [Id] get_arg_bndrs (ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders pat get_arg_bndrs (ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders pat
compiler/GHC/Tc/Gen/Match.hs-boot view
@@ -5,13 +5,13 @@ import GHC.Tc.Utils.TcType( ExpSigmaType, TcRhoType ) import GHC.Tc.Types ( TcM ) import GHC.Types.SrcLoc ( Located )-import GHC.Hs.Extension ( GhcRn, GhcTcId )+import GHC.Hs.Extension ( GhcRn, GhcTc ) tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> TcRhoType- -> TcM (GRHSs GhcTcId (LHsExpr GhcTcId))+ -> TcM (GRHSs GhcTc (LHsExpr GhcTc)) tcMatchesFun :: Located Name -> MatchGroup GhcRn (LHsExpr GhcRn) -> ExpSigmaType- -> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId))+ -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
compiler/GHC/Tc/Gen/Pat.hs view
@@ -30,7 +30,7 @@ import GHC.Prelude -import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcSyntaxOpGen, tcInferSigma )+import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcSyntaxOpGen, tcInferRho ) import GHC.Hs import GHC.Tc.Utils.Zonk@@ -41,6 +41,7 @@ import GHC.Types.Var import GHC.Types.Name import GHC.Types.Name.Reader+import GHC.Core.Multiplicity import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcMType import GHC.Tc.Validity( arityErr )@@ -77,9 +78,9 @@ tcLetPat :: (Name -> Maybe TcId) -> LetBndrSpec- -> LPat GhcRn -> ExpSigmaType+ -> LPat GhcRn -> Scaled ExpSigmaType -> TcM a- -> TcM (LPat GhcTcId, a)+ -> TcM (LPat GhcTc, a) tcLetPat sig_fn no_gen pat pat_ty thing_inside = do { bind_lvl <- getTcLevel ; let ctxt = LetPat { pc_lvl = bind_lvl@@ -94,9 +95,9 @@ ----------------- tcPats :: HsMatchContext GhcRn -> [LPat GhcRn] -- Patterns,- -> [ExpSigmaType] -- and their types+ -> [Scaled ExpSigmaType] -- and their types -> TcM a -- and the checker for the body- -> TcM ([LPat GhcTcId], a)+ -> TcM ([LPat GhcTc], a) -- This is the externally-callable wrapper function -- Typecheck the patterns, extend the environment to bind the variables,@@ -116,27 +117,27 @@ tcInferPat :: HsMatchContext GhcRn -> LPat GhcRn -> TcM a- -> TcM ((LPat GhcTcId, a), TcSigmaType)+ -> TcM ((LPat GhcTc, a), TcSigmaType) tcInferPat ctxt pat thing_inside = tcInfer $ \ exp_ty ->- tc_lpat exp_ty penv pat thing_inside+ tc_lpat (unrestricted exp_ty) penv pat thing_inside where penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin } tcCheckPat :: HsMatchContext GhcRn- -> LPat GhcRn -> TcSigmaType+ -> LPat GhcRn -> Scaled TcSigmaType -> TcM a -- Checker for body- -> TcM (LPat GhcTcId, a)+ -> TcM (LPat GhcTc, 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+ -> LPat GhcRn -> Scaled TcSigmaType -> TcM a -- Checker for body- -> TcM (LPat GhcTcId, a)-tcCheckPat_O ctxt orig pat pat_ty thing_inside- = tc_lpat (mkCheckExpType pat_ty) penv pat thing_inside+ -> TcM (LPat GhcTc, a)+tcCheckPat_O ctxt orig pat (Scaled pat_mult pat_ty) thing_inside+ = tc_lpat (Scaled pat_mult (mkCheckExpType pat_ty)) penv pat thing_inside where penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = orig } @@ -198,7 +199,7 @@ * * ********************************************************************* -} -tcPatBndr :: PatEnv -> Name -> ExpSigmaType -> TcM (HsWrapper, TcId)+tcPatBndr :: PatEnv -> Name -> Scaled ExpSigmaType -> TcM (HsWrapper, TcId) -- (coi, xp) = tcPatBndr penv x pat_ty -- Then coi : pat_ty ~ typeof(xp) --@@ -210,34 +211,36 @@ -- 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)+ = do { wrap <- tc_sub_type penv (scaledThing 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+ = do { (co, bndr_ty) <- case scaledThing 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+ ; let bndr_mult = scaledMult exp_pat_ty+ ; bndr_id <- newLetBndr no_gen bndr_name bndr_mult 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+ = do { let pat_mult = scaledMult pat_ty+ ; pat_ty <- expTypeToType (scaledThing pat_ty) ; traceTc "tcPatBndr(not let)" (ppr bndr_name $$ ppr pat_ty)- ; return (idHsWrapper, mkLocalIdOrCoVar bndr_name pat_ty) }+ ; return (idHsWrapper, mkLocalIdOrCoVar bndr_name pat_mult 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+newLetBndr :: LetBndrSpec -> Name -> Mult -> TcType -> TcM TcId -- Make up a suitable Id for the pattern-binder. -- See Note [Typechecking pattern bindings], item (4) in GHC.Tc.Gen.Bind --@@ -248,11 +251,11 @@ -- 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+newLetBndr LetLclBndr name w ty = do { mono_name <- cloneLocalName name- ; return (mkLocalId mono_name ty) }-newLetBndr (LetGblBndr prags) name ty- = addInlinePrags (mkLocalId name ty) (lookupPragEnv prags name)+ ; return (mkLocalId mono_name w ty) }+newLetBndr (LetGblBndr prags) name w ty+ = addInlinePrags (mkLocalId name w ty) (lookupPragEnv prags name) tc_sub_type :: PatEnv -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper -- tcSubTypeET with the UserTypeCtxt specialised to GenSigCtxt@@ -322,16 +325,16 @@ ; loop penv args } ---------------------tc_lpat :: ExpSigmaType- -> Checker (LPat GhcRn) (LPat GhcTcId)+tc_lpat :: Scaled ExpSigmaType+ -> Checker (LPat GhcRn) (LPat GhcTc) tc_lpat pat_ty penv (L span pat) thing_inside = setSrcSpan span $ do { (pat', res) <- maybeWrapPatCtxt pat (tc_pat pat_ty penv pat) thing_inside ; return (L span pat', res) } -tc_lpats :: [ExpSigmaType]- -> Checker [LPat GhcRn] [LPat GhcTcId]+tc_lpats :: [Scaled ExpSigmaType]+ -> Checker [LPat GhcRn] [LPat GhcTc] tc_lpats tys penv pats = ASSERT2( equalLength pats tys, ppr pats $$ ppr tys ) tcMultiple (\ penv' (p,t) -> tc_lpat t penv' p)@@ -339,17 +342,24 @@ (zipEqual "tc_lpats" pats tys) ---------------------tc_pat :: ExpSigmaType+-- See Note [tcSubMult's wrapper] in TcUnify.+checkManyPattern :: Scaled a -> TcM HsWrapper+checkManyPattern pat_ty = tcSubMult NonLinearPatternOrigin Many (scaledMult pat_ty)++tc_pat :: Scaled ExpSigmaType -- ^ Fully refined result type- -> Checker (Pat GhcRn) (Pat GhcTcId)+ -> Checker (Pat GhcRn) (Pat GhcTc) -- ^ Translated pattern+ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of VarPat x (L l name) -> do { (wrap, id) <- tcPatBndr penv name pat_ty- ; res <- tcExtendIdEnv1 name id thing_inside- ; pat_ty <- readExpType pat_ty- ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) }+ ; (res, mult_wrap) <- tcCheckUsage name (scaledMult pat_ty) $+ tcExtendIdEnv1 name id thing_inside+ -- See Note [tcSubMult's wrapper] in TcUnify.+ ; pat_ty <- readExpType (scaledThing pat_ty)+ ; return (mkHsWrapPat (wrap <.> mult_wrap) (VarPat x (L l id)) pat_ty, res) } ParPat x pat -> do { (pat', res) <- tc_lpat pat_ty penv pat thing_inside@@ -360,7 +370,9 @@ ; return (BangPat x pat', res) } LazyPat x pat -> do- { (pat', (res, pat_ct))+ { mult_wrap <- checkManyPattern pat_ty+ -- See Note [tcSubMult's wrapper] in TcUnify.+ ; (pat', (res, pat_ct)) <- tc_lpat pat_ty (makeLazy penv) pat $ captureConstraints thing_inside -- Ignore refined penv', revert to penv@@ -370,20 +382,24 @@ -- see Note [Hopping the LIE in lazy patterns] -- Check that the expected pattern type is itself lifted- ; pat_ty <- readExpType pat_ty+ ; pat_ty <- readExpType (scaledThing pat_ty) ; _ <- unifyType Nothing (tcTypeKind pat_ty) liftedTypeKind - ; return (LazyPat x pat', res) }+ ; return (mkHsWrapPat mult_wrap (LazyPat x pat') pat_ty, res) } WildPat _ -> do- { res <- thing_inside- ; pat_ty <- expTypeToType pat_ty- ; return (WildPat pat_ty, res) }+ { mult_wrap <- checkManyPattern pat_ty+ -- See Note [tcSubMult's wrapper] in TcUnify.+ ; res <- thing_inside+ ; pat_ty <- expTypeToType (scaledThing pat_ty)+ ; return (mkHsWrapPat mult_wrap (WildPat pat_ty) pat_ty, res) } AsPat x (L nm_loc name) pat -> do- { (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty)+ { mult_wrap <- checkManyPattern pat_ty+ -- See Note [tcSubMult's wrapper] in TcUnify.+ ; (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty) ; (pat', res) <- tcExtendIdEnv1 name bndr_id $- tc_lpat (mkCheckExpType $ idType bndr_id)+ tc_lpat (pat_ty `scaledSet`(mkCheckExpType $ idType bndr_id)) penv pat thing_inside -- NB: if we do inference on: -- \ (y@(x::forall a. a->a)) = e@@ -392,81 +408,97 @@ -- 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) }+ ; pat_ty <- readExpType (scaledThing pat_ty)+ ; return (mkHsWrapPat (wrap <.> mult_wrap) (AsPat x (L nm_loc bndr_id) pat') pat_ty, res) } ViewPat _ expr pat -> 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))+ { mult_wrap <- checkManyPattern pat_ty+ -- See Note [tcSubMult's wrapper] in TcUnify. --- -- TEMPORARY: pending simple subsumption, use tcInferSigma- -- When removing this, remove it from Expr.hs-boot too- ; (expr',expr_ty) <- tcInferSigma expr+ -- It should be possible to have view patterns at linear (or otherwise+ -- non-Many) multiplicity. But it is not clear at the moment what+ -- restriction need to be put in place, if any, for linear view+ -- patterns to desugar to type-correct Core. + ; (expr',expr_ty) <- tcInferRho expr+ -- Note [View patterns and polymorphism]+ -- 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)+ ; (expr_wrap1, Scaled _mult inf_arg_ty, inf_res_sigma)+ <- matchActualFunTySigma herald expr_orig (Just (unLoc expr)) (1,[]) expr_ty+ -- See Note [View patterns and polymorphism]+ -- expr_wrap1 :: expr_ty "->" (inf_arg_ty -> inf_res_sigma) -- Check that overall pattern is more polymorphic than arg type- ; expr_wrap2 <- tc_sub_type penv pat_ty inf_arg_ty+ ; expr_wrap2 <- tc_sub_type penv (scaledThing pat_ty) inf_arg_ty -- expr_wrap2 :: pat_ty "->" inf_arg_ty - -- Pattern must have inf_res_ty- ; (pat', res) <- tc_lpat (mkCheckExpType inf_res_ty) penv pat thing_inside+ -- Pattern must have inf_res_sigma+ ; (pat', res) <- tc_lpat (pat_ty `scaledSet` mkCheckExpType inf_res_sigma) penv pat thing_inside - ; pat_ty <- readExpType pat_ty+ ; let Scaled w h_pat_ty = pat_ty+ ; pat_ty <- readExpType h_pat_ty ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper- pat_ty inf_res_ty doc- -- expr_wrap2' :: (inf_arg_ty -> inf_res_ty) "->"- -- (pat_ty -> inf_res_ty)- expr_wrap = expr_wrap2' <.> expr_wrap1+ (Scaled w pat_ty) inf_res_sigma doc+ -- expr_wrap2' :: (inf_arg_ty -> inf_res_sigma) "->"+ -- (pat_ty -> inf_res_sigma)+ expr_wrap = expr_wrap2' <.> expr_wrap1 <.> mult_wrap doc = text "When checking the view pattern function:" <+> (ppr expr) ; return (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res)} +{- Note [View patterns and polymorphism]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this exotic example:+ pair :: forall a. Bool -> a -> forall b. b -> (a,b)++ f :: Int -> blah+ f (pair True -> x) = ...here (x :: forall b. b -> (Int,b))++The expresion (pair True) should have type+ pair True :: Int -> forall b. b -> (Int,b)+so that it is ready to consume the incoming Int. It should be an+arrow type (t1 -> t2); hence using (tcInferRho expr).++Then, when taking that arrow apart we want to get a *sigma* type+(forall b. b->(Int,b)), because that's what we want to bind 'x' to.+Fortunately that's what matchExpectedFunTySigma returns anyway.+-}+ -- Type signatures in patterns -- See Note [Pattern coercions] below SigPat _ pat sig_ty -> do { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv)- sig_ty pat_ty+ sig_ty (scaledThing 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 (mkCheckExpType inner_ty) penv pat thing_inside- ; pat_ty <- readExpType pat_ty+ tc_lpat (pat_ty `scaledSet` mkCheckExpType inner_ty) penv pat thing_inside+ ; pat_ty <- readExpType (scaledThing pat_ty) ; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) } ------------------------ -- Lists, tuples, arrays ListPat Nothing pats -> do- { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv pat_ty- ; (pats', res) <- tcMultiple (tc_lpat $ mkCheckExpType elt_ty)+ { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv (scaledThing pat_ty)+ ; (pats', res) <- tcMultiple (tc_lpat (pat_ty `scaledSet` mkCheckExpType elt_ty)) penv pats thing_inside- ; pat_ty <- readExpType pat_ty+ ; pat_ty <- readExpType (scaledThing pat_ty) ; return (mkHsWrapPat coi (ListPat (ListPatTc elt_ty Nothing) pats') pat_ty, res) } ListPat (Just e) pats -> do- { tau_pat_ty <- expTypeToType pat_ty+ { tau_pat_ty <- expTypeToType (scaledThing pat_ty) ; ((pats', res, elt_ty), e') <- tcSyntaxOpGen ListOrigin e [SynType (mkCheckExpType tau_pat_ty)] SynList $- \ [elt_ty] ->- do { (pats', res) <- tcMultiple (tc_lpat $ mkCheckExpType elt_ty)+ \ [elt_ty] _ ->+ do { (pats', res) <- tcMultiple (tc_lpat (pat_ty `scaledSet` mkCheckExpType elt_ty)) penv pats thing_inside ; return (pats', res, elt_ty) } ; return (ListPat (ListPatTc elt_ty (Just (tau_pat_ty,e'))) pats', res)@@ -478,12 +510,12 @@ -- 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+ penv (scaledThing 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 (map mkCheckExpType con_arg_tys)+ ; (pats', res) <- tc_lpats (map (scaledSet pat_ty . mkCheckExpType) con_arg_tys) penv pats thing_inside ; dflags <- getDynFlags@@ -500,7 +532,7 @@ isBoxed boxity = LazyPat noExtField (noLoc unmangled_result) | otherwise = unmangled_result - ; pat_ty <- readExpType pat_ty+ ; pat_ty <- readExpType (scaledThing pat_ty) ; ASSERT( con_arg_tys `equalLength` pats ) -- Syntactically enforced return (mkHsWrapPat coi possibly_mangled_result pat_ty, res) }@@ -508,12 +540,12 @@ SumPat _ pat alt arity -> do { let tc = sumTyCon arity ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)- penv pat_ty+ penv (scaledThing pat_ty) ; -- Drop levity vars, we don't care about them here let con_arg_tys = drop arity arg_tys- ; (pat', res) <- tc_lpat (mkCheckExpType (con_arg_tys `getNth` (alt - 1)))+ ; (pat', res) <- tc_lpat (pat_ty `scaledSet` mkCheckExpType (con_arg_tys `getNth` (alt - 1))) penv pat thing_inside- ; pat_ty <- readExpType pat_ty+ ; pat_ty <- readExpType (scaledThing pat_ty) ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty , res) }@@ -527,9 +559,9 @@ -- Literal patterns LitPat x simple_lit -> do { let lit_ty = hsLitType simple_lit- ; wrap <- tc_sub_type penv pat_ty lit_ty+ ; wrap <- tc_sub_type penv (scaledThing pat_ty) lit_ty ; res <- thing_inside- ; pat_ty <- readExpType pat_ty+ ; pat_ty <- readExpType (scaledThing pat_ty) ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty , res) } @@ -552,11 +584,16 @@ -- -- When there is no negation, neg_lit_ty and lit_ty are the same NPat _ (L l over_lit) mb_neg eq -> do- { let orig = LiteralOrigin over_lit+ { mult_wrap <- checkManyPattern pat_ty+ -- See Note [tcSubMult's wrapper] in TcUnify.+ --+ -- It may be possible to refine linear pattern so that they work in+ -- linear environments. But it is not clear how useful this is.+ ; let orig = LiteralOrigin over_lit ; ((lit', mb_neg'), eq')- <- tcSyntaxOp orig eq [SynType pat_ty, SynAny]+ <- tcSyntaxOp orig eq [SynType (scaledThing pat_ty), SynAny] (mkCheckExpType boolTy) $- \ [neg_lit_ty] ->+ \ [neg_lit_ty] _ -> let new_over_lit lit_ty = newOverloadedLit over_lit (mkCheckExpType lit_ty) in case mb_neg of@@ -565,11 +602,14 @@ -- The 'negate' is re-mappable syntax second Just <$> (tcSyntaxOp orig neg [SynRho] (mkCheckExpType neg_lit_ty) $- \ [lit_ty] -> new_over_lit lit_ty)+ \ [lit_ty] _ -> new_over_lit lit_ty)+ -- applied to a closed literal: linearity doesn't matter as+ -- literals are typed in an empty environment, hence have+ -- all multiplicities. ; res <- thing_inside- ; pat_ty <- readExpType pat_ty- ; return (NPat pat_ty (L l lit') mb_neg' eq', res) }+ ; pat_ty <- readExpType (scaledThing pat_ty)+ ; return (mkHsWrapPat mult_wrap (NPat pat_ty (L l lit') mb_neg' eq') pat_ty, res) } {- Note [NPlusK patterns]@@ -602,19 +642,21 @@ -- See Note [NPlusK patterns] NPlusKPat _ (L nm_loc name) (L loc lit) _ ge minus -> do- { pat_ty <- expTypeToType pat_ty+ { mult_wrap <- checkManyPattern pat_ty+ -- See Note [tcSubMult's wrapper] in TcUnify.+ ; pat_ty <- expTypeToType (scaledThing pat_ty) ; let orig = LiteralOrigin lit ; (lit1', ge') <- tcSyntaxOp orig ge [synKnownType pat_ty, SynRho] (mkCheckExpType boolTy) $- \ [lit1_ty] ->+ \ [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] ->+ \ [lit2_ty, var_ty] _ -> do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty) ; (wrap, bndr_id) <- setSrcSpan nm_loc $- tcPatBndr penv name (mkCheckExpType var_ty)+ tcPatBndr penv name (unrestricted $ mkCheckExpType var_ty) -- co :: var_ty ~ idType bndr_id -- minus_wrap is applicable to minus'@@ -631,7 +673,7 @@ ; 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+ -- Case (3) from Note [NoSyntaxExpr] in "GHC.Hs.Expr" SyntaxExprTc { syn_expr = minus'_expr , syn_arg_wraps = minus'_arg_wraps , syn_res_wrap = minus'_res_wrap }@@ -642,7 +684,7 @@ -- 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) }+ ; return (mkHsWrapPat mult_wrap pat' pat_ty, 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.@@ -805,9 +847,9 @@ -- with scrutinee of type (T ty) tcConPat :: PatEnv -> Located Name- -> ExpSigmaType -- Type of the pattern+ -> Scaled ExpSigmaType -- Type of the pattern -> HsConPatDetails GhcRn -> TcM a- -> TcM (Pat GhcTcId, a)+ -> TcM (Pat GhcTc, a) tcConPat penv con_lname@(L _ con_name) pat_ty arg_pats thing_inside = do { con_like <- tcLookupConLike con_name ; case con_like of@@ -818,10 +860,10 @@ } tcDataConPat :: PatEnv -> Located Name -> DataCon- -> ExpSigmaType -- Type of the pattern+ -> Scaled ExpSigmaType -- Type of the pattern -> HsConPatDetails GhcRn -> TcM a- -> TcM (Pat GhcTcId, a)-tcDataConPat penv (L con_span con_name) data_con pat_ty+ -> TcM (Pat GhcTc, a)+tcDataConPat penv (L con_span con_name) data_con pat_ty_scaled arg_pats thing_inside = do { let tycon = dataConTyCon data_con -- For data families this is the representation tycon@@ -832,13 +874,13 @@ -- 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+ ; (wrap, ctxt_res_tys) <- matchExpectedConTy penv tycon pat_ty_scaled+ ; pat_ty <- readExpType (scaledThing pat_ty_scaled) -- Add the stupid theta ; setSrcSpan con_span $ addDataConStupidTheta data_con ctxt_res_tys - ; let all_arg_tys = eqSpecPreds eq_spec ++ theta ++ arg_tys+ ; let all_arg_tys = eqSpecPreds eq_spec ++ theta ++ (map scaledThing arg_tys) ; checkExistentials ex_tvs all_arg_tys penv ; tenv <- instTyVarsWith PatOrigin univ_tvs ctxt_res_tys@@ -853,7 +895,9 @@ -- pat_ty' is type of the actual constructor application -- pat_ty' /= pat_ty iff coi /= IdCo - arg_tys' = substTys tenv arg_tys+ arg_tys' = substScaledTys tenv arg_tys+ pat_mult = scaledMult pat_ty_scaled+ arg_tys_scaled = map (scaleScaled pat_mult) arg_tys' ; traceTc "tcConPat" (vcat [ ppr con_name , pprTyVars univ_tvs@@ -867,7 +911,7 @@ ; 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', res) <- tcConArgs (RealDataCon data_con) arg_tys_scaled penv arg_pats thing_inside ; let res_pat = ConPat { pat_con = header , pat_args = arg_pats'@@ -904,7 +948,7 @@ ; given <- newEvVars theta' ; (ev_binds, (arg_pats', res)) <- checkConstraints skol_info ex_tvs' given $- tcConArgs (RealDataCon data_con) arg_tys' penv arg_pats thing_inside+ tcConArgs (RealDataCon data_con) arg_tys_scaled penv arg_pats thing_inside ; let res_pat = ConPat { pat_con = header@@ -921,23 +965,28 @@ } } tcPatSynPat :: PatEnv -> Located Name -> PatSyn- -> ExpSigmaType -- Type of the pattern+ -> Scaled ExpSigmaType -- Type of the pattern -> HsConPatDetails GhcRn -> TcM a- -> TcM (Pat GhcTcId, a)+ -> TcM (Pat GhcTc, 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+ ; let all_arg_tys = ty : prov_theta ++ (map scaledThing 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+ arg_tys' = substScaledTys tenv arg_tys+ pat_mult = scaledMult pat_ty+ arg_tys_scaled = map (scaleScaled pat_mult) arg_tys' prov_theta' = substTheta tenv prov_theta req_theta' = substTheta tenv req_theta - ; wrap <- tc_sub_type penv pat_ty ty'+ ; mult_wrap <- checkManyPattern pat_ty+ -- See Note [tcSubMult's wrapper] in TcUnify.++ ; wrap <- tc_sub_type penv (scaledThing pat_ty) ty' ; traceTc "tcPatSynPat" (ppr pat_syn $$ ppr pat_ty $$ ppr ty' $$@@ -958,7 +1007,7 @@ ; traceTc "checkConstraints {" Outputable.empty ; (ev_binds, (arg_pats', res)) <- checkConstraints skol_info ex_tvs' prov_dicts' $- tcConArgs (PatSynCon pat_syn) arg_tys' penv arg_pats thing_inside+ tcConArgs (PatSynCon pat_syn) arg_tys_scaled penv arg_pats thing_inside ; traceTc "checkConstraints }" (ppr ev_binds) ; let res_pat = ConPat { pat_con = L con_span $ PatSynCon pat_syn@@ -971,8 +1020,8 @@ , cpt_wrap = req_wrap } }- ; pat_ty <- readExpType pat_ty- ; return (mkHsWrapPat wrap res_pat pat_ty, res) }+ ; pat_ty <- readExpType (scaledThing pat_ty)+ ; return (mkHsWrapPat (wrap <.> mult_wrap) res_pat pat_ty, res) } ---------------------------- -- | Convenient wrapper for calling a matchExpectedXXX function@@ -993,9 +1042,9 @@ -- 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+ -> Scaled 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@@ -1003,7 +1052,7 @@ | 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+ = do { pat_ty <- expTypeToType (scaledThing exp_pat_ty) ; (wrap, pat_rho) <- topInstantiate orig pat_ty ; (subst, tvs') <- newMetaTyVars (tyConTyVars data_tc)@@ -1030,7 +1079,7 @@ ; return ( mkWpCastR full_co <.> wrap, tys') } | otherwise- = do { pat_ty <- expTypeToType exp_pat_ty+ = do { pat_ty <- expTypeToType (scaledThing exp_pat_ty) ; (wrap, pat_rho) <- topInstantiate orig pat_ty ; (coi, tys) <- matchExpectedTyConApp data_tc pat_rho ; return (mkWpCastN (mkTcSymCo coi) <.> wrap, tys) }@@ -1064,7 +1113,7 @@ error messages; it's a purely internal thing -} -tcConArgs :: ConLike -> [TcSigmaType]+tcConArgs :: ConLike -> [Scaled TcSigmaType] -> Checker (HsConPatDetails GhcRn) (HsConPatDetails GhcTc) tcConArgs con_like arg_tys penv con_args thing_inside = case con_args of@@ -1094,7 +1143,7 @@ ; return (RecCon (HsRecFields rpats' dd), res) } where tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn))- (LHsRecField GhcTcId (LPat GhcTcId))+ (LHsRecField GhcTc (LPat GhcTc)) tc_field penv (L l (HsRecField (L loc (FieldOcc sel (L lr rdr))) pat pun)) thing_inside@@ -1106,7 +1155,7 @@ pun), res) } - find_field_ty :: Name -> FieldLabelString -> TcM TcType+ find_field_ty :: Name -> FieldLabelString -> TcM (Scaled TcType) find_field_ty sel lbl = case [ty | (fl, ty) <- field_tys, flSelector fl == sel ] of @@ -1123,14 +1172,15 @@ traceTc "find_field" (ppr pat_ty <+> ppr extras) ASSERT( null extras ) (return pat_ty) - field_tys :: [(FieldLabel, TcType)]+ field_tys :: [(FieldLabel, Scaled 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 penv (arg_pat, arg_ty) = tc_lpat (mkCheckExpType arg_ty) penv arg_pat+tcConArg :: Checker (LPat GhcRn, Scaled TcSigmaType) (LPat GhcTc)+tcConArg penv (arg_pat, Scaled arg_mult arg_ty)+ = tc_lpat (Scaled arg_mult (mkCheckExpType arg_ty)) penv arg_pat addDataConStupidTheta :: DataCon -> [TcType] -> TcM () -- Instantiate the "stupid theta" of the data con, and throw
compiler/GHC/Tc/Gen/Rule.hs view
@@ -7,7 +7,7 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeFamilies #-} --- | Typechecking transformation rules+-- | Typechecking rewrite rules module GHC.Tc.Gen.Rule ( tcRules ) where import GHC.Prelude@@ -98,10 +98,10 @@ equation. -} -tcRules :: [LRuleDecls GhcRn] -> TcM [LRuleDecls GhcTcId]+tcRules :: [LRuleDecls GhcRn] -> TcM [LRuleDecls GhcTc] tcRules decls = mapM (wrapLocM tcRuleDecls) decls -tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTcId)+tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTc) tcRuleDecls (HsRules { rds_src = src , rds_rules = decls }) = do { tc_decls <- mapM (wrapLocM tcRule) decls@@ -109,7 +109,7 @@ , rds_src = src , rds_rules = tc_decls } } -tcRule :: RuleDecl GhcRn -> TcM (RuleDecl GhcTcId)+tcRule :: RuleDecl GhcRn -> TcM (RuleDecl GhcTc) tcRule (HsRule { rd_ext = ext , rd_name = rname@(L _ (_,name)) , rd_act = act@@ -199,7 +199,7 @@ do { -- See Note [Solve order for RULES] ((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs) ; (rhs', rhs_wanted) <- captureConstraints $- tcLExpr rhs (mkCheckExpType rule_ty)+ tcCheckMonoExpr rhs rule_ty ; let all_lhs_wanted = bndr_wanted `andWC` lhs_wanted ; return (id_bndrs, lhs', all_lhs_wanted, rhs', rhs_wanted, rule_ty) } } @@ -221,7 +221,7 @@ tcRuleTmBndrs (L _ (RuleBndr _ (L _ name)) : rule_bndrs) = do { ty <- newOpenFlexiTyVarTy ; (tyvars, tmvars) <- tcRuleTmBndrs rule_bndrs- ; return (tyvars, mkLocalId name ty : tmvars) }+ ; return (tyvars, mkLocalId name Many 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@@ -230,7 +230,7 @@ -- 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+ ; let id = mkLocalId name Many id_ty -- See Note [Typechecking pattern signature binders] in GHC.Tc.Gen.HsType -- The type variables scope over subsequent bindings; yuk@@ -239,7 +239,7 @@ ; return (map snd tvs ++ tyvars, id : tmvars) } ruleCtxt :: FastString -> SDoc-ruleCtxt name = text "When checking the transformation rule" <+>+ruleCtxt name = text "When checking the rewrite rule" <+> doubleQuotes (ftext name)
compiler/GHC/Tc/Gen/Sig.hs view
@@ -40,6 +40,7 @@ import GHC.Tc.Utils.Env( tcLookupId ) import GHC.Tc.Types.Evidence( HsWrapper, (<.>) ) import GHC.Core.Type ( mkTyVarBinders )+import GHC.Core.Multiplicity import GHC.Driver.Session import GHC.Types.Var ( TyVar, Specificity(..), tyVarKind, binderVars )@@ -224,7 +225,12 @@ = do { sigma_ty <- tcHsSigWcType ctxt_F hs_sig_ty ; traceTc "tcuser" (ppr sigma_ty) ; return $- CompleteSig { sig_bndr = mkLocalId name sigma_ty+ CompleteSig { sig_bndr = mkLocalId name Many sigma_ty+ -- We use `Many' as the multiplicity here,+ -- as if this identifier corresponds to+ -- anything, it is a top-level+ -- definition. Which are all unrestricted in+ -- the current implementation. , sig_ctxt = ctxt_T , sig_loc = loc } } -- Location of the <type> in f :: <type>@@ -266,7 +272,7 @@ HsWildCardTy _ -> False HsAppTy _ ty1 ty2 -> go ty1 && go ty2 HsAppKindTy _ ty ki -> go ty && go ki- HsFunTy _ ty1 ty2 -> go ty1 && go ty2+ HsFunTy _ w ty1 ty2 -> go ty1 && go ty2 && go (arrowToHsType w) HsListTy _ ty -> go ty HsTupleTy _ _ tys -> gos tys HsSumTy _ tys -> gos tys@@ -279,8 +285,8 @@ 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+ HsForAllTy { hst_tele = tele+ , hst_body = ty } -> no_anon_wc_tele tele && go ty HsQualTy { hst_ctxt = L _ ctxt , hst_body = ty } -> gos ctxt && go ty@@ -293,8 +299,10 @@ gos = all go -no_anon_wc_bndrs :: [LHsTyVarBndr flag GhcRn] -> Bool-no_anon_wc_bndrs ltvs = all (go . unLoc) ltvs+no_anon_wc_tele :: HsForAllTelescope GhcRn -> Bool+no_anon_wc_tele tele = case tele of+ HsForAllVis { hsf_vis_bndrs = ltvs } -> all (go . unLoc) ltvs+ HsForAllInvis { hsf_invis_bndrs = ltvs } -> all (go . unLoc) ltvs where go (UserTyVar _ _ _) = True go (KindedTyVar _ _ _ ki) = no_anon_wc ki@@ -434,7 +442,7 @@ -- arguments become the types of binders. We thus cannot allow -- levity polymorphism here ; let (arg_tys, _) = tcSplitFunTys body_ty'- ; mapM_ (checkForLevPoly empty) arg_tys+ ; mapM_ (checkForLevPoly empty . scaledThing) arg_tys ; traceTc "tcTySig }" $ vcat [ text "implicit_tvs" <+> ppr_tvs implicit_tvs'@@ -635,6 +643,7 @@ 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 = <poly_rhs>@@ -674,13 +683,14 @@ 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.)+1. In tcSpecWrapper, rather than calling tcSubType, we directly call+ skolemise/instantiate. That is mainly because of wrinkle (2). + Historical note: in the past, tcSubType did co/contra stuff, which+ could generate too complex a LHS for the RULE, which was another+ reason for not using tcSubType. But that reason has gone away+ with simple subsumption (#17775).+ 2. We need to take care with type families (#5821). Consider type instance F Int = Bool f :: Num a => a -> F a@@ -775,7 +785,7 @@ -- See Note [Handling SPECIALISE pragmas], wrinkle 1 tcSpecWrapper ctxt poly_ty spec_ty = do { (sk_wrap, inst_wrap)- <- tcSkolemise ctxt spec_ty $ \ _ spec_tau ->+ <- tcSkolemise ctxt spec_ty $ \ spec_tau -> do { (inst_wrap, tau) <- topInstantiate orig poly_ty ; _ <- unifyType Nothing spec_tau tau -- Deliberately ignore the evidence
compiler/GHC/Tc/Gen/Splice.hs view
@@ -44,6 +44,7 @@ import GHC.Types.Name import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType+import GHC.Core.Multiplicity import GHC.Utils.Outputable import GHC.Tc.Gen.Expr@@ -150,10 +151,10 @@ ************************************************************************ -} -tcTypedBracket :: HsExpr GhcRn -> HsBracket GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId)+tcTypedBracket :: HsExpr GhcRn -> HsBracket GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) tcUntypedBracket :: HsExpr GhcRn -> HsBracket GhcRn -> [PendingRnSplice] -> ExpRhoType- -> TcM (HsExpr GhcTcId)-tcSpliceExpr :: HsSplice GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId)+ -> TcM (HsExpr GhcTc)+tcSpliceExpr :: HsSplice GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) -- None of these functions add constraints to the LIE -- runQuasiQuoteExpr :: HsQuasiQuote RdrName -> RnM (LHsExpr RdrName)@@ -238,7 +239,7 @@ -- | A type variable with kind * -> * named "m" mkMetaTyVar :: TcM TyVar mkMetaTyVar =- newNamedFlexiTyVar (fsLit "m") (mkVisFunTy liftedTypeKind liftedTypeKind)+ newNamedFlexiTyVar (fsLit "m") (mkVisFunTyMany liftedTypeKind liftedTypeKind) -- | For a type 'm', emit the constraint 'Quote m'.@@ -288,7 +289,7 @@ = 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+ ; expr' <- tcCheckPolyExpr expr expected_type ; return (PendingTcSplice splice_name expr') } where meta_ty_name = case flavour of@@ -618,7 +619,7 @@ ; meta_exp_ty <- tcTExpTy m_var res_ty ; expr' <- setStage pop_stage $ setConstraintVar lie_var $- tcLExpr expr (mkCheckExpType meta_exp_ty)+ tcCheckMonoExpr expr meta_exp_ty ; untypeq <- tcLookupId unTypeQName ; let expr'' = mkHsApp (mkLHsWrap (applyQuoteWrapper q)@@ -647,7 +648,7 @@ -- 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)+ tcCheckMonoExpr expr meta_exp_ty ; lcl_env <- getLclEnv ; let delayed_splice = DelayedSplice lcl_env expr res_ty q_expr@@ -684,7 +685,7 @@ captureConstraints $ addErrCtxt (spliceResultDoc zonked_q_expr) $ do { (exp3, _fvs) <- rnLExpr expr2- ; tcLExpr exp3 (mkCheckExpType zonked_ty)}+ ; tcCheckMonoExpr exp3 zonked_ty } ; ev <- simplifyTop wcs ; return $ unLoc (mkHsDictLet (EvBinds ev) res) }@@ -717,7 +718,7 @@ -- 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+-- The recursive call to tcCheckPolyExpr will simply expand the -- inner escape before dealing with the outer one tcTopSpliceExpr isTypedSplice tc_action@@ -1431,14 +1432,14 @@ -- must error before proceeding to typecheck the -- renamed type, as that will result in GHC -- internal errors (#13837).- bindLRdrNames tv_rdrs $ \ tv_names ->+ rnImplicitBndrs Nothing 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+ tcInferLHsType rn_ty ; ty <- zonkTcTypeToType ty -- Substitute out the meta type variables -- In particular, the type might have kind@@ -1757,7 +1758,7 @@ filterOut (`elemVarSet` eq_spec_tvs) g_univ_tvs ; let (tvb_subst, g_user_tvs) = subst_tv_binders univ_subst g_user_tvs' g_theta = substTys tvb_subst g_theta'- g_arg_tys = substTys tvb_subst g_arg_tys'+ g_arg_tys = substTys tvb_subst (map scaledThing 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)@@ -2115,27 +2116,32 @@ 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 })+reifyType ty@(FunTy { ft_af = af, ft_mult = Many, 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) }+ | otherwise = do { [r1,r2] <- reifyTypes [t1,t2]+ ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }+reifyType ty@(FunTy { ft_af = af, ft_mult = tm, ft_arg = t1, ft_res = t2 })+ | InvisArg <- af = noTH (sLit "linear invisible argument") (ppr ty)+ | otherwise = do { [rm,r1,r2] <- reifyTypes [tm,t1,t2]+ ; return (TH.MulArrowT `TH.AppT` rm `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- tvbndrs' <- reifyTyVarBndrs tvbndrs- case argToForallVisFlag argf of- ForallVis -> do phi' <- reifyType phi- let tvs = map (() <$) tvbndrs'- -- see Note [Specificity in HsForAllTy] in GHC.Hs.Type- pure $ TH.ForallVisT tvs phi'- ForallInvis -> do let (cxt, tau) = tcSplitPhiTy phi- cxt' <- reifyCxt cxt- tau' <- reifyType tau- pure $ TH.ForallT tvbndrs' cxt' tau'- where- (tvbndrs, phi) = tcSplitForAllTysSameVis argf ty+reify_for_all argf ty+ | isVisibleArgFlag argf+ = do let (req_bndrs, phi) = tcSplitForAllTysReq ty+ tvbndrs' <- reifyTyVarBndrs req_bndrs+ phi' <- reifyType phi+ pure $ TH.ForallVisT tvbndrs' phi'+ | otherwise+ = do let (inv_bndrs, phi) = tcSplitForAllTysInvis ty+ tvbndrs' <- reifyTyVarBndrs inv_bndrs+ let (cxt, tau) = tcSplitPhiTy phi+ cxt' <- reifyCxt cxt+ tau' <- reifyType tau+ pure $ TH.ForallT tvbndrs' cxt' tau' reifyTyLit :: TyCoRep.TyLit -> TcM TH.TyLit reifyTyLit (NumTyLit n) = return (TH.NumTyLit n)@@ -2145,7 +2151,7 @@ reifyTypes = mapM reifyType reifyPatSynType- :: ([InvisTVBinder], ThetaType, [InvisTVBinder], ThetaType, [Type], Type) -> TcM TH.Type+ :: ([InvisTVBinder], ThetaType, [InvisTVBinder], ThetaType, [Scaled 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]@@ -2177,10 +2183,6 @@ reifyFlag SpecifiedSpec = TH.SpecifiedSpec reifyFlag InferredSpec = TH.InferredSpec -instance ReifyFlag ArgFlag TH.Specificity where- reifyFlag Required = TH.SpecifiedSpec- reifyFlag (Invisible s) = reifyFlag s- reifyTyVars :: [TyVar] -> TcM [TH.TyVarBndr ()] reifyTyVars = reifyTyVarBndrs . map mk_bndr where@@ -2217,7 +2219,7 @@ else TH.TupleT arity | tc `hasKey` constraintKindTyConKey = TH.ConstraintT- | tc `hasKey` funTyConKey = TH.ArrowT+ | tc `hasKey` unrestrictedFunTyConKey = TH.ArrowT | tc `hasKey` listTyConKey = TH.ListT | tc `hasKey` nilDataConKey = TH.PromotedNilT | tc `hasKey` consDataConKey = TH.PromotedConsT
compiler/GHC/Tc/Gen/Splice.hs-boot view
@@ -9,7 +9,7 @@ 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.Extension ( GhcRn, GhcPs, GhcTc ) import GHC.Hs ( HsSplice, HsBracket, HsExpr, LHsExpr, LHsType, LPat, LHsDecl, ThModFinalizers )@@ -17,28 +17,28 @@ tcSpliceExpr :: HsSplice GhcRn -> ExpRhoType- -> TcM (HsExpr GhcTcId)+ -> TcM (HsExpr GhcTc) tcUntypedBracket :: HsExpr GhcRn -> HsBracket GhcRn -> [PendingRnSplice] -> ExpRhoType- -> TcM (HsExpr GhcTcId)+ -> TcM (HsExpr GhcTc) tcTypedBracket :: HsExpr GhcRn -> HsBracket GhcRn -> ExpRhoType- -> TcM (HsExpr GhcTcId)+ -> TcM (HsExpr GhcTc) runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc) runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation -tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)+tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc) -runMetaE :: LHsExpr GhcTcId -> TcM (LHsExpr GhcPs)-runMetaP :: LHsExpr GhcTcId -> TcM (LPat GhcPs)-runMetaT :: LHsExpr GhcTcId -> TcM (LHsType GhcPs)-runMetaD :: LHsExpr GhcTcId -> TcM [LHsDecl GhcPs]+runMetaE :: LHsExpr GhcTc -> TcM (LHsExpr GhcPs)+runMetaP :: LHsExpr GhcTc -> TcM (LPat GhcPs)+runMetaT :: LHsExpr GhcTc -> TcM (LHsType GhcPs)+runMetaD :: LHsExpr GhcTc -> TcM [LHsDecl GhcPs] lookupThName_maybe :: TH.Name -> TcM (Maybe Name) runQuasi :: TH.Q a -> TcM a
compiler/GHC/Tc/Instance/Class.hs view
@@ -60,7 +60,7 @@ | InClsInst { ai_class :: Class , ai_tyvars :: [TyVar] -- ^ The /scoped/ tyvars of the instance -- Why scoped? See bind_me in- -- GHC.Tc.Validity.checkConsistentFamInst+ -- 'GHC.Tc.Validity.checkConsistentFamInst' , ai_inst_env :: VarEnv Type -- ^ Maps /class/ tyvars to their instance types -- See Note [Matching in the consistent-instantiation check] }@@ -259,12 +259,12 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 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+defining singleton values. Here is the key stuff from GHC.TypeNats class KnownNat (n :: Nat) where natSing :: SNat n - newtype SNat (n :: Nat) = SNat Integer+ newtype SNat (n :: Nat) = SNat Natural Conceptually, this class has infinitely many instances: @@ -291,10 +291,10 @@ 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+ natVal :: KnownNat n => proxy n -> Natural 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,+and more efficient to pass around a Natural rather than an entire function, especially when the `KnowNat` evidence is packaged up in an existential. The story for kind `Symbol` is analogous:@@ -354,9 +354,7 @@ -- 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+ | Just n <- isNumLitTy ty = makeLitDict clas ty (mkNaturalExpr n) 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.@@ -422,7 +420,7 @@ | 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 (mult,arg,ret) <- splitFunTy_maybe t = doFunTy clas t mult 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@@ -430,15 +428,15 @@ 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+doFunTy :: Class -> Type -> Mult -> Type -> Type -> TcM ClsInstResult+doFunTy clas ty mult arg_ty ret_ty = return $ OneInst { cir_new_theta = preds , cir_mk_ev = mk_ev , cir_what = BuiltinInstance } 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)+ preds = map (mk_typeable_pred clas) [mult, arg_ty, ret_ty]+ mk_ev [mult_ev, arg_ev, ret_ev] = evTypeable ty $+ EvTypeableTrFun (EvExpr mult_ev) (EvExpr arg_ev) (EvExpr ret_ev) mk_ev _ = panic "GHC.Tc.Solver.Interact.doFunTy" @@ -685,7 +683,7 @@ -- 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+ ; let theta = mkPrimEqPred sel_ty (mkVisFunTyMany 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
compiler/GHC/Tc/Instance/Family.hs view
@@ -18,7 +18,6 @@ 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@@ -162,34 +161,13 @@ 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+ = do {+ -- Freshen the type variables+ (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@@ -199,10 +177,6 @@ , 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@@ -736,7 +710,7 @@ -- 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.+-- Does checks (2)-(4) of Note [Verifying injectivity annotation] in "GHC.Core.FamInstEnv". checkInjectiveEquation :: FamInst -> TcM () checkInjectiveEquation famInst | isTypeFamilyTyCon tycon
compiler/GHC/Tc/Instance/Typeable.hs view
@@ -147,7 +147,7 @@ -- 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.+-- See Note [Grand plan for Typeable] in "GHC.Tc.Instance.Typeable". mkTypeableBinds :: TcM TcGblEnv mkTypeableBinds = do { dflags <- getDynFlags@@ -346,7 +346,7 @@ -- 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.+-- Note [Built-in syntax and the OrigNameCache] in "GHC.Iface.Env" for more. ghcPrimTypeableTyCons :: [TyCon] ghcPrimTypeableTyCons = concat [ [ runtimeRepTyCon, vecCountTyCon, vecElemTyCon, funTyCon ]@@ -437,7 +437,9 @@ | isLiftedTypeKind ty = True kindIsTypeable (TyVarTy _) = True kindIsTypeable (AppTy a b) = kindIsTypeable a && kindIsTypeable b-kindIsTypeable (FunTy _ a b) = kindIsTypeable a && kindIsTypeable b+kindIsTypeable (FunTy _ w a b) = kindIsTypeable w &&+ kindIsTypeable a &&+ kindIsTypeable b kindIsTypeable (TyConApp tc args) = tyConIsTypeable tc && all kindIsTypeable args kindIsTypeable (ForAllTy{}) = False@@ -466,8 +468,8 @@ builtInKindReps :: [(Kind, Name)] builtInKindReps = [ (star, starKindRepName)- , (mkVisFunTy star star, starArrStarKindRepName)- , (mkVisFunTys [star, star] star, starArrStarArrStarKindRepName)+ , (mkVisFunTyMany star star, starArrStarKindRepName)+ , (mkVisFunTysMany [star, star] star, starArrStarArrStarKindRepName) ] where star = liftedTypeKind@@ -537,7 +539,7 @@ = 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)+ <$> newSysLocalId (fsLit "$krep") Many (mkTyConTy kindRepTyCon) -- do we need to tie a knot here? flip runStateT env $ unKindRepM $ do@@ -591,7 +593,7 @@ new_kind_rep (ForAllTy (Bndr var _) ty) = pprPanic "mkTyConKindRepBinds(ForAllTy)" (ppr var $$ ppr ty) - new_kind_rep (FunTy _ t1 t2)+ new_kind_rep (FunTy _ _ t1 t2) = do rep1 <- getKindRep stuff in_scope t1 rep2 <- getKindRep stuff in_scope t2 return $ nlHsDataCon kindRepFunDataCon
compiler/GHC/Tc/Module.hs view
@@ -183,7 +183,7 @@ 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)+ this_pkg = homeUnit (hsc_dflags hsc_env) pair :: (Module, SrcSpan) pair@(this_mod,_)@@ -268,6 +268,14 @@ then tcRnHsBootDecls hsc_src local_decls else {-# SCC "tcRnSrcDecls" #-} tcRnSrcDecls explicit_mod_hdr local_decls export_ies++ ; whenM (goptM Opt_DoCoreLinting) $+ do { let (warns, errs) = lintGblEnv (hsc_dflags hsc_env) tcg_env+ ; mapBagM_ (addWarn NoReason) warns+ ; mapBagM_ addErr errs+ ; failIfErrsM } -- if we have a lint error, we're only+ -- going to get in deeper trouble by proceeding+ ; setGblEnv tcg_env $ do { -- Process the export list traceRn "rn4a: before exports" empty@@ -321,7 +329,7 @@ = do { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ; ; this_mod <- getModule- ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface)+ ; let { dep_mods :: ModuleNameEnv ModuleNameWithIsBoot ; dep_mods = imp_dep_mods imports -- We want instance declarations from all home-package@@ -1274,7 +1282,7 @@ 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))+ check (eqType (dataConWrapperType c1) (dataConWrapperType c2)) (text "The types for" <+> pname1 <+> text "differ") where name1 = dataConName c1@@ -1781,11 +1789,11 @@ ; res_ty <- newFlexiTyVarTy liftedTypeKind ; let io_ty = mkTyConApp ioTyCon [res_ty] skol_info = SigSkol (FunSigCtxt main_name False) io_ty []+ main_expr_rn = L loc (HsVar noExtField (L loc main_name)) ; (ev_binds, main_expr) <- checkConstraints skol_info [] [] $ addErrCtxt mainCtxt $- tcLExpr (L loc (HsVar noExtField (L loc main_name)))- (mkCheckExpType io_ty)+ tcCheckMonoExpr main_expr_rn io_ty -- See Note [Root-main Id] -- Construct the binding@@ -1973,7 +1981,7 @@ ; let getOrphans m mb_pkg = fmap (\iface -> mi_module iface : dep_orphs (mi_deps iface)) (loadSrcInterface (text "runTcInteractive") m- False mb_pkg)+ NotBoot mb_pkg) ; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i -> case i of -- force above: see #15111@@ -2443,10 +2451,10 @@ ioM = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv) step_ty = noLoc $ HsForAllTy- { hst_fvf = ForallInvis- , hst_bndrs = [noLoc $ UserTyVar noExtField SpecifiedSpec (noLoc a_tv)]+ { hst_tele = mkHsForAllInvisTele+ [noLoc $ UserTyVar noExtField SpecifiedSpec (noLoc a_tv)] , hst_xforall = noExtField- , hst_body = nlHsFunTy ghciM ioM }+ , hst_body = nlHsFunTy HsUnrestrictedArrow ghciM ioM } stepTy :: LHsSigWcType GhcRn stepTy = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs step_ty)@@ -2476,6 +2484,7 @@ | TM_Default -- ^ Default the type eagerly (:type +d) -- | tcRnExpr just finds the type of an expression+-- for :type tcRnExpr :: HscEnv -> TcRnExprMode -> LHsExpr GhcPs@@ -2590,7 +2599,7 @@ solveEqualities $ tcNamedWildCardBinders wcs $ \ wcs' -> do { mapM_ emitNamedTypeHole wcs'- ; tcLHsTypeUnsaturated rn_type }+ ; tcInferLHsTypeUnsaturated rn_type } -- Do kind generalisation; see Note [Kind-generalise in tcRnType] ; kvs <- kindGeneralizeAll kind@@ -2623,7 +2632,7 @@ 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+ This means we instantiate the type and then regeneralize, as discussed in #11376. > :type foo @Int@@ -2829,7 +2838,7 @@ = initIfaceTcRn $ do mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods)) where- this_pkg = thisPackage (hsc_dflags hsc_env)+ this_pkg = homeUnit (hsc_dflags hsc_env) unqual_mods = [ nameModule name | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt)@@ -2895,7 +2904,7 @@ 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+ -- The use of sort is just to reduce unnecessary -- wobbling in testsuite output ppr_rules :: [LRuleDecl GhcTc] -> SDoc@@ -2964,7 +2973,8 @@ = 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)+ ppr_dc dc = sdocWithDynFlags (\dflags ->+ ppr dc <+> dcolon <+> ppr (dataConDisplayType dflags dc)) all_dcs = typeEnvDataCons type_env wanted_dcs | debug = all_dcs | otherwise = filterOut is_cls_dc all_dcs
compiler/GHC/Tc/Solver.hs view
@@ -16,8 +16,7 @@ simpl_top, - promoteTyVar,- promoteTyVarSet,+ promoteTyVarSet, emitFlatConstraints, -- For Rules we need these solveWanteds, solveWantedsAndDrop,@@ -51,7 +50,7 @@ import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType import GHC.Core.Type-import GHC.Builtin.Types ( liftedRepTy )+import GHC.Builtin.Types ( liftedRepTy, manyDataConTy ) import GHC.Core.Unify ( tcMatchTyKi ) import GHC.Utils.Misc import GHC.Types.Var@@ -65,7 +64,6 @@ import Data.Foldable ( toList ) import Data.List ( partition ) import Data.List.NonEmpty ( NonEmpty(..) )-import GHC.Data.Maybe ( isJust ) {- *********************************************************************************@@ -162,27 +160,143 @@ -- 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+-- Note [Failure in local type signatures] solveLocalEqualities callsite thing_inside = do { (wanted, res) <- solveLocalEqualitiesX callsite thing_inside- ; emitConstraints wanted+ ; emitFlatConstraints wanted+ ; return res } - -- See Note [Fail fast if there are insoluble kind equalities]- ; when (insolubleWC wanted) $- failM+emitFlatConstraints :: WantedConstraints -> TcM ()+-- See Note [Failure in local type signatures]+emitFlatConstraints wanted+ = do { wanted <- TcM.zonkWC wanted+ ; case floatKindEqualities wanted of+ Nothing -> do { traceTc "emitFlatConstraints: failing" (ppr wanted)+ ; emitConstraints wanted -- So they get reported!+ ; failM }+ Just (simples, holes)+ -> do { _ <- promoteTyVarSet (tyCoVarsOfCts simples)+ ; traceTc "emitFlatConstraints:" $+ vcat [ text "simples:" <+> ppr simples+ , text "holes: " <+> ppr holes ]+ ; emitHoles holes -- Holes don't need promotion+ ; emitSimples simples } } - ; return res }+floatKindEqualities :: WantedConstraints -> Maybe (Bag Ct, Bag Hole)+-- Float out all the constraints from the WantedConstraints,+-- Return Nothing if any constraints can't be floated (captured+-- by skolems), or if there is an insoluble constraint, or+-- IC_Telescope telescope error+floatKindEqualities wc = float_wc emptyVarSet wc+ where+ float_wc :: TcTyCoVarSet -> WantedConstraints -> Maybe (Bag Ct, Bag Hole)+ float_wc trapping_tvs (WC { wc_simple = simples+ , wc_impl = implics+ , wc_holes = holes })+ | all is_floatable simples+ = do { (inner_simples, inner_holes)+ <- flatMapBagPairM (float_implic trapping_tvs) implics+ ; return ( simples `unionBags` inner_simples+ , holes `unionBags` inner_holes) }+ | otherwise+ = Nothing+ where+ is_floatable ct+ | insolubleEqCt ct = False+ | otherwise = tyCoVarsOfCt ct `disjointVarSet` trapping_tvs -{- 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.+ float_implic :: TcTyCoVarSet -> Implication -> Maybe (Bag Ct, Bag Hole)+ float_implic trapping_tvs (Implic { ic_wanted = wanted, ic_no_eqs = no_eqs+ , ic_skols = skols, ic_status = status })+ | isInsolubleStatus status+ = Nothing -- A short cut /plus/ we must keep track of IC_BadTelescope+ | otherwise+ = do { (simples, holes) <- float_wc new_trapping_tvs wanted+ ; when (not (isEmptyBag simples) && not no_eqs) $+ Nothing+ -- If there are some constraints to float out, but we can't+ -- because we don't float out past local equalities+ -- (c.f GHC.Tc.Solver.approximateWC), then fail+ ; return (simples, holes) }+ where+ new_trapping_tvs = trapping_tvs `extendVarSetList` skols -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!+{- Note [Failure in local type signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When kind checking a type signature, we like to fail fast if we can't+solve all the kind equality constraints: see Note [Fail fast on kind+errors]. But what about /local/ type signatures, mentioning in-scope+type variables for which there might be given equalities. Here's+an example (T15076b):++ class (a ~ b) => C a b+ data SameKind :: k -> k -> Type where { SK :: SameKind a b }++ bar :: forall (a :: Type) (b :: Type).+ C a b => Proxy a -> Proxy b -> ()+ bar _ _ = const () (undefined :: forall (x :: a) (y :: b). SameKind x y)++Consider the type singature on 'undefined'. It's ill-kinded unless+a~b. But the superclass of (C a b) means that indeed (a~b). So all+should be well. BUT it's hard to see that when kind-checking the signature+for undefined. We want to emit a residual (a~b) constraint, to solve+later.++Another possiblity is that we might have something like+ F alpha ~ [Int]+where alpha is bound further out, which might become soluble+"later" when we learn more about alpha. So we want to emit+those residual constraints.++BUT it's no good simply wrapping all unsolved constraints from+a type signature in an implication constraint to solve later. The+problem is that we are going to /use/ that signature, including+instantiate it. Say we have+ f :: forall a. (forall b. blah) -> blah2+ f x = <body>+To typecheck the definition of f, we have to instantiate those+foralls. Moreover, any unsolved kind equalities will be coercion+holes in the type. If we naively wrap them in an implication like+ forall a. (co1:k1~k2, forall b. co2:k3~k4)+hoping to solve it later, we might end up filling in the holes+co1 and co2 with coercions involving 'a' and 'b' -- but by now+we've instantiated the type. Chaos!++Moreover, the unsolved constraints might be skolem-escpae things, and+if we proceed with f bound to a nonsensical type, we get a cascade of+follow-up errors. For example polykinds/T12593, T15577, and many others.++So here's the plan:++* solveLocalEqualitiesX: try to solve the constraints (solveLocalEqualitiesX)++* buildTvImplication: build an implication for the residual, unsolved+ constraint++* emitFlatConstraints: try to float out every unsolved equalities+ inside that implication, in the hope that it constrains only global+ type variables, not the locally-quantified ones.++ * If we fail, or find an insoluble constraint, emit the implication,+ so that the errors will be reported, and fail.++ * If we succeed in floating all the equalities, promote them and+ re-emit them as flat constraint, not wrapped at all (since they+ don't mention any of the quantified variables.++* Note that this float-and-promote step means that anonymous+ wildcards get floated to top level, as we want; see+ Note [Checking partial type signatures] in GHC.Tc.Gen.HsType.++All this is done:++* in solveLocalEqualities, where there is no kind-generalisation+ to complicate matters.++* in GHC.Tc.Gen.HsType.tcHsSigType, where quantification intervenes.++See also #18062, #11506 -} solveLocalEqualitiesX :: String -> TcM a -> TcM (WantedConstraints, a)@@ -321,7 +435,7 @@ * 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+ means that we'll be left with a type that has coercion holes in it, something like <type> |> co-hole where co-hole is not filled in. Eeek! That un-filled-in@@ -681,7 +795,7 @@ 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.+in Note [Type normalisation] in "GHC.HsToCore.PmCheck". To accomplish its stated goal, tcNormalise first feeds the local constraints into solveSimpleGivens, then uses flattenType to simplify the desired type@@ -717,11 +831,11 @@ -- | 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,+ | 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+ -- satisfies 'GHC.Tc.Utils.TcType.pickQuantifiablePreds' instance Outputable InferMode where ppr ApplyMR = text "ApplyMR"@@ -867,7 +981,6 @@ 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@@ -1168,7 +1281,7 @@ = do { -- Promote any tyvars that we cannot generalise -- See Note [Promote momomorphic tyvars] ; traceTc "decideMonoTyVars: promotion:" (ppr mono_tvs)- ; (prom, _) <- promoteTyVarSet mono_tvs+ ; any_promoted <- promoteTyVarSet mono_tvs -- Default any kind/levity vars ; DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs}@@ -1186,7 +1299,7 @@ ; case () of _ | some_default -> simplify_cand candidates- | prom -> mapM TcM.zonkTcType candidates+ | any_promoted -> mapM TcM.zonkTcType candidates | otherwise -> return candidates } where@@ -1789,9 +1902,9 @@ 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+checkBadTelescope (Implic { ic_info = info+ , ic_skols = skols })+ | ForAllSkol {} <- info = do{ skols <- mapM TcS.zonkTyCoVarKind skols ; return (go emptyVarSet (reverse skols))} @@ -2063,7 +2176,7 @@ allow the implication to make progress. -} -promoteTyVar :: TcTyVar -> TcM (Bool, TcTyVar)+promoteTyVar :: TcTyVar -> TcM Bool -- 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@@ -2075,16 +2188,16 @@ 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) }+ ; return True }+ else return False } -- Returns whether or not *any* tyvar is defaulted-promoteTyVarSet :: TcTyVarSet -> TcM (Bool, TcTyVarSet)+promoteTyVarSet :: TcTyVarSet -> TcM Bool promoteTyVarSet tvs- = do { (bools, tyvars) <- mapAndUnzipM promoteTyVar (nonDetEltsUniqSet tvs)- -- non-determinism is OK because order of promotion doesn't matter+ = do { bools <- mapM promoteTyVar (nonDetEltsUniqSet tvs)+ -- Non-determinism is OK because order of promotion doesn't matter - ; return (or bools, mkVarSet tyvars) }+ ; return (or bools) } promoteTyVarTcS :: TcTyVar -> TcS () -- When we float a constraint out of an implication we must restore@@ -2110,6 +2223,13 @@ = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv) ; unifyTyVar the_tv liftedRepTy ; return True }+ | isMultiplicityVar the_tv+ , not (isTyVarTyVar the_tv) -- TyVarTvs should only be unified with a tyvar+ -- never with a type; c.f. TcMType.defaultTyVar+ -- See Note [Kind generalisation and SigTvs]+ = do { traceTcS "defaultTyVarTcS Multiplicity" (ppr the_tv)+ ; unifyTyVar the_tv manyDataConTy+ ; return True } | otherwise = return False -- the common case @@ -2122,7 +2242,7 @@ 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+ concatMapBag (float_implic trapping_tvs) implics where float_implic :: TcTyCoVarSet -> Implication -> Cts@@ -2134,9 +2254,6 @@ 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 | insolubleEqCt ct = False@@ -2151,7 +2268,7 @@ 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.+to applyDefaultingRules) to extract constraints that might be defaulted. There is one caveat: @@ -2419,21 +2536,20 @@ | otherwise = acc -- Identify which equalities are candidates for floating- -- Float out alpha ~ ty, or ty ~ alpha which might be unified outside+ -- Float out alpha ~ ty 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)+ = float_eq ty1 ty2 || float_eq ty2 ty1+ | otherwise+ = False + float_eq ty1 ty2+ = case getTyVar_maybe ty1 of+ Just tv1 -> isMetaTyVar tv1+ && (not (isTyVarTyVar tv1) || isTyVarTy ty2)+ Nothing -> False {- Note [Float equalities from under a skolem binding] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2469,6 +2585,12 @@ * 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.++ NB: generally we won't see (ty ~ alpha), with alpha on the right because+ of Note [Unification variables on the left] in GHC.Tc.Utils.Unify.+ But if we start with (F tys ~ alpha), it will orient as (fmv ~ alpha),+ and unflatten back to (F tys ~ alpha). So we must look for alpha on+ the right too. Example T4494. * Nominal. No point in floating (alpha ~R# ty), because we do not unify representational equalities even if alpha is touchable.
compiler/GHC/Tc/Solver/Canonical.hs view
@@ -25,6 +25,7 @@ import GHC.Tc.Types.EvTerm import GHC.Core.Class import GHC.Core.TyCon+import GHC.Core.Multiplicity import GHC.Core.TyCo.Rep -- cleverly decomposes types, good for completeness checking import GHC.Core.Coercion import GHC.Core@@ -551,7 +552,7 @@ (sc_theta, sc_inner_pred) = splitFunTys sc_rho all_tvs = tvs `chkAppend` sc_tvs- all_theta = theta `chkAppend` sc_theta+ all_theta = theta `chkAppend` (map scaledThing sc_theta) swizzled_pred = mkInfSigmaTy all_tvs all_theta sc_inner_pred -- evar :: forall tvs. theta => cls tys@@ -904,22 +905,23 @@ 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,+Note [Decomposing FunTy]+~~~~~~~~~~~~~~~~~~~~~~~~+can_eq_nc' may attempt to decompose a FunTy that is un-zonked. This+means that we may very well have a FunTy containing a type of some+unknown kind. For instance, we may have, FunTy (a :: k) Int -Where k is a unification variable. 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.+Where k is a unification variable. So the calls to getRuntimeRep_maybe may+fail (returning Nothing). In that case we'll fall through, zonk, and try again. Zonking should fill the variable k, meaning that decomposition will succeed the second time around.++Also note that we require the AnonArgFlag to match. This will stop+us decomposing+ (Int -> Bool) ~ (Show a => blah)+It's as if we treat (->) and (=>) as different type constructors. -} canEqNC :: CtEvidence -> EqRel -> Type -> Type -> TcS (StopOrContinue Ct)@@ -1003,13 +1005,26 @@ = 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)+-- Decompose FunTy: (s -> t) and (c => t)+-- NB: don't decompose (Int -> blah) ~ (Show a => blah)+can_eq_nc' _flat _rdr_env _envs ev eq_rel+ (FunTy { ft_mult = am1, ft_af = af1, ft_arg = ty1a, ft_res = ty1b }) _+ (FunTy { ft_mult = am2, ft_af = af2, ft_arg = ty2a, ft_res = ty2b }) _+ | af1 == af2 -- Don't decompose (Int -> blah) ~ (Show a => blah)+ , Just ty1a_rep <- getRuntimeRep_maybe ty1a -- getRutimeRep_maybe:+ , Just ty1b_rep <- getRuntimeRep_maybe ty1b -- see Note [Decomposing FunTy]+ , Just ty2a_rep <- getRuntimeRep_maybe ty2a+ , Just ty2b_rep <- getRuntimeRep_maybe ty2b+ = canDecomposableTyConAppOK ev eq_rel funTyCon+ [am1, ty1a_rep, ty1b_rep, ty1a, ty1b]+ [am2, ty2a_rep, ty2b_rep, ty2a, ty2b]++-- Decompose type constructor applications+-- NB: e have expanded type synonyms already+can_eq_nc' _flat _rdr_env _envs ev eq_rel+ (TyConApp tc1 tys1) _+ (TyConApp tc2 tys2) _+ | not (isTypeFamilyTyCon tc1) , not (isTypeFamilyTyCon tc2) = canTyConApp ev eq_rel tc1 tys1 tc2 tys2 @@ -1163,11 +1178,12 @@ -- 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+ | Just (Scaled w1 arg1, res1) <- split1+ , Just (Scaled w2 arg2, res2) <- split2+ , eqType w1 w2 = do { res_a <- go arg1 arg2 ; res_b <- go res1 res2- ; return $ combine_rev mkVisFunTy res_b res_a+ ; return $ combine_rev (mkVisFunTy w1) res_b res_a } | isJust split1 || isJust split2 = bale_out ty1 ty2@@ -1452,15 +1468,13 @@ -> TyCon -> [TcType] -> TcS (StopOrContinue Ct) -- See Note [Decomposing TyConApps]+-- Neither tc1 nor tc2 is a saturated funTyCon 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" }+ then canDecomposableTyConAppOK ev eq_rel tc1 tys1 tys2 else canEqFailure ev eq_rel ty1 ty2 } -- See Note [Skolem abstract data] (at tyConSkolem)@@ -1476,6 +1490,10 @@ | otherwise = canEqHardFailure ev ty1 ty2 where+ -- Reconstruct the types for error messages. This would do+ -- the wrong thing (from a pretty printing point of view)+ -- for functions, because we've lost the AnonArgFlag; but+ -- in fact we never call canTyConApp on a saturated FunTyCon ty1 = mkTyConApp tc1 tys1 ty2 = mkTyConApp tc2 tys2 @@ -1673,30 +1691,35 @@ canDecomposableTyConAppOK :: CtEvidence -> EqRel -> TyCon -> [TcType] -> [TcType]- -> TcS ()+ -> TcS (StopOrContinue Ct) -- 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+ do { traceTcS "canDecomposableTyConAppOK"+ (ppr ev $$ ppr eq_rel $$ ppr tc $$ ppr tys1 $$ ppr 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) }+ 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 }+ 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 }++ ; stopWith ev "Decomposed TyConApp" }+ where loc = ctEvLoc ev role = eqRelRole eq_rel@@ -1747,7 +1770,8 @@ -> 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+ = do { traceTcS "canEqHardFailure" (ppr ty1 $$ ppr ty2)+ ; (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) }@@ -2007,7 +2031,7 @@ -- this guarantees (TyEq:TV) | Just (tv2, co2) <- tcGetCastedTyVar_maybe xi2- , swapOverTyVars tv1 tv2+ , swapOverTyVars (isGiven ev) tv1 tv2 = do { traceTcS "canEqTyVar swapOver" (ppr tv1 $$ ppr tv2 $$ ppr swapped) ; let role = eqRelRole eq_rel sym_co2 = mkTcSymCo co2@@ -2447,10 +2471,11 @@ 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)+ go (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2) = do { co_s <- unifyWanted loc role s1 s2 ; co_t <- unifyWanted loc role t1 t2- ; return (mkFunCo role co_s co_t) }+ ; co_w <- unifyWanted loc Nominal w1 w2+ ; return (mkFunCo role co_w co_s co_t) } go (TyConApp tc1 tys1) (TyConApp tc2 tys2) | tc1 == tc2, tys1 `equalLength` tys2 , isInjectiveTyCon tc1 role -- don't look under newtypes at Rep equality@@ -2498,9 +2523,10 @@ 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)+ go (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2) = do { unify_derived loc role s1 s2- ; unify_derived loc role t1 t2 }+ ; unify_derived loc role t1 t2+ ; unify_derived loc Nominal w1 w2 } go (TyConApp tc1 tys1) (TyConApp tc2 tys2) | tc1 == tc2, tys1 `equalLength` tys2 , isInjectiveTyCon tc1 role
compiler/GHC/Tc/Solver/Flatten.hs view
@@ -767,7 +767,7 @@ -- 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).+-- in "GHC.Tc.Types"). flatten :: FlattenMode -> CtEvidence -> TcType -> TcS (Xi, TcCoercion) flatten mode ev ty@@ -1175,12 +1175,13 @@ -- _ -> fmode = flatten_ty_con_app tc tys -flatten_one ty@(FunTy _ ty1 ty2)+flatten_one ty@(FunTy { ft_mult = mult, ft_arg = ty1, ft_res = ty2 }) = do { (xi1,co1) <- flatten_one ty1 ; (xi2,co2) <- flatten_one ty2+ ; (xi3,co3) <- setEqRel NomEq $ flatten_one mult ; role <- getRole- ; return (ty { ft_arg = xi1, ft_res = xi2 }- , mkFunCo role co1 co2) }+ ; return (ty { ft_mult = xi3, ft_arg = xi1, ft_res = xi2 }+ , mkFunCo role co3 co1 co2) } flatten_one ty@(ForAllTy {}) -- TODO (RAE): This is inadequate, as it doesn't flatten the kind of@@ -1918,12 +1919,14 @@ 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'+ -- put common cases first 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 })+ split _ (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) = let (bs, ty, named) = split res res- in (Anon af arg : bs, ty, named)+ in (Anon af (mkScaled w arg) : bs, ty, named)++ split orig_ty ty | Just ty' <- coreView ty = split orig_ty ty' split orig_ty _ = ([], orig_ty, False) {-# INLINE split_pi_tys' #-} @@ -1935,6 +1938,6 @@ 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)+ = (Anon af (unrestricted (tyVarKind tv)) : bndrs, n) {-# INLINE go #-} {-# INLINE ty_con_binders_ty_binders' #-}
compiler/GHC/Tc/Solver/Interact.hs view
@@ -2488,7 +2488,7 @@ -- | 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.+-- See also Note [The equality class story] in "GHC.Builtin.Types.Prim". naturallyCoherentClass :: Class -> Bool naturallyCoherentClass cls = isCTupleClass cls
compiler/GHC/Tc/Solver/Monad.hs view
@@ -728,7 +728,7 @@ -- failure. -- -- ^ See Note [Safe Haskell Overlapping Instances Implementation]- -- in GHC.Tc.Solver+ -- in "GHC.Tc.Solver" , inert_irreds :: Cts -- Irreducible predicates that cannot be made canonical,@@ -1822,7 +1822,7 @@ ; setInertCans ics2 ; return n_kicked } --- See Wrinkle (2b) in Note [Equalities with incompatible kinds] in TcCanonical+-- See Wrinkle (2b) in Note [Equalities with incompatible kinds] in "GHC.Tc.Solver.Canonical" kickOutAfterFillingCoercionHole :: CoercionHole -> TcS () kickOutAfterFillingCoercionHole hole = do { ics <- getInertCans@@ -2177,7 +2177,7 @@ -- | 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.+-- 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@@ -2313,7 +2313,7 @@ MkS -> [y,z]) in ... -From the type signature for `g`, we get `y::a` . Then when when we+From the type signature for `g`, we get `y::a` . Then when we encounter the `\z`, we'll assign `z :: alpha[1]`, say. Next, from the body of the lambda we'll get @@ -3232,7 +3232,7 @@ | 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+ -- See (2a) in "GHC.Tc.Solver.Canonical" -- Note [Equalities with incompatible kinds] ; (ev, hole_co) <- newWantedEq_SI NoBlockSubst WDeriv loc Nominal fam_ty (mkTyVarTy fmv)
compiler/GHC/Tc/TyCl.hs view
@@ -44,6 +44,7 @@ import GHC.Tc.Utils.TcMType import GHC.Builtin.Types ( unitTy, makeRecoveryTyCon ) import GHC.Tc.Utils.TcType+import GHC.Core.Multiplicity import GHC.Rename.Env( lookupConstructorFields ) import GHC.Tc.Instance.Family import GHC.Core.FamInstEnv@@ -61,6 +62,7 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Unit.Module+import GHC.Unit.State import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env@@ -172,7 +174,7 @@ -- 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+ ; this_uid <- fmap homeUnit getDynFlags ; checkSynCycles this_uid tyclss tyclds ; traceTc "Done synonym cycle check" (ppr tyclss) @@ -234,7 +236,7 @@ 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+ -- a TcTyCon for each knot-tied TyCon or Class -- See Note [Type checking recursive type and class declarations] -- and Note [Type environment evolution] tcExtendKindEnvWithTyCons tc_tycons $@@ -1560,10 +1562,10 @@ -- 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 :: NewOrData -> Kind -> [HsScaled GhcRn (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+ ; mapM_ (flip tcCheckLHsType exp_kind . getBangType . hsScaledThing) arg_tys -- See Note [Implementation of UnliftedNewtypes], STEP 2 } @@ -1789,6 +1791,272 @@ e.g. the need to make the data constructor worker name for a constraint tuple match the wired-in one +Note [Datatype return kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are several poorly lit corners around datatype/newtype return kinds.+This Note explains these. We cover data/newtype families and instances+in Note [Data family/instance return kinds].++data T a :: <kind> where ... -- See Point DT4+newtype T a :: <kind> where ... -- See Point DT5++DT1 Where this applies: Only GADT syntax for data/newtype/instance declarations+ can have declared return kinds. This Note does not apply to Haskell98+ syntax.++DT2 Where these kinds come from: 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.++DT3 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.++ See also Note [TyConBinders for the result kind signatures of a data type]+ in GHC.Tc.Gen.HsType.++DT4 Datatype return kind restriction: A data type 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.++ 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++ Exactly the same applies to data instance (but not data family)+ declarations. Examples+ data instance D1 :: Type -- good+ data instance D2 :: Bool -> Type -- good++ We can "look through" type synonyms+ type Star = Type+ data T7 :: Bool -> Star -- good (synonym expansion ok)+ type Arrow = (->)+ data T8 :: Arrow Bool Type -- good (ditto)++ But we specifically do *not* do type family reduction here.+ type family ARROW where+ ARROW = (->)+ data T9 :: ARROW Bool Type -- bad++ type family F a where+ F Int = Bool+ F Bool = Type+ data T10 :: Bool -> F Bool -- bad++ The /principle/ here is that in the TyCon for a data type or data instance,+ we must be able to lay out all the type-variable binders, one by one, until+ we reach (TYPE xx). There is no place for a cast here. We could add one,+ but let's not!++ This check is done in checkDataKindSig. For data declarations, this+ call is in tcDataDefn; for data instances, this call is in tcDataFamInstDecl.++DT5 Newtype return kind restriction.+ If -XUnliftedNewtypes is not on, then newtypes are treated just+ like datatypes --- see (4) above.++ If -XUnliftedNewtypes is on, then a newtype 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+ /without/ 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].++ 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++Note [Data family/instance return kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Within this note, understand "instance" to mean data or newtype+instance, and understand "family" to mean data family. No type+families or classes here. Some examples:++data family T a :: <kind> -- See Point DF56++data instance T [a] :: <kind> where ... -- See Point DF2+newtype instance T [a] :: <kind> where ... -- See Point DF2++Here is the Plan for Data Families:++DF0 Where these kinds come from:++ 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. See also DF3, below.++DF1 In a data/newtype instance, we treat the kind of the /data family/,+ once instantiated, as the "master kind" for the representation+ TyCon. For example:+ data family T1 :: Type -> Type -> Type+ data instance T1 Int :: F Bool -> Type where ...+ The "master kind" for the representation TyCon R:T1Int comes+ from T1, not from the signature on the data instance. It is as+ if we declared+ data R:T1Int :: Type -> Type where ...+ See Note [Liberalising data family return kinds] for an alternative+ plan. But this current plan is simple, and ensures that all instances+ are simple instantiations of the master, without strange casts.++ An example with non-trivial instantiation:+ data family T2 :: forall k. Type -> k+ data instance T2 :: Type -> Type -> Type where ...+ Here 'k' gets instantiated with (Type -> Type), driven by+ the signature on the 'data instance'. (See also DT3 of+ Note [Datatype return kinds] about eta-expansion, which applies here,+ too; see tcDataFamInstDecl's call of etaExpandAlgTyCon.)++ A newtype 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 our+ representation newtype looks like+ newtype R:FooRed :: TYPE (Interpret Red) where+ FooRedC :: Int# -> R:FooRed+ Remember: the master kind comes from the /family/ tycon.++DF2 /After/ this instantiation, the return kind of the master kind+ must obey the usual rules for data/newtype return kinds (DT4, DT5)+ of Note [Datatype return kinds]. Examples:+ data family T3 k :: k+ data instance T3 Type where ... -- OK+ data instance T3 (Type->Type) where ... -- OK+ data instance T3 (F Int) where ... -- Not OK++DF3 Any kind signatures on the data/newtype instance are checked for+ equality with the master kind (and hence may guide instantiation)+ but are otherwise ignored. So in the T1 example above, we check+ that (F Int ~ Type) by unification; but otherwise ignore the+ user-supplied signature from the /family/ not the /instance/.++ We must be sure to instantiate any trailing invisible binders+ before doing this unification. See the call to tcInstInvisibleBinders+ in tcDataFamInstHeader. For example:+ 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+ we must instantiate D before unifying with the signature in the+ data instance declaration++DF4 We also (redundantly) check that any user-specified return kind+ signature in the data instance also obeys DT4/DT5. For example we+ reject+ data family T1 :: Type -> Type -> Type+ data instance T1 Int :: Type -> F Int+ even if (F Int ~ Type). We could omit this check, because we+ use the master kind; but it seems more uniform to check it, again+ with checkDataKindSig.++DF5 Data /family/ return kind restrictions. Consider+ data family D8 a :: F a+ where F is a type family. No data/newtype instance can instantiate+ this so that it obeys the rules of DT4 or DT5. So GHC proactively+ rejects the data /family/ declaration if it can never satisfy (DT4)/(DT5).+ Remember that a data family supports both data and newtype instances.++ More precisely, the return kind of a data family must be either+ * TYPE xyz (for some type xyz) or+ * a kind variable+ Only in these cases can a data/newtype instance possibly satisfy (DT4)/(DT5).+ 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)++DF6 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 DF3 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).++ This all is Wrinkle (3) in Note [Implementation of UnliftedNewtypes].++Note [Liberalising data family return kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Could we allow this?+ type family F a where { F Int = Type }+ data family T a :: F a+ data instance T Int where+ MkT :: T Int++In the 'data instance', T Int :: F Int, and F Int = Type, so all seems+well. But there are lots of complications:++* The representation constructor R:TInt presumably has kind Type.+ So the axiom connecting the two would have to look like+ axTInt :: T Int ~ R:TInt |> sym axFInt+ and that doesn't match expectation in DataFamInstTyCon+ in AlgTyConFlav++* The wrapper can't have type+ $WMkT :: Int -> T Int+ because T Int has the wrong kind. It would have to be+ $WMkT :: Int -> (T Int) |> axFInt++* The code for $WMkT would also be more complicated, needing+ two coherence coercions. Try it!++* Code for pattern matching would be complicated in an+ exactly dual way.++So yes, we could allow this, but we currently do not. That's+why we have DF2 in Note [Data family/instance return kinds].+ Note [Implementation of UnliftedNewtypes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Expected behavior of UnliftedNewtypes:@@ -1865,11 +2133,12 @@ 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.+ 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@@ -1881,7 +2150,7 @@ 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:+There are also some changes for dealing with families: 1. In tcFamDecl1, we suppress a tcIsLiftedTypeKind check if UnliftedNewtypes is on. This allows us to write things like:@@ -1903,7 +2172,7 @@ 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].+ different kinds. See point DF6 in Note [Data family/instance return kinds] There's also a change in the renamer: @@ -2290,177 +2559,6 @@ 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 :: <kind> where ... -- See Point 4-newtype T a :: <kind> where ... -- See Point 5--data family T a :: <kind> -- See Point 6--data instance T [a] :: <kind> where ... -- See Point 4-newtype instance T [a] :: <kind> 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].- -} {- *********************************************************************@@ -2490,8 +2588,7 @@ -- 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+ ; checkDataKindSig DataFamilySort res_kind ; tc_rep_name <- newTyConRepName tc_name ; let inj = Injective $ replicate (length binders) True tycon = mkFamilyTyCon tc_name binders@@ -2786,7 +2883,7 @@ 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+ ; return (mkCoAxBranch qtvs [] [] pats rhs_ty (map (const Nominal) qtvs) loc) } @@ -2906,36 +3003,11 @@ ; 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),+-- tcFamTyPats 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@@ -2950,7 +3022,7 @@ 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+-- ensure 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@@ -3073,7 +3145,7 @@ ------------------------------------consUseGadtSyntax :: [LConDecl a] -> Bool+consUseGadtSyntax :: [LConDecl GhcRn] -> Bool consUseGadtSyntax (L _ (ConDeclGADT {}) : _) = True consUseGadtSyntax _ = False -- All constructors have same shape@@ -3148,7 +3220,7 @@ ; (ze, qkvs) <- zonkTyBndrs kvs ; (ze, user_qtvbndrs) <- zonkTyVarBindersX ze exp_tvbndrs ; let user_qtvs = binderVars user_qtvbndrs- ; arg_tys <- zonkTcTypesToTypesX ze arg_tys+ ; arg_tys <- zonkScaledTcTypesToTypesX ze arg_tys ; ctxt <- zonkTcTypesToTypesX ze ctxt ; fam_envs <- tcGetFamInstEnvs@@ -3183,8 +3255,8 @@ } 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.+ -- 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_g_ext = implicit_tkv_nms , con_names = names , con_qvars = explicit_tkv_nms@@ -3201,16 +3273,12 @@ 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+ ; (res_ty, res_kind) <- tcInferLHsTypeKind hs_res_ty+ -- See Note [GADT return kinds]+ -- See Note [Datatype return kinds]- ; let exp_kind = getArgExpKind new_or_data (typeKind res_ty)+ ; let exp_kind = getArgExpKind new_or_data res_kind+ ; btys <- tcConArgs exp_kind hs_args ; let (arg_tys, stricts) = unzip btys ; field_lbls <- lookupConstructorFields name@@ -3230,7 +3298,7 @@ -- Zonk to Types ; (ze, tvbndrs) <- zonkTyVarBinders tvbndrs- ; arg_tys <- zonkTcTypesToTypesX ze arg_tys+ ; arg_tys <- zonkScaledTcTypesToTypesX ze arg_tys ; ctxt <- zonkTcTypesToTypesX ze ctxt ; res_ty <- zonkTcTypeToTypeX ze res_ty @@ -3239,7 +3307,7 @@ -- See Note [Checking GADT return types] ctxt' = substTys arg_subst ctxt- arg_tys' = substTys arg_subst arg_tys+ arg_tys' = substScaledTys arg_subst arg_tys res_ty' = substTy arg_subst res_ty @@ -3265,6 +3333,20 @@ ; mapM buildOneDataCon names } +{- Note [GADT return kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+ type family Star where Star = Type+ data T :: Type where+ MkT :: Int -> T++If, for some stupid reason, tcInferLHsTypeKind on the return type of+MkT returned (T |> ax, Star), then the return-type check in+checkValidDataCon would reject the decl (although of course there is+nothing wrong with it). We are implicitly requiring tha+tcInferLHsTypeKind doesn't any gratuitous top-level casts.+-}+ -- | 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,@@ -3276,7 +3358,7 @@ getArgExpKind DataType _ = OpenKind tcConIsInfixH98 :: Name- -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])+ -> HsConDetails a b -> TcM Bool tcConIsInfixH98 _ details = case details of@@ -3284,7 +3366,7 @@ _ -> return False tcConIsInfixGADT :: Name- -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])+ -> HsConDetails (HsScaled GhcRn (LHsType GhcRn)) r -> TcM Bool tcConIsInfixGADT con details = case details of@@ -3292,7 +3374,7 @@ RecCon {} -> return False PrefixCon arg_tys -- See Note [Infix GADT constructors] | isSymOcc (getOccName con)- , [_ty1,_ty2] <- arg_tys+ , [_ty1,_ty2] <- map hsScaledThing arg_tys -> do { fix_env <- getFixityEnv ; return (con `elemNameEnv` fix_env) } | otherwise -> return False@@ -3301,7 +3383,7 @@ -- always OpenKind for datatypes, but unlifted newtypes -- might have a specific kind -> HsConDeclDetails GhcRn- -> TcM [(TcType, HsSrcBang)]+ -> TcM [(Scaled TcType, HsSrcBang)] tcConArgs exp_kind (PrefixCon btys) = mapM (tcConArg exp_kind) btys tcConArgs exp_kind (InfixCon bty1 bty2)@@ -3312,7 +3394,7 @@ = 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))+ combined = map (\(L _ f) -> (cd_fld_names f,hsLinear (cd_fld_type f))) (unLoc fields) explode (ns,ty) = zip ns (repeat ty) exploded = concatMap explode combined@@ -3321,12 +3403,13 @@ 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+ -> HsScaled GhcRn (LHsType GhcRn) -> TcM (Scaled TcType, HsSrcBang)+tcConArg exp_kind (HsScaled w bty) = do { traceTc "tcConArg 1" (ppr bty) ; arg_ty <- tcCheckLHsType (getBangType bty) exp_kind+ ; w' <- tcMult w ; traceTc "tcConArg 2" (ppr bty)- ; return (arg_ty, getBangStrictness bty) }+ ; return (Scaled w' arg_ty, getBangStrictness bty) } {- Note [Infix GADT constructors]@@ -3936,13 +4019,18 @@ , ppr orig_res_ty <+> dcolon <+> ppr (tcTypeKind orig_res_ty)]) - ; checkTc (isJust (tcMatchTy res_ty_tmpl orig_res_ty))+ ; checkTc (isJust (tcMatchTyKi 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+ -- critical to avoid panicking when we call dataConDisplayType -- on an un-rejiggable datacon!+ -- Also NB that we match the *kind* as well as the *type* (#18357)+ -- However, if the kind is the only thing that doesn't match, the+ -- error message is terrible. E.g. test T18357b+ -- type family Star where Star = Type+ -- newtype T :: Type where MkT :: Int -> (T :: Star) - ; traceTc "checkValidDataCon 2" (ppr (dataConUserType con))+ ; traceTc "checkValidDataCon 2" (ppr data_con_display_type) -- Check that the result type is a *monotype* -- e.g. reject this: MkT :: T (forall a. a->a)@@ -3954,7 +4042,7 @@ -- later check in checkNewDataCon handles this, producing a -- better error message than checkForLevPoly would. ; unless (isNewTyCon tc)- (mapM_ (checkForLevPoly empty) (dataConOrigArgTys con))+ (mapM_ (checkForLevPoly empty) (map scaledThing $ dataConOrigArgTys con)) -- Extra checks for newtype data constructors. Importantly, these -- checks /must/ come before the call to checkValidType below. This@@ -3964,7 +4052,7 @@ ; when (isNewTyCon tc) (checkNewDataCon con) -- Check all argument types for validity- ; checkValidType ctxt (dataConUserType con)+ ; checkValidType ctxt data_con_display_type -- Check that existentials are allowed if they are used ; checkTc (existential_ok || isVanillaDataCon con)@@ -3994,8 +4082,9 @@ ; traceTc "Done validity of data con" $ vcat [ ppr con- , text "Datacon user type:" <+> ppr (dataConUserType con)+ , text "Datacon wrapper type:" <+> ppr (dataConWrapperType con) , text "Datacon rep type:" <+> ppr (dataConRepType con)+ , text "Datacon display type:" <+> ppr data_con_display_type , text "Rep typcon binders:" <+> ppr (tyConBinders (dataConTyCon con)) , case tyConFamInst_maybe (dataConTyCon con) of Nothing -> text "not family"@@ -4024,7 +4113,7 @@ -- 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)+ , homeUnitIsDefinite dflags = addWarnTc NoReason (bad_bang n (text "Ignoring unusable UNPACK pragma")) where is_strict = case strict_mark of@@ -4037,6 +4126,9 @@ bad_bang n herald = hang herald 2 (text "on the" <+> speakNth n <+> text "argument of" <+> quotes (ppr con))++ data_con_display_type = dataConDisplayType dflags con+ ------------------------------- checkNewDataCon :: DataCon -> TcM () -- Further checks for the data constructor of a newtype@@ -4046,12 +4138,19 @@ ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes ; let allowedArgType =- unlifted_newtypes || isLiftedType_maybe arg_ty1 == Just True+ unlifted_newtypes || isLiftedType_maybe (scaledThing arg_ty1) == Just True ; checkTc allowedArgType $ vcat [ text "A newtype cannot have an unlifted argument type" , text "Perhaps you intended to use UnliftedNewtypes" ]+ ; dflags <- getDynFlags + ; let check_con what msg =+ checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConDisplayType dflags con))++ ; checkTc (ok_mult (scaledMult arg_ty1)) $+ text "A newtype constructor must be linear"+ ; 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)@@ -4070,8 +4169,6 @@ 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 @@ -4079,6 +4176,9 @@ ok_bang (HsSrcBang _ _ SrcLazy) = False ok_bang _ = True + ok_mult One = True+ ok_mult _ = False+ ------------------------------- checkValidClass :: Class -> TcM () checkValidClass cls@@ -4191,7 +4291,7 @@ -- default-method Name to be that of the generic -- default type signature - -- First, we check that that the method's default type signature+ -- First, we check 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@@ -4525,7 +4625,7 @@ 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 }+ eqSpecPreds eq_spec ++ theta ++ (map scaledThing 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)@@ -4562,8 +4662,9 @@ = 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 (FunTy _ w ty1 ty2)+ = check_ty_roles env Nominal w+ >> check_ty_roles env role ty1 >> check_ty_roles env role ty2 check_ty_roles env role (ForAllTy (Bndr tv _) ty)@@ -4720,50 +4821,12 @@ 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)@@ -4771,10 +4834,11 @@ 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" ])+ = sdocWithDynFlags (\dflags ->+ hang (text "Data constructor" <+> quotes (ppr con) <+>+ text "has existential type variables, a context, or a specialised result type")+ 2 (vcat [ ppr con <+> dcolon <+> ppr (dataConDisplayType dflags con)+ , parens $ text "Enable ExistentialQuantification or GADTs to allow this" ])) badStupidTheta :: Name -> SDoc badStupidTheta tc_name@@ -4817,7 +4881,7 @@ -- | Produce an error for oversaturated type family equations with too many -- required arguments.--- See Note [Oversaturated type family equations] in GHC.Tc.Validity.+-- 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"
compiler/GHC/Tc/TyCl/Build.hs view
@@ -36,6 +36,7 @@ import GHC.Core.Type import GHC.Types.Id import GHC.Tc.Utils.TcType+import GHC.Core.Multiplicity import GHC.Types.SrcLoc( SrcSpan, noSrcSpan ) import GHC.Driver.Session@@ -65,7 +66,7 @@ roles = tyConRoles tycon res_kind = tyConResKind tycon con_arg_ty = case dataConRepArgTys con of- [arg_ty] -> arg_ty+ [arg_ty] -> scaledThing arg_ty tys -> pprPanic "mkNewTyConRhs" (ppr con <+> ppr tys) rhs_ty = substTyWith (dataConUnivTyVars con) (mkTyVarTys tvs) con_arg_ty@@ -110,7 +111,7 @@ -> [EqSpec] -- Equality spec -> KnotTied ThetaType -- Does not include the "stupid theta" -- or the GADT equalities- -> [KnotTied Type] -- Arguments+ -> [KnotTied (Scaled Type)] -- Arguments -> KnotTied Type -- Result types -> KnotTied TyCon -- Rep tycon -> NameEnv ConTag -- Maps the Name of each DataCon to its@@ -132,7 +133,7 @@ ; traceIf (text "buildDataCon 1" <+> ppr src_name) ; us <- newUniqueSupply ; dflags <- getDynFlags- ; let stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs+ ; let stupid_ctxt = mkDataConStupidTheta rep_tycon (map scaledThing 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@@ -184,10 +185,10 @@ -- compatible with the pattern synonym ASSERT2((and [ univ_tvs `equalLength` univ_tvs1 , ex_tvs `equalLength` ex_tvs1- , pat_ty `eqType` substTy subst pat_ty1+ , pat_ty `eqType` substTy subst (scaledThing pat_ty1) , prov_theta `eqTypes` substTys subst prov_theta1 , req_theta `eqTypes` substTys subst req_theta1- , compareArgTys arg_tys (substTys subst arg_tys1)+ , compareArgTys arg_tys (substTys subst (map scaledThing arg_tys1)) ]) , (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1 , ppr ex_tvs <+> twiddle <+> ppr ex_tvs1@@ -202,7 +203,7 @@ 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+ (ex_tvs1, prov_theta1, cont_tau) = tcSplitSigmaTy (scaledThing cont_sigma) (arg_tys1, _) = (tcSplitFunTys cont_tau) twiddle = char '~' subst = zipTvSubst (univ_tvs1 ++ ex_tvs1)@@ -314,7 +315,7 @@ univ_bndrs [{- No GADT equalities -}] [{- No theta -}]- arg_tys+ (map unrestricted arg_tys) -- type classes are unrestricted (mkTyConApp rec_tycon (mkTyVarTys univ_tvs)) rec_tycon (mkTyConTagMap rec_tycon)
compiler/GHC/Tc/TyCl/Class.hs view
@@ -40,6 +40,7 @@ import GHC.Tc.Utils.TcMType import GHC.Core.Type ( piResultTys ) import GHC.Core.Predicate+import GHC.Core.Multiplicity import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Monad@@ -183,7 +184,7 @@ -} tcClassDecl2 :: LTyClDecl GhcRn -- The class declaration- -> TcM (LHsBinds GhcTcId)+ -> TcM (LHsBinds GhcTc) tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs, tcdMeths = default_binds}))@@ -217,7 +218,7 @@ tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds GhcRn -> HsSigFun -> TcPragEnv -> ClassOpItem- -> TcM (LHsBinds GhcTcId)+ -> TcM (LHsBinds GhcTc) -- 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@@ -284,7 +285,7 @@ ctxt = FunSigCtxt sel_name warn_redundant - ; let local_dm_id = mkLocalId local_dm_name local_dm_ty+ ; let local_dm_id = mkLocalId local_dm_name Many local_dm_ty local_dm_sig = CompleteSig { sig_bndr = local_dm_id , sig_ctxt = ctxt , sig_loc = getLoc (hsSigType hs_ty) }
compiler/GHC/Tc/TyCl/Instance.hs view
@@ -41,6 +41,7 @@ import GHC.Tc.TyCl.Build import GHC.Tc.Utils.Instantiate import GHC.Tc.Instance.Class( AssocInstInfo(..), isNotAssociated )+import GHC.Core.Multiplicity import GHC.Core.InstEnv import GHC.Tc.Instance.Family import GHC.Core.FamInstEnv@@ -699,9 +700,10 @@ -- 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++ -- Check the result kind; it may come from a user-written signature.+ -- See Note [Datatype return kinds] in GHC.Tc.TyCl point 4(a) ; let extra_pats = map (mkTyVarTy . binderVar) extra_tcbs all_pats = pats `chkAppend` extra_pats orig_res_ty = mkTyConApp fam_tc all_pats@@ -710,10 +712,12 @@ ; traceTc "tcDataFamInstDecl" $ vcat [ text "Fam tycon:" <+> ppr fam_tc , text "Pats:" <+> ppr pats- , text "visibliities:" <+> ppr (tcbVisibilities fam_tc pats)+ , text "visiblities:" <+> 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 "res_kind:" <+> ppr res_kind+ , text "final_res_kind:" <+> ppr final_res_kind , text "eta_pats" <+> ppr eta_pats , text "eta_tcbs" <+> ppr eta_tcbs ] @@ -731,9 +735,9 @@ 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))+ ; let ax_rhs = mkTyConApp rep_tc (mkTyVarTys post_eta_qtvs)+ axiom = mkSingleCoAxiom Representational axiom_name+ post_eta_qtvs eta_tvs [] fam_tc eta_pats ax_rhs parent = DataFamInstTyCon axiom fam_tc all_pats -- NB: Use the full ty_binders from the pats. See bullet toward@@ -847,13 +851,18 @@ -- 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)))+ = do { traceTc "tcDataFamInstHeader {" (ppr fam_tc <+> ppr hs_pats)+ ; (imp_tvs, (exp_tvs, (stupid_theta, lhs_ty, master_res_kind, instance_res_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+ ; (lhs_applied_ty, lhs_applied_kind)+ <- tcInstInvisibleTyBinders lhs_ty lhs_kind+ -- See Note [Data family/instance return kinds]+ -- in GHC.Tc.TyCl point (DF3) -- Ensure that the instance is consistent -- with its parent class@@ -865,17 +874,18 @@ -- 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+ -- Check that the result kind of the TyCon applied to its args+ -- is compatible with the explicit signature (or Type, if there+ -- is none)+ ; let hs_lhs = nlHsTyConApp fixity (getName fam_tc) hs_pats ; _ <- unifyKind (Just (unLoc hs_lhs)) lhs_applied_kind res_kind + ; traceTc "tcDataFamInstHeader" $+ vcat [ ppr fam_tc, ppr m_ksig, ppr lhs_applied_kind, ppr res_kind ] ; return ( stupid_theta , lhs_applied_ty- , lhs_applied_kind ) }+ , lhs_applied_kind+ , res_kind ) } -- See GHC.Tc.TyCl Note [Generalising in tcFamTyPatsGuts] -- This code (and the stuff immediately above) is very similar@@ -888,18 +898,28 @@ ; 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+ ; (ze, qtvs) <- zonkTyBndrs qtvs+ ; lhs_ty <- zonkTcTypeToTypeX ze lhs_ty+ ; stupid_theta <- zonkTcTypesToTypesX ze stupid_theta+ ; master_res_kind <- zonkTcTypeToTypeX ze master_res_kind+ ; instance_res_kind <- zonkTcTypeToTypeX ze instance_res_kind + -- We check that res_kind is OK with checkDataKindSig in+ -- tcDataFamInstDecl, after eta-expansion. We need to check that+ -- it's ok because res_kind can come from a user-written kind signature.+ -- See Note [Datatype return kinds], point (4a)++ ; checkDataKindSig (DataInstanceSort new_or_data) master_res_kind+ ; checkDataKindSig (DataInstanceSort new_or_data) instance_res_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) }++ ; return (qtvs, pats, master_res_kind, stupid_theta) } where fam_name = tyConName fam_tc data_ctxt = DataKindCtxt fam_name@@ -920,11 +940,7 @@ ; 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 }+ ; return (substTy subst inner_kind) } {- Note [Result kind signature for a data family instance] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -932,7 +948,7 @@ 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+Thus: skolemise away. cf. GHC.Tc.Utils.Unify.tcSkolemise Examples in indexed-types/should_compile/T12369 Note [Implementing eta reduction for data families]@@ -962,7 +978,7 @@ * 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+ in the right order. So, if the /patterns/ of the family instance are eta-reducible, we re-order Drep's parameters to put the eta-reduced type variables last. @@ -1308,7 +1324,7 @@ ; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id sc_ev_tm ; let sc_top_ty = mkInfForAllTys tyvars $ mkPhiTy (map idType dfun_evs) sc_pred- sc_top_id = mkLocalId sc_top_name sc_top_ty+ sc_top_id = mkLocalId sc_top_name Many sc_top_ty export = ABE { abe_ext = noExtField , abe_wrap = idHsWrapper , abe_poly = sc_top_id@@ -1593,7 +1609,7 @@ -> 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+ = do { (meth_bind, inline_prags) <- mkDefMethBind dfun_id clas 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@@ -1764,7 +1780,7 @@ | otherwise = thing tcMethodBodyHelp :: HsSigFun -> Id -> TcId- -> LHsBind GhcRn -> TcM (LHsBinds GhcTcId)+ -> LHsBind GhcRn -> TcM (LHsBinds GhcTc) 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@@ -1781,14 +1797,14 @@ -- 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+ tcSubTypeSigma 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_id = mkLocalId inner_meth_name Many sig_ty inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id , sig_ctxt = ctxt , sig_loc = getLoc (hsSigType hs_sig_ty) }@@ -1839,8 +1855,8 @@ ; 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+ ; let poly_meth_id = mkLocalId poly_meth_name Many poly_meth_ty+ local_meth_id = mkLocalId local_meth_name Many local_meth_ty ; return (poly_meth_id, local_meth_id) } where@@ -1936,7 +1952,7 @@ | L inst_loc (SpecPrag _ wrap inl) <- spec_inst_prags] -mkDefMethBind :: Class -> [Type] -> Id -> Name+mkDefMethBind :: DFunId -> Class -> 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@@ -1944,7 +1960,7 @@ -- 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+mkDefMethBind dfun_id clas sel_id dm_name = do { dflags <- getDynFlags ; dm_id <- tcLookupId dm_name ; let inline_prag = idInlinePragma dm_id@@ -1969,6 +1985,8 @@ ; return (bind, inline_prags) } where+ (_, _, _, inst_tys) = tcSplitDFunTy (idType dfun_id)+ mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn mk_vta fun ty = noLoc (HsAppType noExtField fun (mkEmptyWildCardBndrs $ nlHsParTy $ noLoc $ XHsType $ NHsCoreTy ty))
compiler/GHC/Tc/TyCl/PatSyn.hs view
@@ -24,6 +24,7 @@ import GHC.Hs import GHC.Tc.Gen.Pat+import GHC.Core.Multiplicity import GHC.Core.Type ( tidyTyCoVarBinders, tidyTypes, tidyType ) import GHC.Tc.Utils.Monad import GHC.Tc.Gen.Sig( emptyPragEnv, completeSigFromId )@@ -106,7 +107,7 @@ 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 $+ matcher_id = mkLocalId matcher_name Many $ mkSpecForAllTys [alphaTyVar] alphaTy {- Note [Pattern synonym error recovery]@@ -387,7 +388,7 @@ ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys ) pushLevelAndCaptureConstraints $ tcExtendTyVarEnv univ_tvs $- tcCheckPat PatSyn lpat pat_ty $+ tcCheckPat PatSyn lpat (unrestricted pat_ty) $ do { let in_scope = mkInScopeSet (mkVarSet univ_tvs) empty_subst = mkEmptyTCvSubst in_scope ; (subst, ex_tvs') <- mapAccumLM newMetaTyVarX empty_subst ex_tvs@@ -402,13 +403,13 @@ -- 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+ ; args' <- zipWithM (tc_arg subst) arg_names (map scaledThing 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+ -- See Note [Skolem info for pattern synonyms] in "GHC.Tc.Types.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,@@ -423,17 +424,17 @@ ; 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)+ (args', (map scaledThing arg_tys)) pat_ty rec_fields } where- tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr GhcTcId)+ tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr GhcTc) 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)+ ; wrap <- tcSubTypeSigma 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) }@@ -596,8 +597,7 @@ -> LPat GhcTc -- ^ Pattern of the PatSyn -> ([TcInvisTVBinder], [PredType], TcEvBinds, [EvVar]) -> ([TcInvisTVBinder], [TcType], [PredType], [EvTerm])- -> ([LHsExpr GhcTcId], [TcType]) -- ^ Pattern arguments and- -- types+ -> ([LHsExpr GhcTc], [TcType]) -- ^ Pattern arguments and types -> TcType -- ^ Pattern type -> [Name] -- ^ Selector names -- ^ Whether fields, empty if not record PatSyn@@ -682,7 +682,7 @@ -> LPat GhcTc -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar]) -> ([TcTyVar], [TcType], ThetaType, [EvTerm])- -> ([LHsExpr GhcTcId], [TcType])+ -> ([LHsExpr GhcTc], [TcType]) -> TcType -> TcM ((Id, Bool), LHsBinds GhcTc) -- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn@@ -701,16 +701,16 @@ | is_unlifted = ([nlHsVar voidPrimId], [voidPrimTy]) | otherwise = (args, arg_tys) cont_ty = mkInfSigmaTy ex_tvs prov_theta $- mkVisFunTys cont_arg_tys res_ty+ mkVisFunTysMany cont_arg_tys res_ty - fail_ty = mkVisFunTy voidPrimTy res_ty+ fail_ty = mkVisFunTyMany 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+ ; scrutinee <- newSysLocalId (fsLit "scrut") Many pat_ty+ ; cont <- newSysLocalId (fsLit "cont") Many cont_ty+ ; fail <- newSysLocalId (fsLit "fail") Many fail_ty - ; let matcher_tau = mkVisFunTys [pat_ty, cont_ty, fail_ty] res_ty+ ; let matcher_tau = mkVisFunTysMany [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@@ -730,14 +730,14 @@ L (getLoc lpat) $ HsCase noExtField (nlHsVar scrutinee) $ MG{ mg_alts = L (getLoc lpat) cases- , mg_ext = MatchGroupTc [pat_ty] res_ty+ , mg_ext = MatchGroupTc [unrestricted 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_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty , mg_origin = Generated } match = mkMatch (mkPrefixFunRhs (L loc name)) []@@ -799,7 +799,7 @@ mkInvisForAllTys univ_bndrs $ mkInvisForAllTys ex_bndrs $ mkPhiTy theta $- mkVisFunTys arg_tys $+ mkVisFunTysMany arg_tys $ pat_ty builder_id = mkExportedVanillaId builder_name builder_sigma -- See Note [Exported LocalIds] in GHC.Types.Id@@ -884,7 +884,7 @@ add_dummy_arg other_mg = pprPanic "add_dummy_arg" $ pprMatches other_mg -tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr GhcTcId, TcSigmaType)+tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr GhcTc, TcSigmaType) -- monadic only for failure tcPatSynBuilderOcc ps | Just (builder_id, add_void_arg) <- builder@@ -905,7 +905,7 @@ add_void :: Bool -> Type -> Type add_void need_dummy_arg ty- | need_dummy_arg = mkVisFunTy voidPrimTy ty+ | need_dummy_arg = mkVisFunTyMany voidPrimTy ty | otherwise = ty tcPatToExpr :: Name -> [Located Name] -> LPat GhcRn
compiler/GHC/Tc/TyCl/Utils.hs view
@@ -36,6 +36,7 @@ import GHC.Tc.Utils.Env import GHC.Tc.Gen.Bind( tcValBinds ) import GHC.Core.TyCo.Rep( Type(..), Coercion(..), MCoercion(..), UnivCoProvenance(..) )+import GHC.Core.Multiplicity import GHC.Tc.Utils.TcType import GHC.Core.Predicate import GHC.Builtin.Types( unitTy )@@ -90,7 +91,7 @@ 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 (FunTy _ w a b) = go w `plusNameEnv` 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@@ -124,7 +125,7 @@ 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 (FunCo _ co_mult co co') = go_co co_mult `plusNameEnv` go_co co `plusNameEnv` go_co co' go_co (CoVarCo _) = emptyNameEnv go_co (HoleCo {}) = emptyNameEnv go_co (AxiomInstCo _ _ cs) = go_co_s cs@@ -579,7 +580,7 @@ = setRoleInferenceVars univ_tvs $ irExTyVars ex_tvs $ \ ex_var_set -> mapM_ (irType ex_var_set)- (map tyVarKind ex_tvs ++ eqSpecPreds eq_spec ++ theta ++ arg_tys)+ (map tyVarKind ex_tvs ++ eqSpecPreds eq_spec ++ theta ++ (map scaledThing arg_tys)) -- See Note [Role-checking data constructor arguments] where (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty)@@ -599,7 +600,7 @@ lcls' = extendVarSet lcls tv ; markNominal lcls (tyVarKind tv) ; go lcls' ty }- go lcls (FunTy _ arg res) = go lcls arg >> go lcls res+ go lcls (FunTy _ w arg res) = markNominal lcls w >> go lcls arg >> go lcls res go _ (LitTy {}) = return () -- See Note [Coercions in role inference] go lcls (CastTy ty _) = go lcls ty@@ -635,7 +636,7 @@ 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 (FunTy _ w t1 t2) = get_ty_vars w `unionFV` 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@@ -881,7 +882,10 @@ mkPhiTy (conLikeStupidTheta con1) $ -- Urgh! -- req_theta is empty for normal DataCon mkPhiTy req_theta $- mkVisFunTy data_ty $+ mkVisFunTyMany data_ty $+ -- Record selectors are always typed with Many. We+ -- could improve on it in the case where all the+ -- fields in all the constructor have multiplicity Many. field_ty -- Make the binding: sel (C2 { fld = x }) = x
compiler/GHC/Tc/Utils/Backpack.hs view
@@ -50,6 +50,7 @@ import GHC.Driver.Types import GHC.Utils.Outputable import GHC.Core.Type+import GHC.Core.Multiplicity import GHC.Data.FastString import GHC.Rename.Fixity ( lookupFixityRn ) import GHC.Data.Maybe@@ -216,7 +217,7 @@ (substTy skol_subst pred) givens <- forM theta $ \given -> do loc <- getCtLocM origin (Just TypeLevel)- let given_pred = substTy skol_subst given+ let given_pred = substTy skol_subst (scaledThing given) new_ev <- newEvVar given_pred return CtGiven { ctev_pred = given_pred -- Doesn't matter, make something up@@ -231,7 +232,7 @@ -- | 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 :: UnitState -> ModuleName -> [InstantiatedModule] requirementMerges pkgstate mod_name = fmap fixupModule $ fromMaybe [] (Map.lookup mod_name (requirementContext pkgstate)) where@@ -255,7 +256,7 @@ -- import A -- -- unit q where--- dependency p[A=<A>,B=<B>]+-- dependency p[A=\<A>,B=\<B>] -- signature A -- signature B --@@ -274,7 +275,7 @@ $ moduleFreeHolesPrecise (text "findExtraSigImports") (mkModule (VirtUnit iuid) mod_name))) where- pkgstate = pkgState (hsc_dflags hsc_env)+ pkgstate = unitState (hsc_dflags hsc_env) reqs = requirementMerges pkgstate modname findExtraSigImports' _ _ _ = return emptyUniqDSet@@ -309,7 +310,7 @@ forM normal_imports $ \(mb_pkg, L _ imp) -> do found <- findImportedModule hsc_env imp mb_pkg case found of- Found _ mod | thisPackage dflags /= moduleUnit mod ->+ Found _ mod | not (isHomeModule dflags mod) -> return (uniqDSetToList (moduleFreeHoles mod)) _ -> return [] where dflags = hsc_dflags hsc_env@@ -535,7 +536,7 @@ let outer_mod = tcg_mod tcg_env inner_mod = tcg_semantic_mod tcg_env mod_name = moduleName (tcg_mod tcg_env)- pkgstate = pkgState dflags+ pkgstate = unitState dflags -- STEP 1: Figure out all of the external signature interfaces -- we are going to merge in.@@ -549,7 +550,7 @@ im = fst (getModuleInstantiation m) in fmap fst . withException- $ findAndReadIface (text "mergeSignatures") im m False+ $ findAndReadIface (text "mergeSignatures") im m NotBoot -- STEP 3: Get the unrenamed exports of all these interfaces, -- thin it according to the export list, and do shaping on them.@@ -568,7 +569,7 @@ let insts = instUnitInsts iuid isFromSignaturePackage = let inst_uid = instUnitInstanceOf iuid- pkg = getInstalledPackageDetails pkgstate (indefUnit inst_uid)+ pkg = unsafeLookupUnitId 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@@ -731,7 +732,7 @@ -- 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+ lcl_iface <- tcRnModIface (homeUnitInstantiations dflags) (Just nsubst) lcl_iface0 let ifaces = lcl_iface : ext_ifaces -- STEP 4.1: Merge fixities (we'll verify shortly) tcg_fix_env@@ -753,7 +754,7 @@ let infos = zip ifaces detailss -- Test for cycles- checkSynCycles (thisPackage dflags) (typeEnvTyCons type_env) []+ checkSynCycles (homeUnit 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@@ -842,7 +843,7 @@ -- 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+ calculateAvails dflags iface' False NotBoot ImportedBySystem return tcg_env { tcg_inst_env = inst_env, tcg_insts = insts,@@ -929,7 +930,7 @@ dflags <- getDynFlags let avails = calculateAvails dflags- impl_iface False{- safe -} False{- boot -} ImportedBySystem+ impl_iface False{- safe -} NotBoot ImportedBySystem fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f) | (occ, f) <- mi_fixities impl_iface , rdr_elt <- lookupGlobalRdrEnv impl_gr occ ]@@ -953,7 +954,7 @@ -- 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+ mb_isig_iface <- findAndReadIface (text "checkImplements 2") isig_mod sig_mod NotBoot isig_iface <- case mb_isig_iface of Succeeded (iface, _) -> return iface Failed err -> failWithTc $@@ -1000,9 +1001,13 @@ -- 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 )+ MASSERT( isHomeModule dflags outer_mod )+ MASSERT( isJust (homeUnitInstanceOfId dflags) )+ let uid = fromJust (homeUnitInstanceOfId dflags)+ -- we need to fetch the most recent ppr infos from the unit+ -- database because we might have modified it+ uid' = updateIndefUnitId (unitState dflags) uid inner_mod `checkImplements` Module- (mkInstantiatedUnit (thisComponentId dflags)- (thisUnitIdInsts dflags))+ (mkInstantiatedUnit uid' (homeUnitInstantiations dflags)) (moduleName outer_mod)
compiler/GHC/Tc/Utils/Env.hs view
@@ -34,6 +34,7 @@ tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, tcExtendBinderStack, tcExtendLocalTypeEnv, isTypeClosedLetBndr,+ tcCheckUsage, tcLookup, tcLookupLocated, tcLookupLocalIds, tcLookupId, tcLookupIdMaybe, tcLookupTyVar,@@ -78,6 +79,10 @@ import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType+import GHC.Core.UsageEnv+import GHC.Tc.Types.Evidence (HsWrapper, idHsWrapper)+import {-# SOURCE #-} GHC.Tc.Utils.Unify ( tcSubMult )+import GHC.Tc.Types.Origin ( CtOrigin(UsageEnvironmentOf) ) import GHC.Iface.Load import GHC.Builtin.Names import GHC.Builtin.Types@@ -133,7 +138,7 @@ } lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing)--- This may look up an Id that one one has previously looked up.+-- This may look up an Id that one has previously looked up. -- If so, we are going to read its interface file, and add its bindings -- to the ExternalPackageTable. lookupGlobal_maybe hsc_env name@@ -593,28 +598,55 @@ -- 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] }+ ; env0@(TcLclEnv { tcl_rdr = rdr_env+ , tcl_th_bndrs = th_bndrs+ , tcl_env = lcl_type_env }) <- getLclEnv + ; let thlvl = (top_lvl, thLevel stage)++ env1 = env0 { tcl_rdr = extendLocalRdrEnvList rdr_env+ [ n | (n, _) <- extra_env, isInternalName n ]+ -- The LocalRdrEnv contains only non-top-level names+ -- (GlobalRdrEnv handles the top level)++ , tcl_th_bndrs = extendNameEnvList th_bndrs+ [(n, thlvl) | (n, ATcId {}) <- extra_env]+ -- We only track Ids in tcl_th_bndrs++ , tcl_env = extendNameEnvList lcl_type_env extra_env }++ -- tcl_rdr and tcl_th_bndrs: extend the local LocalRdrEnv and+ -- Template Haskell staging env simultaneously. Reason for extending+ -- LocalRdrEnv: after running a TH splice we need to do renaming.++ ; setLclEnv env1 thing_inside }+ 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 }++-- | @tcCheckUsage name mult thing_inside@ runs @thing_inside@, checks that the+-- usage of @name@ is a submultiplicity of @mult@, and removes @name@ from the+-- usage environment. See also Note [tcSubMult's wrapper] in TcUnify.+tcCheckUsage :: Name -> Mult -> TcM a -> TcM (a, HsWrapper)+tcCheckUsage name id_mult thing_inside+ = do { (local_usage, result) <- tcCollectingUsage thing_inside+ ; wrapper <- check_then_add_usage local_usage+ ; return (result, wrapper) }+ where+ check_then_add_usage :: UsageEnv -> TcM HsWrapper+ -- Checks that the usage of the newly introduced binder is compatible with+ -- its multiplicity, and combines the usage of non-new binders to |uenv|+ check_then_add_usage uenv+ = do { let actual_u = lookupUE uenv name+ ; traceTc "check_then_add_usage" (ppr id_mult $$ ppr actual_u)+ ; wrapper <- case actual_u of+ Bottom -> return idHsWrapper+ Zero -> tcSubMult (UsageEnvironmentOf name) Many id_mult+ MUsage m -> tcSubMult (UsageEnvironmentOf name) m id_mult+ ; tcEmitBindingUsage (deleteUE uenv name)+ ; return wrapper } {- ********************************************************************* * *
compiler/GHC/Tc/Utils/Instantiate.hs view
@@ -10,14 +10,13 @@ {-# 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,+ topSkolemise,+ topInstantiate, topInstantiateInferred, instCall, instDFunType, instStupidTheta, instTyVarsWith, newWanted, newWanteds, - tcInstInvisibleTyBinders, tcInstInvisibleTyBinder,+ tcInstInvisibleTyBindersN, tcInstInvisibleTyBinders, tcInstInvisibleTyBinder, newOverloadedLit, mkOverLit, @@ -36,11 +35,10 @@ import GHC.Prelude -import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcCheckExpr, tcSyntaxOp )+import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcCheckPolyExpr, 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@@ -50,11 +48,12 @@ import GHC.Tc.Utils.Env import GHC.Tc.Types.Evidence import GHC.Core.InstEnv-import GHC.Builtin.Types ( heqDataCon, eqDataCon )+import GHC.Builtin.Types ( heqDataCon, eqDataCon, integerTyConName ) import GHC.Core ( isOrphan ) import GHC.Tc.Instance.FunDeps import GHC.Tc.Utils.TcMType import GHC.Core.Type+import GHC.Core.Multiplicity import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr ( debugPprType ) import GHC.Tc.Utils.TcType@@ -91,7 +90,7 @@ :: CtOrigin -- ^ why do we need this? -> Name -- ^ name of the method -> [TcRhoType] -- ^ types with which to instantiate the class- -> TcM (HsExpr GhcTcId)+ -> TcM (HsExpr GhcTc) -- ^ 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 --@@ -117,66 +116,62 @@ {- ************************************************************************ * *- Deep instantiation and skolemisation+ 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)+Note [Skolemisation]+~~~~~~~~~~~~~~~~~~~~+topSkolemise decomposes and skolemises a type, returning a type+with no top level foralls or (=>) Examples: - deeplySkolemise (Int -> forall a. Ord a => blah)- = ( wp, [a], [d:Ord a], Int -> blah )- where wp = \x:Int. /\a. \(d:Ord a). <hole> x+ topSkolemise (forall a. Ord a => a -> a)+ = ( wp, [a], [d:Ord a], a->a )+ where wp = /\a. \(d:Ord a). <hole> a d - 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). <hole> x+ topSkolemise (forall a. Ord a => forall b. Eq b => a->b->b)+ = ( wp, [a,b], [d1:Ord a,d2:Eq b], a->b->b )+ where wp = /\a.\(d1:Ord a)./\b.\(d2:Ord b). <hole> a d1 b d2 +This second example is the reason for the recursive 'go'+function in topSkolemise: we must remove successive layers+of foralls and (=>).+ In general,- if deeplySkolemise ty = (wrap, tvs, evs, rho)+ if topSkolemise ty = (wrap, tvs, evs, rho) and e :: rho then wrap e :: ty- and 'wrap' binds tvs, evs+ 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+topSkolemise :: TcSigmaType+ -> TcM ( HsWrapper+ , [(Name,TyVar)] -- All skolemised variables+ , [EvVar] -- All "given"s+ , TcRhoType )+-- See Note [Skolemisation]+topSkolemise ty+ = go init_subst idHsWrapper [] [] 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+ -- Why recursive? See Note [Skolemisation]+ go subst wrap tv_prs ev_vars ty+ | (tvs, theta, inner_ty) <- tcSplitSigmaTy ty+ , not (null tvs && null theta)+ = do { (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 ) }+ ; go subst'+ (wrap <.> mkWpTyLams tvs1 <.> mkWpLams ev_vars1)+ (tv_prs ++ (map tyVarName tvs `zip` tvs1))+ (ev_vars ++ ev_vars1)+ inner_ty } | otherwise- = return (idHsWrapper, [], [], substTy subst ty)+ = return (wrap, tv_prs, ev_vars, substTy subst ty) -- substTy is a quick no-op on an empty substitution -- | Instantiate all outer type variables@@ -185,6 +180,7 @@ -- if topInstantiate ty = (wrap, rho) -- and e :: ty -- then wrap e :: rho (that is, wrap :: ty "->" rho)+-- NB: always returns a rho-type, with no top-level forall or (=>) topInstantiate = top_instantiate True -- | Instantiate all outer 'Inferred' binders@@ -195,13 +191,16 @@ -- if topInstantiate ty = (wrap, rho) -- and e :: ty -- then wrap e :: rho+-- NB: may return a sigma-type 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)+ | (binders, phi) <- tcSplitForAllVarBndrs ty+ , (theta, rho) <- tcSplitPhiTy phi+ , not (null binders && null theta) = do { let (inst_bndrs, leave_bndrs) = span should_inst binders (inst_theta, leave_theta) | null leave_bndrs = (theta, [])@@ -226,7 +225,7 @@ , text "theta:" <+> ppr inst_theta' ]) ; (wrap2, rho2) <-- if null leave_bndrs+ if null leave_bndrs -- NB: if inst_all is True then leave_bndrs = [] -- account for types like forall a. Num a => forall b. Ord b => ... then top_instantiate inst_all orig sigma'@@ -238,67 +237,11 @@ | 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@@ -423,13 +366,19 @@ * * ********************************************************************* -} --- | Instantiates up to n invisible binders--- Returns the instantiating types, and body kind-tcInstInvisibleTyBinders :: Int -> TcKind -> TcM ([TcType], TcKind)+-- | Given ty::forall k1 k2. k, instantiate all the invisible forall-binders+-- returning ty @kk1 @kk2 :: k[kk1/k1, kk2/k1]+tcInstInvisibleTyBinders :: TcType -> TcKind -> TcM (TcType, TcKind)+tcInstInvisibleTyBinders ty kind+ = do { (extra_args, kind') <- tcInstInvisibleTyBindersN n_invis kind+ ; return (mkAppTys ty extra_args, kind') }+ where+ n_invis = invisibleTyBndrCount kind -tcInstInvisibleTyBinders 0 kind+tcInstInvisibleTyBindersN :: Int -> TcKind -> TcM ([TcType], TcKind)+tcInstInvisibleTyBindersN 0 kind = return ([], kind)-tcInstInvisibleTyBinders n ty+tcInstInvisibleTyBindersN n ty = go n empty_subst ty where empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))@@ -451,7 +400,7 @@ ; return (subst', mkTyVarTy tv') } tcInstInvisibleTyBinder subst (Anon af ty)- | Just (mk, k1, k2) <- get_eq_tys_maybe (substTy subst ty)+ | Just (mk, k1, k2) <- get_eq_tys_maybe (substTy subst (scaledThing ty)) -- Equality is the *only* constraint currently handled in types. -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep = ASSERT( af == InvisArg )@@ -521,7 +470,7 @@ newOverloadedLit :: HsOverLit GhcRn -> ExpRhoType- -> TcM (HsOverLit GhcTcId)+ -> TcM (HsOverLit GhcTc) newOverloadedLit lit@(OverLit { ol_val = val, ol_ext = rebindable }) res_ty | not rebindable@@ -550,7 +499,7 @@ newNonTrivialOverloadedLit :: CtOrigin -> HsOverLit GhcRn -> ExpRhoType- -> TcM (HsOverLit GhcTcId)+ -> TcM (HsOverLit GhcTc) newNonTrivialOverloadedLit orig lit@(OverLit { ol_val = val, ol_witness = HsVar _ (L _ meth_name) , ol_ext = rebindable }) res_ty@@ -558,7 +507,7 @@ ; let lit_ty = hsLitType hs_lit ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name) [synKnownType lit_ty] res_ty $- \_ -> return ()+ \_ _ -> return () ; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit] ; res_ty <- readExpType res_ty ; return (lit { ol_witness = witness@@ -614,10 +563,10 @@ tcSyntaxName :: CtOrigin -> TcType -- ^ Type to instantiate it at -> (Name, HsExpr GhcRn) -- ^ (Standard name, user name)- -> TcM (Name, HsExpr GhcTcId)+ -> TcM (Name, HsExpr GhcTc) -- ^ (Standard name, suitable expression) -- USED ONLY FOR CmdTop (sigh) ***--- See Note [CmdSyntaxTable] in GHC.Hs.Expr+-- See Note [CmdSyntaxTable] in "GHC.Hs.Expr" tcSyntaxName orig ty (std_nm, HsVar _ (L _ user_nm)) | std_nm == user_nm@@ -639,7 +588,7 @@ -- same type as the standard one. -- Tiresome jiggling because tcCheckSigma takes a located expression span <- getSrcSpanM- expr <- tcCheckExpr (L span user_nm_expr) sigma1+ expr <- tcCheckPolyExpr (L span user_nm_expr) sigma1 return (std_nm, unLoc expr) syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> TidyEnv
compiler/GHC/Tc/Utils/Monad.hs view
@@ -69,6 +69,9 @@ addMessages, discardWarnings, + -- * Usage environment+ tcCollectingUsage, tcScalingUsage, tcEmitBindingUsage,+ -- * Shared error message stuff: renamer and typechecker mkLongErrAt, mkErrDocAt, addLongErrAt, reportErrors, reportError, reportWarning, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM,@@ -98,7 +101,8 @@ chooseUniqueOccTc, getConstraintVar, setConstraintVar, emitConstraints, emitStaticConstraints, emitSimple, emitSimples,- emitImplication, emitImplications, emitInsoluble, emitHole,+ emitImplication, emitImplications, emitInsoluble,+ emitHole, emitHoles, discardConstraints, captureConstraints, tryCaptureConstraints, pushLevelAndCaptureConstraints, pushTcLevelM_, pushTcLevelM, pushTcLevelsM,@@ -156,6 +160,8 @@ import GHC.Unit import GHC.Types.Name.Reader import GHC.Types.Name+import GHC.Core.UsageEnv+import GHC.Core.Multiplicity import GHC.Core.Type import GHC.Tc.Utils.TcType@@ -264,7 +270,8 @@ tcg_rdr_env = emptyGlobalRdrEnv, tcg_fix_env = emptyNameEnv, tcg_field_env = emptyNameEnv,- tcg_default = if moduleUnit mod == primUnitId+ tcg_default = if moduleUnit mod == primUnit+ || moduleUnit mod == bignumUnit then Just [] -- See Note [Default types] else Nothing, tcg_type_env = emptyNameEnv,@@ -331,6 +338,7 @@ initTcWithGbl hsc_env gbl_env loc do_this = do { lie_var <- newIORef emptyWC ; errs_var <- newIORef (emptyBag, emptyBag)+ ; usage_var <- newIORef zeroUE ; let lcl_env = TcLclEnv { tcl_errs = errs_var, tcl_loc = loc, -- Should be over-ridden very soon!@@ -340,6 +348,7 @@ tcl_th_bndrs = emptyNameEnv, tcl_arrow_ctxt = NoArrowCtxt, tcl_env = emptyNameEnv,+ tcl_usage = usage_var, tcl_bndrs = [], tcl_lie = lie_var, tcl_tclvl = topTcLevel@@ -382,10 +391,10 @@ {- 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".+The Integer type is simply not available in ghc-prim and ghc-bignum packages (it+is declared in ghc-bignum). So we set the defaulting types to (Just []), meaning+there are no default types, rather than 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).@@ -624,15 +633,16 @@ = do { uniq <- newUnique ; return (mkSystemName uniq occ) } -newSysLocalId :: FastString -> TcType -> TcRnIf gbl lcl TcId-newSysLocalId fs ty+newSysLocalId :: FastString -> Mult -> TcType -> TcRnIf gbl lcl TcId+newSysLocalId fs w ty = do { u <- newUnique- ; return (mkSysLocal fs u ty) }+ ; return (mkSysLocal fs u w ty) } -newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]+newSysLocalIds :: FastString -> [Scaled TcType] -> TcRnIf gbl lcl [TcId] newSysLocalIds fs tys = do { us <- newUniqueSupply- ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) }+ ; let mkId' n (Scaled w t) = mkSysLocal fs n w t+ ; return (zipWith mkId' (uniqsFromSupply us) tys) } instance MonadUnique (IOEnv (Env gbl lcl)) where getUniqueM = newUnique@@ -1145,7 +1155,7 @@ ; addMessages msgs ; case mb_res of- Nothing -> do { emitConstraints (insolublesOnly lie)+ Nothing -> do { emitConstraints (dropMisleading lie) ; failM } Just res -> do { emitConstraints lie@@ -1167,7 +1177,7 @@ -- See Note [Constraints and errors] ; let lie_to_keep = case mb_res of- Nothing -> insolublesOnly lie+ Nothing -> dropMisleading lie Just {} -> lie ; return (mb_res, lie_to_keep) }@@ -1190,6 +1200,36 @@ Just res -> return (res, lie) } -----------------------+-- | @tcCollectingUsage thing_inside@ runs @thing_inside@ and returns the usage+-- information which was collected as part of the execution of+-- @thing_inside@. Careful: @tcCollectingUsage thing_inside@ itself does not+-- report any usage information, it's up to the caller to incorporate the+-- returned usage information into the larger context appropriately.+tcCollectingUsage :: TcM a -> TcM (UsageEnv,a)+tcCollectingUsage thing_inside+ = do { env0 <- getLclEnv+ ; local_usage_ref <- newTcRef zeroUE+ ; let env1 = env0 { tcl_usage = local_usage_ref }+ ; result <- setLclEnv env1 thing_inside+ ; local_usage <- readTcRef local_usage_ref+ ; return (local_usage,result) }++-- | @tcScalingUsage mult thing_inside@ runs @thing_inside@ and scales all the+-- usage information by @mult@.+tcScalingUsage :: Mult -> TcM a -> TcM a+tcScalingUsage mult thing_inside+ = do { (usage, result) <- tcCollectingUsage thing_inside+ ; traceTc "tcScalingUsage" (ppr mult)+ ; tcEmitBindingUsage $ scaleUE mult usage+ ; return result }++tcEmitBindingUsage :: UsageEnv -> TcM ()+tcEmitBindingUsage ue+ = do { lcl_env <- getLclEnv+ ; let usage = tcl_usage lcl_env+ ; updTcRef usage (addUE ue) }++----------------------- attemptM :: TcRn r -> TcRn (Maybe r) -- (attemptM thing_inside) runs thing_inside -- If thing_inside succeeds, returning r,@@ -1479,7 +1519,7 @@ , 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+-- tracks covar usages (see comments on ebv_tcvs in "GHC.Tc.Types.Evidence"), thus -- must be made monadically newNoTcEvBinds :: TcM EvBindsVar newNoTcEvBinds@@ -1589,8 +1629,14 @@ emitHole hole = do { traceTc "emitHole" (ppr hole) ; lie_var <- getConstraintVar- ; updTcRef lie_var (`addHole` hole) }+ ; updTcRef lie_var (`addHoles` unitBag hole) } +emitHoles :: Bag Hole -> TcM ()+emitHoles holes+ = do { traceTc "emitHoles" (ppr holes)+ ; lie_var <- getConstraintVar+ ; updTcRef lie_var (`addHoles` holes) }+ -- | Throw out any constraints emitted by the thing_inside discardConstraints :: TcM a -> TcM a discardConstraints thing_inside = fst <$> captureConstraints thing_inside@@ -1830,7 +1876,7 @@ ************************************************************************ -} -mkIfLclEnv :: Module -> SDoc -> Bool -> IfLclEnv+mkIfLclEnv :: Module -> SDoc -> IsBootInterface -> IfLclEnv mkIfLclEnv mod loc boot = IfLclEnv { if_mod = mod, if_loc = loc,@@ -1850,8 +1896,8 @@ ; 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))+ is_instantiate = homeUnitIsDefinite dflags &&+ not (null (homeUnitInstantiations dflags)) ; let { if_env = IfGblEnv { if_doc = text "initIfaceTcRn", if_rec_types =@@ -1887,14 +1933,14 @@ } initTcRnIf 'i' hsc_env gbl_env () do_this -initIfaceLcl :: Module -> SDoc -> Bool -> IfL a -> IfM lcl a+initIfaceLcl :: Module -> SDoc -> IsBootInterface -> 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 :: Module -> SDoc -> IsBootInterface -> 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 @@ -1911,7 +1957,7 @@ ; let full_msg = (if_loc env <> colon) $$ nest 2 msg ; dflags <- getDynFlags ; liftIO (putLogMsg dflags NoReason SevFatal- noSrcSpan $ withPprStyle (defaultErrStyle dflags) full_msg)+ noSrcSpan $ withPprStyle defaultErrStyle full_msg) ; failM } --------------------@@ -1947,7 +1993,7 @@ NoReason SevFatal noSrcSpan- $ withPprStyle (defaultErrStyle dflags) msg+ $ withPprStyle defaultErrStyle msg ; traceIf (text "} ending fork (badly)" <+> doc) ; return Nothing }
compiler/GHC/Tc/Utils/TcMType.hs view
@@ -4,7 +4,7 @@ -} -{-# LANGUAGE CPP, TupleSections, MultiWayIf #-}+{-# LANGUAGE CPP, TupleSections, MultiWayIf, PatternSynonyms #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -26,8 +26,10 @@ cloneMetaTyVar, newFmvTyVar, newFskTyVar, + newMultiplicityVar, readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef,- newMetaDetails, isFilledMetaTyVar_maybe, isFilledMetaTyVar, isUnfilledMetaTyVar,+ newTauTvDetailsAtLevel, newMetaDetails, newMetaTyVarName,+ isFilledMetaTyVar_maybe, isFilledMetaTyVar, isUnfilledMetaTyVar, -------------------------------- -- Expected types@@ -70,7 +72,7 @@ zonkTidyTcType, zonkTidyTcTypes, zonkTidyOrigin, tidyEvVar, tidyCt, tidyHole, tidySkolemInfo, zonkTcTyVar, zonkTcTyVars,- zonkTcTyVarToTyVar, zonkTyVarTyVarPairs,+ zonkTcTyVarToTyVar, zonkInvisTVBinder, zonkTyCoVarsAndFV, zonkTcTypeAndFV, zonkDTyCoVarSetAndFV, zonkTyCoVarsAndFVList, candidateQTyVarsOfType, candidateQTyVarsOfKind,@@ -81,7 +83,7 @@ zonkTcType, zonkTcTypes, zonkCo, zonkTyCoVarKind, zonkTyCoVarKindBinder, - zonkEvVar, zonkWC, zonkSimples,+ zonkEvVar, zonkWC, zonkImplication, zonkSimples, zonkId, zonkCoVar, zonkCt, zonkSkolemInfo, @@ -119,7 +121,6 @@ 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@@ -144,18 +145,13 @@ ************************************************************************ -} -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+ ; name <- newMetaTyVarName (fsLit "k")+ -- All MetaKindVars are called "k"+ -- They may be jiggled by tidying+ ; let kv = mkTcTyVar name liftedTypeKind details ; traceTc "newMetaKindVar" (ppr kv) ; return (mkTyVarTy kv) } @@ -178,7 +174,7 @@ newEvVar :: TcPredType -> TcRnIf gbl lcl EvVar -- Creates new *rigid* variables for predicates newEvVar ty = do { name <- newSysName (predTypeOccName ty)- ; return (mkLocalIdOrCoVar name ty) }+ ; return (mkLocalIdOrCoVar name Many ty) } newWanted :: CtOrigin -> Maybe TypeOrKind -> PredType -> TcM CtEvidence -- Deals with both equality and non-equality predicates@@ -291,7 +287,7 @@ newDict :: Class -> [TcType] -> TcM DictId newDict cls tys = do { name <- newSysName (mkDictOcc (getOccName cls))- ; return (mkLocalId name (mkClassPred cls tys)) }+ ; return (mkLocalId name Many (mkClassPred cls tys)) } predTypeOccName :: PredType -> OccName predTypeOccName ty = case classifyPredType ty of@@ -308,7 +304,7 @@ -- -- 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.+-- Note [Avoid -Winaccessible-code when deriving] in "GHC.Tc.TyCl.Instance". newImplication :: TcM Implication newImplication = do env <- getLclEnv@@ -548,14 +544,8 @@ -> TcM ([(Name, VarBndr TcTyVar Specificity)], TcThetaType, TcType) -- ^ Result -- (type vars, preds (incl equalities), rho) tcInstTypeBndrs inst_tyvars id =- let (tyvars, rho) = splitForAllVarBndrs (idType id)- tyvars' = map argf_to_spec tyvars- in tc_inst_internal inst_tyvars tyvars' rho- where- argf_to_spec :: VarBndr TyCoVar ArgFlag -> VarBndr TyCoVar Specificity- argf_to_spec (Bndr tv Required) = Bndr tv SpecifiedSpec- -- see Note [Specificity in HsForAllTy] in GHC.Hs.Type- argf_to_spec (Bndr tv (Invisible s)) = Bndr tv s+ let (tyvars, rho) = splitForAllTysInvis (idType id)+ in tc_inst_internal inst_tyvars tyvars rho tcSkolDFunType :: DFunId -> TcM ([TcTyVar], TcThetaType, TcType) -- Instantiate a type signature with skolem constants.@@ -619,12 +609,12 @@ 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+-- Used in 'GHC.Tc.Instance.Family.newFamInst', and 'GHC.Tc.Utils.Instantiate.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+-- Used in "GHC.Tc.Instance.Family.newFamInst" freshenCoVarBndrsX subst = freshenTyCoVarsX mkCoVar subst ------------------@@ -834,6 +824,13 @@ , mtv_ref = ref , mtv_tclvl = tclvl }) } +newTauTvDetailsAtLevel :: TcLevel -> TcM TcTyVarDetails+newTauTvDetailsAtLevel tclvl+ = do { ref <- newMutVar Flexi+ ; return (MetaTv { mtv_info = TauTv+ , mtv_ref = ref+ , mtv_tclvl = tclvl }) }+ cloneMetaTyVar :: TcTyVar -> TcM TcTyVar cloneMetaTyVar tv = ASSERT( isTcTyVar tv )@@ -929,6 +926,7 @@ -- Check for level OK -- See Note [Level check when unifying] ; MASSERT2( level_check_ok, level_check_msg )+ -- another level check problem, see #97 -- Check Kinds ok ; MASSERT2( kind_check_ok, kind_msg )@@ -986,6 +984,9 @@ -} +newMultiplicityVar :: TcM TcType+newMultiplicityVar = newFlexiTyVarTy multiplicityTy+ newFlexiTyVar :: Kind -> TcM TcTyVar newFlexiTyVar kind = newAnonMetaTyVar TauTv kind @@ -1060,18 +1061,15 @@ -- is not yet fixed so leaving as unchecked for now. -- OLD NOTE: -- Unchecked because we call newMetaTyVarX from- -- tcInstTyBinder, which is called from tcInferApps+ -- tcInstTyBinder, which is called from tcInferTyApps -- which does not yet take enough trouble to ensure -- the in-scope set is right; e.g. #12785 trips -- if we use substTy here newMetaTyVarTyAtLevel :: TcLevel -> TcKind -> TcM TcType newMetaTyVarTyAtLevel tc_lvl kind- = do { ref <- newMutVar Flexi- ; name <- newMetaTyVarName (fsLit "p")- ; let details = MetaTv { mtv_info = TauTv- , mtv_ref = ref- , mtv_tclvl = tc_lvl }+ = do { details <- newTauTvDetailsAtLevel tc_lvl+ ; name <- newMetaTyVarName (fsLit "p") ; return (mkTyVarTy (mkTcTyVar name kind details)) } {- *********************************************************************@@ -1254,13 +1252,14 @@ candidateKindVars :: CandidatesQTvs -> TyVarSet candidateKindVars dvs = dVarSetToVarSet (dv_kvs dvs) -partitionCandidates :: CandidatesQTvs -> (TyVar -> Bool) -> (DTyVarSet, CandidatesQTvs)+partitionCandidates :: CandidatesQTvs -> (TyVar -> Bool) -> (TyVarSet, CandidatesQTvs)+-- The selected TyVars are returned as a non-deterministic TyVarSet partitionCandidates dvs@(DV { dv_kvs = kvs, dv_tvs = tvs }) pred = (extracted, dvs { dv_kvs = rest_kvs, dv_tvs = rest_tvs }) where (extracted_kvs, rest_kvs) = partitionDVarSet pred kvs (extracted_tvs, rest_tvs) = partitionDVarSet pred tvs- extracted = extracted_kvs `unionDVarSet` extracted_tvs+ extracted = dVarSetToVarSet extracted_kvs `unionVarSet` dVarSetToVarSet extracted_tvs -- | Gathers free variables to use as quantification candidates (in -- 'quantifyTyVars'). This might output the same var@@ -1326,9 +1325,9 @@ ----------------- 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 (AppTy t1 t2) = foldlM go dv [t1, t2]+ go dv (TyConApp _ tys) = foldlM go dv tys+ go dv (FunTy _ w arg res) = foldlM go dv [w, arg, res] go dv (LitTy {}) = return dv go dv (CastTy ty co) = do dv1 <- go dv ty collect_cand_qtvs_co orig_ty bound dv1 co@@ -1399,7 +1398,7 @@ 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 (FunCo _ w co1 co2) = foldlM go_co dv [w, co1, co2] go_co dv (AxiomInstCo _ _ cos) = foldlM go_co dv cos go_co dv (AxiomRuleCo _ cos) = foldlM go_co dv cos go_co dv (UnivCo prov _ t1 t2) = do dv1 <- go_prov dv prov@@ -1731,6 +1730,10 @@ = do { traceTc "Defaulting a RuntimeRep var to LiftedRep" (ppr tv) ; writeMetaTyVar tv liftedRepTy ; return True }+ | isMultiplicityVar tv+ = do { traceTc "Defaulting a Multiplicty var to Many" (ppr tv)+ ; writeMetaTyVar tv manyDataConTy+ ; return True } | default_kind -- -XNoPolyKinds and this is a kind var = default_kind_var tv -- so default it to * if possible@@ -2036,8 +2039,7 @@ , ic_info = info' }) } zonkEvVar :: EvVar -> TcM EvVar-zonkEvVar var = do { ty' <- zonkTcType (varType var)- ; return (setVarType var ty') }+zonkEvVar var = updateIdTypeAndMultM zonkTcType var zonkWC :: WantedConstraints -> TcM WantedConstraints@@ -2218,18 +2220,13 @@ (ppr tv $$ ppr ty) ; return tv' } -zonkTyVarTyVarPairs :: [(Name,VarBndr TcTyVar Specificity)] -> TcM [(Name,VarBndr TcTyVar Specificity)]-zonkTyVarTyVarPairs prs- = mapM do_one prs- where- do_one (nm, Bndr tv spec) = do { tv' <- zonkTcTyVarToTyVar tv- ; return (nm, Bndr tv' spec) }+zonkInvisTVBinder :: VarBndr TcTyVar spec -> TcM (VarBndr TyVar spec)+zonkInvisTVBinder (Bndr tv spec) = do { tv' <- zonkTcTyVarToTyVar tv+ ; return (Bndr tv' spec) } -- 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') }+zonkId id = Id.updateIdTypeAndMultM zonkTcType id zonkCoVar :: CoVar -> TcM CoVar zonkCoVar = zonkId@@ -2317,7 +2314,7 @@ ---------------- tidyEvVar :: TidyEnv -> EvVar -> EvVar-tidyEvVar env var = setVarType var (tidyType env (varType var))+tidyEvVar env var = updateIdTypeAndMult (tidyType env) var ---------------- tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo@@ -2330,7 +2327,7 @@ tidySigSkol :: TidyEnv -> UserTypeCtxt -> TcType -> [(Name,TcTyVar)] -> SkolemInfo -- We need to take special care when tidying SigSkol--- See Note [SigSkol SkolemInfo] in Origin+-- See Note [SigSkol SkolemInfo] in "GHC.Tc.Types.Origin" tidySigSkol env cx ty tv_prs = SigSkol cx (tidy_ty env ty) tv_prs' where@@ -2342,8 +2339,10 @@ 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@(FunTy InvisArg w arg res) -- Look under c => t+ = ty { ft_mult = tidy_ty env w,+ ft_arg = tidyType env arg,+ ft_res = tidy_ty env res } tidy_ty env ty = tidyType env ty
compiler/GHC/Tc/Utils/Unify.hs view
@@ -13,11 +13,12 @@ -- | 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,+ tcWrapResult, tcWrapResultO, tcWrapResultMono,+ tcSkolemise, tcSkolemiseScoped, tcSkolemiseET,+ tcSubType, tcSubTypeSigma, tcSubTypePat,+ tcSubMult, checkConstraints, checkTvConstraints,- buildImplicationFor, emitResidualTvConstraint,+ buildImplicationFor, buildTvImplication, emitResidualTvConstraint, -- Various unifications unifyType, unifyKind,@@ -31,7 +32,7 @@ matchExpectedTyConApp, matchExpectedAppTy, matchExpectedFunTys,- matchActualFunTys, matchActualFunTysPart,+ matchActualFunTysRho, matchActualFunTySigma, matchExpectedFunKind, metaTyVarUpdateOK, occCheckForErrors, MetaTyVarUpdateResult(..)@@ -48,8 +49,10 @@ import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType+import GHC.Tc.Utils.Env import GHC.Core.Type import GHC.Core.Coercion+import GHC.Core.Multiplicity import GHC.Tc.Types.Evidence import GHC.Tc.Types.Constraint import GHC.Core.Predicate@@ -70,7 +73,6 @@ import qualified GHC.LanguageExtensions as LangExt import GHC.Utils.Outputable as Outputable -import Data.Maybe( isNothing ) import Control.Monad import Control.Arrow ( second ) @@ -139,34 +141,46 @@ -} -- Use this one when you have an "expected" type.+-- This function skolemises at each polytype. matchExpectedFunTys :: forall a. SDoc -- See Note [Herald for matchExpectedFunTys]+ -> UserTypeCtxt -> Arity- -> ExpRhoType -- deeply skolemised- -> ([ExpSigmaType] -> ExpRhoType -> TcM a)- -- must fill in these ExpTypes here- -> TcM (a, HsWrapper)+ -> ExpRhoType -- Skolemised+ -> ([Scaled ExpSigmaType] -> ExpRhoType -> TcM a)+ -> TcM (HsWrapper, a) -- If matchExpectedFunTys n ty = (_, wrap) -- then wrap : (t1 -> ... -> tn -> ty_r) ~> ty, -- where [t1, ..., tn], ty_r are passed to the thing_inside-matchExpectedFunTys herald arity orig_ty thing_inside+matchExpectedFunTys herald ctx 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) }+ -- Skolemise any foralls /before/ the zero-arg case+ -- so that we guarantee to return a rho-type+ go acc_arg_tys n ty+ | (tvs, theta, _) <- tcSplitSigmaTy ty+ , not (null tvs && null theta)+ = do { (wrap_gen, (wrap_res, result)) <- tcSkolemise ctx ty $ \ty' ->+ go acc_arg_tys n ty'+ ; return (wrap_gen <.> wrap_res, result) } + -- No more args; do this /before/ tcView, so+ -- that we do not unnecessarily unwrap synonyms+ go acc_arg_tys 0 rho_ty+ = do { result <- thing_inside (reverse acc_arg_tys) (mkCheckExpType rho_ty)+ ; return (idHsWrapper, result) }+ go acc_arg_tys n ty | Just ty' <- 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 })+ go acc_arg_tys n (FunTy { ft_mult = mult, 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)+ do { (wrap_res, result) <- go ((Scaled mult $ mkCheckExpType arg_ty) : acc_arg_tys) (n-1) res_ty- ; return ( result- , mkWpFun idHsWrapper wrap_res arg_ty res_ty doc ) }+ ; let fun_wrap = mkWpFun idHsWrapper wrap_res (Scaled mult arg_ty) res_ty doc+ ; return ( fun_wrap, result ) } where doc = text "When inferring the argument type of a function with type" <+> quotes (ppr orig_ty)@@ -197,59 +211,77 @@ defer acc_arg_tys n (mkCheckExpType ty) ------------- defer :: [ExpSigmaType] -> Arity -> ExpRhoType -> TcM (a, HsWrapper)+ defer :: [Scaled ExpSigmaType] -> Arity -> ExpRhoType -> TcM (HsWrapper, a) 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+ ; result <- thing_inside (reverse acc_arg_tys ++ (map unrestricted 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+ ; let unif_fun_ty = mkVisFunTysMany more_arg_tys res_ty+ ; wrap <- tcSubType AppOrigin ctx unif_fun_ty fun_ty -- Not a good origin at all :-(- ; return (result, wrap) }+ ; return (wrap, result) } ------------- mk_ctxt :: [ExpSigmaType] -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc)+ mk_ctxt :: [Scaled 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)+ arg_tys' = map (\(Scaled u v) -> Scaled u (checkingExpType "matchExpectedFunTys" v)) (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+matchActualFunTysRho :: SDoc -- See Note [Herald for matchExpectedFunTys]+ -> CtOrigin+ -> Maybe (HsExpr GhcRn) -- the thing with type TcSigmaType+ -> Arity+ -> TcSigmaType+ -> TcM (HsWrapper, [Scaled TcSigmaType], TcRhoType)+-- If matchActualFunTysRho n ty = (wrap, [t1,..,tn], res_ty)+-- then wrap : ty ~> (t1 -> ... -> tn -> res_ty)+-- and res_ty is a RhoType+-- NB: the returned type is top-instantiated; it's a RhoType+matchActualFunTysRho herald ct_orig mb_thing n_val_args_wanted fun_ty+ = go n_val_args_wanted [] fun_ty+ where+ go 0 _ fun_ty+ = do { (wrap, rho) <- topInstantiate ct_orig fun_ty+ ; return (wrap, [], rho) }+ go n so_far fun_ty+ = do { (wrap_fun1, arg_ty1, res_ty1) <- matchActualFunTySigma+ herald ct_orig mb_thing+ (n_val_args_wanted, so_far)+ fun_ty+ ; (wrap_res, arg_tys, res_ty) <- go (n-1) (arg_ty1:so_far) res_ty1+ ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg_ty1 res_ty doc+ ; return (wrap_fun2 <.> wrap_fun1, arg_ty1:arg_tys, res_ty) }+ where+ doc = text "When inferring the argument type of a function with type" <+>+ quotes (ppr 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+-- | matchActualFunTySigm does looks for just one function arrow+-- returning an uninstantiated sigma-type+matchActualFunTySigma :: 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)+ -> Maybe (HsExpr GhcRn) -- The thing with type TcSigmaType+ -> (Arity, [Scaled TcSigmaType]) -- Total number of value args in the call, and+ -- types of values args to which function has+ -- been applied already (reversed)+ -- Both are used only for error messages)+ -> TcSigmaType -- Type to analyse+ -> TcM (HsWrapper, Scaled 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++-- If (wrap, arg_ty, res_ty) = matchActualFunTySigma ... fun_ty+-- then wrap :: fun_ty ~> (arg_ty -> res_ty)+-- and NB: res_ty is an (uninstantiated) SigmaType++matchActualFunTySigma herald ct_orig mb_thing err_info fun_ty+ = go 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@@ -264,52 +296,28 @@ -- 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 :: TcSigmaType -- The remainder of the type as we're processing+ -> TcM (HsWrapper, Scaled TcSigmaType, TcSigmaType)+ go ty | Just ty' <- tcView ty = go ty' - go n so_far ty+ go 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) }+ ; (wrap2, arg_ty, res_ty) <- go rho+ ; return (wrap2 <.> wrap1, arg_ty, 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 })+ go (FunTy { ft_af = af, ft_mult = w, 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)+ return (idHsWrapper, Scaled w arg_ty, res_ty) - go n so_far ty@(TyVarTy tv)+ go ty@(TyVarTy tv) | isMetaTyVar tv = do { cts <- readMetaTyVar tv ; case cts of- Indirect ty' -> go n so_far ty'- Flexi -> defer n ty }+ Indirect ty' -> go ty'+ Flexi -> defer ty } -- In all other cases we bale out into ordinary unification -- However unlike the meta-tyvar case, we are sure that the@@ -326,22 +334,23 @@ -- -- 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)+ go ty = addErrCtxtM (mk_ctxt ty) (defer ty) ------------- defer n fun_ty- = do { arg_tys <- replicateM n newOpenFlexiTyVarTy- ; res_ty <- newOpenFlexiTyVarTy- ; let unif_fun_ty = mkVisFunTys arg_tys res_ty+ defer fun_ty+ = do { arg_ty <- newOpenFlexiTyVarTy+ ; res_ty <- newOpenFlexiTyVarTy+ ; let unif_fun_ty = mkVisFunTyMany arg_ty res_ty ; co <- unifyType mb_thing fun_ty unif_fun_ty- ; return (mkWpCastN co, arg_tys, res_ty) }+ ; return (mkWpCastN co, unrestricted arg_ty, res_ty) } ------------- mk_ctxt :: [TcType] -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc)- mk_ctxt arg_tys res_ty env+ mk_ctxt :: TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc)+ mk_ctxt res_ty env = do { (env', ty) <- zonkTidyTcType env $- mkVisFunTys (reverse arg_tys) res_ty+ mkVisFunTys (reverse arg_tys_so_far) res_ty ; return (env', mk_fun_tys_msg herald ty n_val_args_in_call) }+ (n_val_args_in_call, arg_tys_so_far) = err_info mk_fun_tys_msg :: SDoc -> TcType -> Arity -> SDoc mk_fun_tys_msg herald ty n_args_in_call@@ -398,7 +407,7 @@ -- Postcondition: (T k1 k2 k3 a b c) is well-kinded matchExpectedTyConApp tc orig_ty- = ASSERT(tc /= funTyCon) go orig_ty+ = ASSERT(not $ isFunTyCon tc) go orig_ty where go ty | Just ty' <- tcView ty@@ -468,7 +477,7 @@ ; return (co, (ty1, ty2)) } orig_kind = tcTypeKind orig_ty- kind1 = mkVisFunTy liftedTypeKind orig_kind+ kind1 = mkVisFunTyMany liftedTypeKind orig_kind kind2 = liftedTypeKind -- m :: * -> k -- arg type :: * @@ -491,95 +500,51 @@ actual ty is more polymorphic than expected_ty -It returns a coercion function+It returns a wrapper function co_fn :: actual_ty ~ expected_ty which takes an HsExpr of type actual_ty into one of type expected_ty.+-} -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.--}+-----------------+-- tcWrapResult needs both un-type-checked (for origins and error messages)+-- and type-checked (for wrapping) expressions+tcWrapResult :: HsExpr GhcRn -> HsExpr GhcTc -> TcSigmaType -> ExpRhoType+ -> TcM (HsExpr GhcTc)+tcWrapResult rn_expr = tcWrapResultO (exprCtOrigin rn_expr) rn_expr +tcWrapResultO :: CtOrigin -> HsExpr GhcRn -> HsExpr GhcTc -> TcSigmaType -> ExpRhoType+ -> TcM (HsExpr GhcTc)+tcWrapResultO orig rn_expr expr actual_ty res_ty+ = do { traceTc "tcWrapResult" (vcat [ text "Actual: " <+> ppr actual_ty+ , text "Expected:" <+> ppr res_ty ])+ ; wrap <- tcSubTypeNC orig GenSigCtxt (Just rn_expr) actual_ty res_ty+ ; return (mkHsWrap wrap expr) } --- | 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+tcWrapResultMono :: HsExpr GhcRn -> HsExpr GhcTc+ -> TcRhoType -- Actual -- a rho-type not a sigma-type+ -> ExpRhoType -- Expected+ -> TcM (HsExpr GhcTc)+-- A version of tcWrapResult to use when the actual type is a+-- rho-type, so nothing to instantiate; just go straight to unify.+-- It means we don't need to pass in a CtOrigin+tcWrapResultMono rn_expr expr act_ty res_ty+ = ASSERT2( isRhoTy act_ty, ppr act_ty $$ ppr rn_expr )+ do { co <- case res_ty of+ Infer inf_res -> fillInferResult act_ty inf_res+ Check exp_ty -> unifyType (Just rn_expr) act_ty exp_ty+ ; return (mkHsWrapCo co expr) } ------------------------ tcSubTypePat :: CtOrigin -> UserTypeCtxt -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper+-- Used in patterns; polarity is backwards compared+-- to tcSubType -- If wrap = tc_sub_type_et t1 t2 -- => wrap :: t1 ~> t2-tcSubTypePat 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 inst_orig ctxt (Check ty_actual) ty_expected+ = tc_sub_type unifyTypeET inst_orig ctxt ty_actual ty_expected tcSubTypePat _ _ (Infer inf_res) ty_expected = do { co <- fillInferResult ty_expected inf_res@@ -587,111 +552,77 @@ ; 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+---------------+tcSubType :: CtOrigin -> UserTypeCtxt+ -> TcSigmaType -- Actual+ -> ExpRhoType -- Expected+ -> TcM HsWrapper+-- Checks that 'actual' is more polymorphic than 'expected'+tcSubType orig ctxt ty_actual ty_expected = addSubTypeCtxt ty_actual ty_expected $- do { traceTc "tcSubTypeDS_O" (vcat [ pprCtOrigin orig- , pprUserTypeCtxt ctxt- , ppr ty_actual- , ppr ty_expected ])- ; tcSubTypeDS_NC_O orig ctxt Nothing ty_actual ty_expected }+ do { traceTc "tcSubType" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected])+ ; tcSubTypeNC 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) }+tcSubTypeNC :: CtOrigin -- Used when instantiating+ -> UserTypeCtxt -- Used when skolemising+ -> Maybe (HsExpr GhcRn) -- The expression that has type 'actual' (if known)+ -> TcSigmaType -- Actual type+ -> ExpRhoType -- Expected type+ -> TcM HsWrapper+tcSubTypeNC inst_orig ctxt m_thing ty_actual res_ty+ = case res_ty of+ Infer inf_res -> instantiateAndFillInferResult inst_orig ty_actual inf_res+ Check ty_expected -> tc_sub_type (unifyType m_thing) inst_orig ctxt+ ty_actual ty_expected ------------------ The "_NC" variants do not add a typechecker-error context;--- the caller is assumed to do that--tcSubType_NC :: UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper+tcSubTypeSigma :: UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper+-- External entry point, but no ExpTypes on either side -- 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 }+tcSubTypeSigma ctxt ty_actual ty_expected+ = tc_sub_type (unifyType Nothing) eq_orig 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 }+ eq_orig = TypeEqOrigin { uo_actual = ty_actual+ , uo_expected = ty_expected+ , uo_thing = Nothing+ , uo_visible = True } ----------------tc_sub_tc_type :: CtOrigin -- used when calling uType- -> CtOrigin -- used when instantiating- -> UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper+tc_sub_type :: (TcType -> TcType -> TcM TcCoercionN) -- How to unify+ -> CtOrigin -- Used when instantiating+ -> UserTypeCtxt -- Used when skolemising+ -> TcSigmaType -- Actual; a sigma-type+ -> TcSigmaType -- Expected; also a sigma-type+ -> TcM HsWrapper+-- Checks that actual_ty is more polymorphic than expected_ty -- If wrap = tc_sub_type t1 t2 -- => wrap :: t1 ~> t2-tc_sub_tc_type eq_orig inst_orig ctxt ty_actual ty_expected+tc_sub_type unify 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)" $+ = do { traceTc "tc_sub_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 }+ unify ty_actual ty_expected } | otherwise -- This is the general case- = do { traceTc "tc_sub_tc_type (general case)" $+ = do { traceTc "tc_sub_type (general case)" $ vcat [ text "ty_actual =" <+> ppr ty_actual , text "ty_expected =" <+> ppr ty_expected ]- ; (sk_wrap, inner_wrap) <- tcSkolemise ctxt ty_expected $- \ _ sk_rho ->- tc_sub_type_ds eq_orig inst_orig ctxt- ty_actual sk_rho++ ; (sk_wrap, inner_wrap)+ <- tcSkolemise ctxt ty_expected $ \ sk_rho ->+ do { (wrap, rho_a) <- topInstantiate inst_orig ty_actual+ ; cow <- unify rho_a sk_rho+ ; return (mkWpCastN cow <.> wrap) }+ ; return (sk_wrap <.> inner_wrap) } where possibly_poly ty | isForAllTy ty = True- | Just (_, res) <- splitFunTy_maybe ty = possibly_poly res+ | Just (_, _, res) <- splitFunTy_maybe ty = possibly_poly res | otherwise = False -- NB *not* tcSplitFunTy, because here we want -- to decompose type-class arguments too@@ -705,6 +636,31 @@ | otherwise = False +------------------------+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) }+ {- Note [Don't skolemise unnecessarily] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we are trying to solve@@ -740,98 +696,9 @@ 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]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Settting the argument context]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider we are doing the ambiguity check for the (bogus) f :: (forall a b. C b => a -> a) -> Int @@ -857,24 +724,49 @@ 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) }+-- Note [tcSubMult's wrapper]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~+-- There is no notion of multiplicity coercion in Core, therefore the wrapper+-- returned by tcSubMult (and derived function such as tcCheckUsage and+-- checkManyPattern) is quite unlike any other wrapper: it checks whether the+-- coercion produced by the constraint solver is trivial and disappears (it+-- produces a type error is the constraint is not trivial). See [Checking+-- multiplicity coercions] in TcEvidence.+--+-- This wrapper need to be placed in the term, otherwise checking of the+-- eventual coercion won't be triggered during desuraging. But it can be put+-- anywhere, since it doesn't affect the desugared code.+--+-- Why do we check this in the desugarer? It's a convenient place, since it's+-- right after all the constraints are solved. We need the constraints to be+-- solved to check whether they are trivial or not. Plus there are precedent for+-- type errors during desuraging (such as the levity polymorphism+-- restriction). An alternative would be to have a kind of constraints which can+-- only produce trivial evidence, then this check would happen in the constraint+-- solver.+tcSubMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper+tcSubMult origin w_actual w_expected+ | Just (w1, w2) <- isMultMul w_actual =+ do { w1 <- tcSubMult origin w1 w_expected+ ; w2 <- tcSubMult origin w2 w_expected+ ; return (w1 <.> w2) }+ -- Currently, we consider p*q and sup p q to be equal. Therefore, p*q <= r is+ -- equivalent to p <= r and q <= r. For other cases, we approximate p <= q by p+ -- ~ q. This is not complete, but it's sound. See also Note [Overapproximating+ -- multiplicities] in Multiplicity.+tcSubMult origin w_actual w_expected =+ case submult w_actual w_expected of+ Submult -> return WpHole+ Unknown -> tcEqMult origin w_actual w_expected +tcEqMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper+tcEqMult origin w_actual w_expected = do+ {+ -- Note that here we do not call to `submult`, so we check+ -- for strict equality.+ ; coercion <- uType TypeLevel origin w_actual w_expected+ ; return $ if isReflCo coercion then WpHole else WpMultCoercion coercion } {- ********************************************************************** %* *@@ -883,7 +775,7 @@ %********************************************************************* -} -- | Infer a type using a fresh ExpType--- See also Note [ExpType] in GHC.Tc.Utils.TcMType+-- See also Note [ExpType] in "GHC.Tc.Utils.TcMType" tcInfer :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType) tcInfer tc_check = do { res_ty <- newInferExpType@@ -896,7 +788,7 @@ -- => wrap :: t1 ~> t2 -- See Note [Instantiation of InferResult] instantiateAndFillInferResult orig ty inf_res- = do { (wrap, rho) <- deeplyInstantiate orig ty+ = do { (wrap, rho) <- topInstantiate orig ty ; co <- fillInferResult rho inf_res ; return (mkWpCastN co <.> wrap) } @@ -1090,48 +982,64 @@ * * ********************************************************************* -} --- | 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+{- Note [Skolemisation]+~~~~~~~~~~~~~~~~~~~~~~~+tcSkolemise takes "expected type" and strip off quantifiers to expose the+type underneath, binding the new skolems for the 'thing_inside'+The returned 'HsWrapper' has type (specific_ty -> expected_ty). -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+Note that for a nested type like+ forall a. Eq a => forall b. Ord b => blah+we still only build one implication constraint+ forall a b. (Eq a, Ord b) => <constraints>+This is just an optimisation, but it's why we use topSkolemise to+build the pieces from all the layers, before making a single call+to checkConstraints. - ; 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' ]+tcSkolemiseScoped is very similar, but differs in two ways: - -- 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+* It deals specially with just the outer forall, bringing those+ type variables into lexical scope. To my surprise, I found that+ doing this regardless (in tcSkolemise) caused a non-trivial (1%-ish)+ perf hit on the compiler. - ; let tvs' = map snd tv_prs+* It always calls checkConstraints, even if there are no skolem+ variables at all. Reason: there might be nested deferred errors+ that must not be allowed to float to top level.+ See Note [When to build an implication] below.+-}++tcSkolemise, tcSkolemiseScoped+ :: UserTypeCtxt -> TcSigmaType+ -> (TcType -> TcM result)+ -> TcM (HsWrapper, result)+ -- ^ The wrapper has type: spec_ty ~> expected_ty++tcSkolemiseScoped ctxt expected_ty thing_inside+ = do { (wrap, tv_prs, given, rho_ty) <- topSkolemise expected_ty+ ; let skol_tvs = map snd tv_prs+ skol_info = SigSkol ctxt expected_ty tv_prs++ ; (ev_binds, res)+ <- checkConstraints skol_info skol_tvs given $+ tcExtendNameTyVarEnv tv_prs $+ thing_inside rho_ty++ ; return (wrap <.> mkWpLet ev_binds, res) }++tcSkolemise ctxt expected_ty thing_inside+ | isRhoTy expected_ty -- Short cut for common case+ = do { res <- thing_inside expected_ty+ ; return (idHsWrapper, res) }+ | otherwise+ = do { (wrap, tv_prs, given, rho_ty) <- topSkolemise expected_ty++ ; let skol_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'+ ; (ev_binds, result)+ <- checkConstraints skol_info skol_tvs given $+ thing_inside rho_ty ; return (wrap <.> mkWpLet ev_binds, result) } -- The ev_binds returned by checkConstraints is very@@ -1144,7 +1052,8 @@ tcSkolemiseET _ et@(Infer {}) thing_inside = (idHsWrapper, ) <$> thing_inside et tcSkolemiseET ctxt (Check ty) thing_inside- = tcSkolemise ctxt ty $ \_ -> thing_inside . mkCheckExpType+ = tcSkolemise ctxt ty $ \rho_ty ->+ thing_inside (mkCheckExpType rho_ty) checkConstraints :: SkolemInfo -> [TcTyVar] -- Skolems@@ -1162,7 +1071,7 @@ ; emitImplications implics ; return (ev_binds, result) } - else -- Fast path. We check every function argument with tcCheckExpr,+ else -- Fast path. We check every function argument with tcCheckPolyExpr, -- which uses tcSkolemise and hence checkConstraints. -- So this fast path is well-exercised do { res <- thing_inside@@ -1175,38 +1084,33 @@ checkTvConstraints skol_info skol_tvs thing_inside = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside- ; emitResidualTvConstraint skol_info Nothing skol_tvs tclvl wanted+ ; emitResidualTvConstraint skol_info skol_tvs tclvl wanted ; return result } -emitResidualTvConstraint :: SkolemInfo -> Maybe SDoc -> [TcTyVar]+emitResidualTvConstraint :: SkolemInfo -> [TcTyVar] -> TcLevel -> WantedConstraints -> TcM ()-emitResidualTvConstraint skol_info m_telescope skol_tvs tclvl wanted+emitResidualTvConstraint skol_info 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+ = do { implic <- buildTvImplication skol_info skol_tvs tclvl wanted+ ; emitImplication implic }++buildTvImplication :: SkolemInfo -> [TcTyVar]+ -> TcLevel -> WantedConstraints -> TcM Implication+buildTvImplication skol_info skol_tvs tclvl wanted+ = do { ev_binds <- newNoTcEvBinds -- Used for equalities only, so all the constraints+ -- are solved by filling in coercion holes, not+ -- by creating a value-level evidence binding ; implic <- newImplication- ; let 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 } }+ ; return (implic { ic_tclvl = tclvl+ , ic_skols = skol_tvs+ , ic_no_eqs = True+ , ic_wanted = wanted+ , ic_binds = ev_binds+ , ic_info = skol_info }) } implicationNeeded :: SkolemInfo -> [TcTyVar] -> [EvVar] -> TcM Bool -- See Note [When to build an implication]@@ -1319,21 +1223,35 @@ -> 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+unifyType thing ty1 ty2+ = 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+ origin = TypeEqOrigin { uo_actual = ty1+ , uo_expected = ty2+ , uo_thing = ppr <$> thing+ , uo_visible = True } +unifyTypeET :: TcTauType -> TcTauType -> TcM CoercionN+-- Like unifyType, but swap expected and actual in error messages+-- This is used when typechecking patterns+unifyTypeET ty1 ty2+ = uType TypeLevel origin ty1 ty2+ where+ origin = TypeEqOrigin { uo_actual = ty2 -- NB swapped+ , uo_expected = ty1 -- NB swapped+ , uo_thing = Nothing+ , uo_visible = True }++ unifyKind :: Maybe (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+unifyKind thing ty1 ty2+ = uType KindLevel origin ty1 ty2+ where+ origin = TypeEqOrigin { uo_actual = ty1+ , uo_expected = ty2+ , uo_thing = ppr <$> thing+ , uo_visible = True } ---------------- {- %************************************************************************@@ -1435,10 +1353,11 @@ | Just ty2' <- tcView ty2 = go ty1 ty2' -- Functions (or predicate functions) just check the two parts- go (FunTy _ fun1 arg1) (FunTy _ fun2 arg2)+ go (FunTy _ w1 fun1 arg1) (FunTy _ w2 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 }+ ; co_w <- uType t_or_k origin w1 w2+ ; return $ mkFunCo Nominal co_w co_l co_r } -- Always defer if a type synonym family (type function) -- is involved. (Data families behave rigidly.)@@ -1639,7 +1558,7 @@ go tv2 | tv1 == tv2 -- Same type variable => no-op = return (mkNomReflCo (mkTyVarTy tv1)) - | swapOverTyVars tv1 tv2 -- Distinct type variables+ | swapOverTyVars False tv1 tv2 -- Distinct type variables -- Swap meta tyvar to the left if poss = do { tv1 <- zonkTyCoVarKind tv1 -- We must zonk tv1's kind because that might@@ -1696,8 +1615,12 @@ defer = unSwap swapped (uType_defer t_or_k origin) ty1 ty2 -swapOverTyVars :: TcTyVar -> TcTyVar -> Bool-swapOverTyVars tv1 tv2+swapOverTyVars :: Bool -> TcTyVar -> TcTyVar -> Bool+swapOverTyVars is_given tv1 tv2+ -- See Note [Unification variables on the left]+ | not is_given, pri1 == 0, pri2 > 0 = True+ | not is_given, pri2 == 0, pri1 > 0 = False+ -- Level comparison: see Note [TyVar/TyVar orientation] | lvl1 `strictlyDeeperThan` lvl2 = False | lvl2 `strictlyDeeperThan` lvl1 = True@@ -1786,6 +1709,24 @@ Uniques. See Note [Eliminate younger unification variables] (which also explains why we don't do this any more) +Note [Unification variables on the left]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For wanteds, but not givens, swap (skolem ~ meta-tv) regardless of+level, so that the unification variable is on the left.++* We /don't/ want this for Givens because if we ave+ [G] a[2] ~ alpha[1]+ [W] Bool ~ a[2]+ we want to rewrite the wanted to Bool ~ alpha[1],+ so we can float the constraint and solve it.++* But for Wanteds putting the unification variable on+ the left means an easier job when floating, and when+ reporting errors -- just fewer cases to consider.++ In particular, we get better skolem-escape messages:+ see #18114+ Note [Deeper level on the left] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The most important thing is that we want to put tyvars with@@ -2080,9 +2021,9 @@ Indirect fun_kind -> go n fun_kind Flexi -> defer n k } - go n (FunTy _ arg res)+ go n (FunTy _ w arg res) = do { co <- go (n-1) res- ; return (mkTcFunCo Nominal (mkTcNomReflCo arg) co) }+ ; return (mkTcFunCo Nominal (mkTcNomReflCo w) (mkTcNomReflCo arg) co) } go n other = defer n other@@ -2090,7 +2031,7 @@ defer n k = do { arg_kinds <- newMetaKindVars n ; res_kind <- newMetaKindVar- ; let new_fun = mkVisFunTys arg_kinds res_kind+ ; let new_fun = mkVisFunTysMany arg_kinds res_kind origin = TypeEqOrigin { uo_actual = k , uo_expected = new_fun , uo_thing = Just (ppr hs_ty)@@ -2154,7 +2095,7 @@ = MTVU_OK a | MTVU_Bad -- Forall, predicate, or type family | MTVU_HoleBlocker -- Blocking coercion hole- -- See Note [Equalities with incompatible kinds] in TcCanonical+ -- See Note [Equalities with incompatible kinds] in "GHC.Tc.Solver.Canonical" | MTVU_Occurs deriving (Functor) @@ -2200,7 +2141,7 @@ -- (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+-- See Note [Equalities with incompatible kinds] in "GHC.Tc.Solver.Canonical" -- -- We have two possible outcomes: -- (1) Return the type to update the type variable with,@@ -2261,10 +2202,10 @@ | 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})+ fast_check (FunTy{ft_af = af, ft_mult = w, ft_arg = a, ft_res = r}) | InvisArg <- af , not impredicative_ok = MTVU_Bad- | otherwise = fast_check a >> fast_check r+ | otherwise = fast_check w >> 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@@ -2286,7 +2227,7 @@ -- inferred fast_check_co co | not (gopt Opt_DeferTypeErrors dflags) , badCoercionHoleCo co = MTVU_HoleBlocker- -- Wrinkle (4b) in TcCanonical Note [Equalities with incompatible kinds]+ -- Wrinkle (4b) in "GHC.Tc.Solver.Canonical" Note [Equalities with incompatible kinds] | tv `elemVarSet` tyCoVarsOfCo co = MTVU_Occurs | otherwise = ok
compiler/GHC/Tc/Utils/Unify.hs-boot view
@@ -3,9 +3,10 @@ import GHC.Prelude import GHC.Tc.Utils.TcType ( TcTauType ) import GHC.Tc.Types ( TcM )-import GHC.Tc.Types.Evidence ( TcCoercion )+import GHC.Tc.Types.Evidence ( TcCoercion, HsWrapper )+import GHC.Tc.Types.Origin ( CtOrigin ) import GHC.Hs.Expr ( HsExpr )-import GHC.Hs.Type ( HsType )+import GHC.Hs.Type ( HsType, Mult ) import GHC.Hs.Extension ( GhcRn ) -- This boot file exists only to tie the knot between@@ -13,3 +14,5 @@ unifyType :: Maybe (HsExpr GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercion unifyKind :: Maybe (HsType GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercion++tcSubMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper
compiler/GHC/Tc/Utils/Zonk.hs view
@@ -29,14 +29,14 @@ -- * Zonking -- | For a description of "zonking", see Note [What is zonking?]- -- in GHC.Tc.Utils.TcMType+ -- in "GHC.Tc.Utils.TcMType" zonkTopDecls, zonkTopExpr, zonkTopLExpr, zonkTopBndrs, ZonkEnv, ZonkFlexi(..), emptyZonkEnv, mkEmptyZonkEnv, initZonkEnv, zonkTyVarBinders, zonkTyVarBindersX, zonkTyVarBinderX, zonkTyBndrs, zonkTyBndrsX, zonkTcTypeToType, zonkTcTypeToTypeX,- zonkTcTypesToTypes, zonkTcTypesToTypesX,+ zonkTcTypesToTypes, zonkTcTypesToTypesX, zonkScaledTcTypesToTypesX, zonkTyVarOcc, zonkCoToCo, zonkEvBinds, zonkTcEvBinds,@@ -80,6 +80,7 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Types.Unique.FM+import GHC.Core.Multiplicity import GHC.Core import {-# SOURCE #-} GHC.Tc.Gen.Splice (runTopSplice)@@ -143,7 +144,7 @@ -- Overloaded literals. Here mainly because it uses isIntTy etc -shortCutLit :: Platform -> OverLitVal -> TcType -> Maybe (HsExpr GhcTcId)+shortCutLit :: Platform -> OverLitVal -> TcType -> Maybe (HsExpr GhcTc) 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))@@ -202,7 +203,7 @@ -- 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.+-- 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@@ -372,11 +373,11 @@ -- to its final form. The TyVarEnv give zonkIdBndr :: ZonkEnv -> TcId -> TcM Id zonkIdBndr env v- = do ty' <- zonkTcTypeToTypeX env (idType v)+ = do Scaled w' ty' <- zonkScaledTcTypeToTypeX env (idScaledType v) ensureNotLevPoly ty' (text "In the type of binder" <+> quotes (ppr v)) - return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdType v ty'))+ return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdMult (setIdType v ty') w')) zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id] zonkIdBndrs env ids = mapM (zonkIdBndr env) ids@@ -384,7 +385,7 @@ zonkTopBndrs :: [TcId] -> TcM [Id] zonkTopBndrs ids = initZonkEnv $ \ ze -> zonkIdBndrs ze ids -zonkFieldOcc :: ZonkEnv -> FieldOcc GhcTcId -> TcM (FieldOcc GhcTc)+zonkFieldOcc :: ZonkEnv -> FieldOcc GhcTc -> TcM (FieldOcc GhcTc) zonkFieldOcc env (FieldOcc sel lbl) = fmap ((flip FieldOcc) lbl) $ zonkIdBndr env sel @@ -401,11 +402,7 @@ -- 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) }+ = updateIdTypeAndMultM ({-# SCC "zonkEvBndr_zonkTcTypeToType" #-} zonkTcTypeToTypeX env) var {- zonkEvVarOcc :: ZonkEnv -> EvVar -> TcM EvTerm@@ -460,16 +457,16 @@ = do { (env', tv') <- zonkTyBndrX env tv ; return (env', Bndr tv' vis) } -zonkTopExpr :: HsExpr GhcTcId -> TcM (HsExpr GhcTc)+zonkTopExpr :: HsExpr GhcTc -> TcM (HsExpr GhcTc) zonkTopExpr e = initZonkEnv $ \ ze -> zonkExpr ze e -zonkTopLExpr :: LHsExpr GhcTcId -> TcM (LHsExpr GhcTc)+zonkTopLExpr :: LHsExpr GhcTc -> TcM (LHsExpr GhcTc) zonkTopLExpr e = initZonkEnv $ \ ze -> zonkLExpr ze e zonkTopDecls :: Bag EvBind- -> LHsBinds GhcTcId- -> [LRuleDecl GhcTcId] -> [LTcSpecPrag]- -> [LForeignDecl GhcTcId]+ -> LHsBinds GhcTc+ -> [LRuleDecl GhcTc] -> [LTcSpecPrag]+ -> [LForeignDecl GhcTc] -> TcM (TypeEnv, Bag EvBind, LHsBinds GhcTc,@@ -486,7 +483,7 @@ ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules') } ----------------------------------------------zonkLocalBinds :: ZonkEnv -> HsLocalBinds GhcTcId+zonkLocalBinds :: ZonkEnv -> HsLocalBinds GhcTc -> TcM (ZonkEnv, HsLocalBinds GhcTc) zonkLocalBinds env (EmptyLocalBinds x) = return (env, (EmptyLocalBinds x))@@ -519,7 +516,7 @@ return (IPBind x n' e') ----------------------------------------------zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (ZonkEnv, LHsBinds GhcTc)+zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTc -> TcM (ZonkEnv, LHsBinds GhcTc) zonkRecMonoBinds env binds = fixM (\ ~(_, new_binds) -> do { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders new_binds)@@ -527,13 +524,13 @@ ; return (env1, binds') }) ----------------------------------------------zonkMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (LHsBinds GhcTc)+zonkMonoBinds :: ZonkEnv -> LHsBinds GhcTc -> TcM (LHsBinds GhcTc) zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds -zonk_lbind :: ZonkEnv -> LHsBind GhcTcId -> TcM (LHsBind GhcTc)+zonk_lbind :: ZonkEnv -> LHsBind GhcTc -> TcM (LHsBind GhcTc) zonk_lbind env = wrapLocM (zonk_bind env) -zonk_bind :: ZonkEnv -> HsBind GhcTcId -> TcM (HsBind GhcTc)+zonk_bind :: ZonkEnv -> HsBind GhcTc -> 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@@ -583,10 +580,10 @@ where zonk_val_bind env lbind | has_sig- , (L loc bind@(FunBind { fun_id = L mloc mono_id+ , (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+ = do { new_mono_id <- updateIdTypeAndMultM (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@@ -598,7 +595,7 @@ | otherwise = zonk_lbind env lbind -- The normal case - zonk_export :: ZonkEnv -> ABExport GhcTcId -> TcM (ABExport GhcTc)+ zonk_export :: ZonkEnv -> ABExport GhcTc -> TcM (ABExport GhcTc) zonk_export env (ABE{ abe_ext = x , abe_wrap = wrap , abe_poly = poly_id@@ -637,7 +634,7 @@ zonkPatSynDetails env (RecCon flds) = RecCon (map (fmap (zonkLIdOcc env)) flds) -zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTcId+zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTc -> TcM (ZonkEnv, HsPatSynDir GhcTc) zonkPatSynDir env Unidirectional = return (env, Unidirectional) zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional)@@ -667,22 +664,22 @@ -} zonkMatchGroup :: ZonkEnv- -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))- -> MatchGroup GhcTcId (Located (body GhcTcId))+ -> (ZonkEnv -> Located (body GhcTc) -> TcM (Located (body GhcTc)))+ -> MatchGroup GhcTc (Located (body GhcTc)) -> 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+ ; arg_tys' <- zonkScaledTcTypesToTypesX env arg_tys ; res_ty' <- zonkTcTypeToTypeX env res_ty ; return (MG { mg_alts = L l ms' , mg_ext = MatchGroupTc arg_tys' res_ty' , mg_origin = origin }) } zonkMatch :: ZonkEnv- -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))- -> LMatch GhcTcId (Located (body GhcTcId))+ -> (ZonkEnv -> Located (body GhcTc) -> TcM (Located (body GhcTc)))+ -> LMatch GhcTc (Located (body GhcTc)) -> TcM (LMatch GhcTc (Located (body GhcTc))) zonkMatch env zBody (L loc match@(Match { m_pats = pats , m_grhss = grhss }))@@ -692,8 +689,8 @@ ------------------------------------------------------------------------- zonkGRHSs :: ZonkEnv- -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))- -> GRHSs GhcTcId (Located (body GhcTcId))+ -> (ZonkEnv -> Located (body GhcTc) -> TcM (Located (body GhcTc)))+ -> GRHSs GhcTc (Located (body GhcTc)) -> TcM (GRHSs GhcTc (Located (body GhcTc))) zonkGRHSs env zBody (GRHSs x grhss (L l binds)) = do@@ -714,9 +711,9 @@ ************************************************************************ -} -zonkLExprs :: ZonkEnv -> [LHsExpr GhcTcId] -> TcM [LHsExpr GhcTc]-zonkLExpr :: ZonkEnv -> LHsExpr GhcTcId -> TcM (LHsExpr GhcTc)-zonkExpr :: ZonkEnv -> HsExpr GhcTcId -> TcM (HsExpr GhcTc)+zonkLExprs :: ZonkEnv -> [LHsExpr GhcTc] -> TcM [LHsExpr GhcTc]+zonkLExpr :: ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)+zonkExpr :: ZonkEnv -> HsExpr GhcTc -> TcM (HsExpr GhcTc) zonkLExprs env exprs = mapM (zonkLExpr env) exprs zonkLExpr env expr = wrapLocM (zonkExpr env) expr@@ -814,7 +811,7 @@ 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+ zonk_tup_arg (L l (Missing t)) = do { t' <- zonkScaledTcTypeToTypeX env t ; return (L l (Missing t')) } @@ -942,7 +939,7 @@ -} -- See Note [Skolems in zonkSyntaxExpr]-zonkSyntaxExpr :: ZonkEnv -> SyntaxExpr GhcTcId+zonkSyntaxExpr :: ZonkEnv -> SyntaxExpr GhcTc -> TcM (ZonkEnv, SyntaxExpr GhcTc) zonkSyntaxExpr env (SyntaxExprTc { syn_expr = expr , syn_arg_wraps = arg_wraps@@ -957,8 +954,8 @@ ------------------------------------------------------------------------- -zonkLCmd :: ZonkEnv -> LHsCmd GhcTcId -> TcM (LHsCmd GhcTc)-zonkCmd :: ZonkEnv -> HsCmd GhcTcId -> TcM (HsCmd GhcTc)+zonkLCmd :: ZonkEnv -> LHsCmd GhcTc -> TcM (LHsCmd GhcTc)+zonkCmd :: ZonkEnv -> HsCmd GhcTc -> TcM (HsCmd GhcTc) zonkLCmd env cmd = wrapLocM (zonkCmd env) cmd @@ -1018,10 +1015,10 @@ -zonkCmdTop :: ZonkEnv -> LHsCmdTop GhcTcId -> TcM (LHsCmdTop GhcTc)+zonkCmdTop :: ZonkEnv -> LHsCmdTop GhcTc -> TcM (LHsCmdTop GhcTc) zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd -zonk_cmd_top :: ZonkEnv -> HsCmdTop GhcTcId -> TcM (HsCmdTop GhcTc)+zonk_cmd_top :: ZonkEnv -> HsCmdTop GhcTc -> TcM (HsCmdTop GhcTc) zonk_cmd_top env (HsCmdTop (CmdTopTc stack_tys ty ids) cmd) = do new_cmd <- zonkLCmd env cmd new_stack_tys <- zonkTcTypeToTypeX env stack_tys@@ -1043,7 +1040,7 @@ ; 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+ ; t1' <- zonkScaledTcTypeToTypeX env2 t1 ; return (env2, WpFun c1' c2' t1' d) } zonkCoFn env (WpCast co) = do { co' <- zonkCoToCo env co ; return (env, WpCast co') }@@ -1058,16 +1055,18 @@ ; return (env, WpTyApp ty') } zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs ; return (env1, WpLet bs') }+zonkCoFn env (WpMultCoercion co) = do { co' <- zonkCoToCo env co+ ; return (env, WpMultCoercion co') } --------------------------------------------------------------------------zonkOverLit :: ZonkEnv -> HsOverLit GhcTcId -> TcM (HsOverLit GhcTc)+zonkOverLit :: ZonkEnv -> HsOverLit GhcTc -> 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 :: ZonkEnv -> ArithSeqInfo GhcTc -> TcM (ArithSeqInfo GhcTc) zonkArithSeq env (From e) = do new_e <- zonkLExpr env e@@ -1092,8 +1091,8 @@ ------------------------------------------------------------------------- zonkStmts :: ZonkEnv- -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))- -> [LStmt GhcTcId (Located (body GhcTcId))]+ -> (ZonkEnv -> Located (body GhcTc) -> TcM (Located (body GhcTc)))+ -> [LStmt GhcTc (Located (body GhcTc))] -> TcM (ZonkEnv, [LStmt GhcTc (Located (body GhcTc))]) zonkStmts env _ [] = return (env, []) zonkStmts env zBody (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env zBody) s@@ -1101,8 +1100,8 @@ ; return (env2, s' : ss') } zonkStmt :: ZonkEnv- -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))- -> Stmt GhcTcId (Located (body GhcTcId))+ -> (ZonkEnv -> Located (body GhcTc) -> TcM (Located (body GhcTc)))+ -> Stmt GhcTc (Located (body GhcTc)) -> 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@@ -1115,7 +1114,7 @@ ; return (env2 , ParStmt new_bind_ty new_stmts_w_bndrs new_mzip new_bind_op)} where- zonk_branch :: ZonkEnv -> ParStmtBlock GhcTcId GhcTcId+ zonk_branch :: ZonkEnv -> ParStmtBlock GhcTc GhcTc -> TcM (ParStmtBlock GhcTc GhcTc) zonk_branch env1 (ParStmtBlock x stmts bndrs return_op) = do { (env2, new_stmts) <- zonkStmts env1 zonkLExpr stmts@@ -1199,6 +1198,7 @@ zonkStmt env zBody (BindStmt xbs pat body) = do { (env1, new_bind) <- zonkSyntaxExpr env (xbstc_bindOp xbs)+ ; new_w <- zonkTcTypeToTypeX env1 (xbstc_boundResultMult xbs) ; new_bind_ty <- zonkTcTypeToTypeX env1 (xbstc_boundResultType xbs) ; new_body <- zBody env1 body ; (env2, new_pat) <- zonkPat env1 pat@@ -1209,6 +1209,7 @@ , BindStmt (XBindStmtTc { xbstc_bindOp = new_bind , xbstc_boundResultType = new_bind_ty+ , xbstc_boundResultMult = new_w , xbstc_failOp = new_fail }) new_pat new_body) }@@ -1225,17 +1226,17 @@ 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 :: (SyntaxExpr GhcTc, ApplicativeArg GhcTc) -> LPat GhcTc get_pat (_, ApplicativeArgOne _ pat _ _) = pat- get_pat (_, ApplicativeArgMany _ _ _ pat) = pat+ get_pat (_, ApplicativeArgMany _ _ _ pat _) = pat - replace_pat :: LPat GhcTcId+ replace_pat :: LPat GhcTc -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc) replace_pat pat (op, ApplicativeArgOne fail_op _ a isBody) = (op, ApplicativeArgOne fail_op pat a isBody)- replace_pat pat (op, ApplicativeArgMany x a b _)- = (op, ApplicativeArgMany x a b pat)+ replace_pat pat (op, ApplicativeArgMany x a b _ c)+ = (op, ApplicativeArgMany x a b pat c) zonk_args env args = do { (env1, new_args_rev) <- zonk_args_rev env (reverse args)@@ -1260,13 +1261,13 @@ ; return fail' } ; return (ApplicativeArgOne new_fail pat new_expr isBody) }- zonk_arg env (ApplicativeArgMany x stmts ret pat)+ zonk_arg env (ApplicativeArgMany x stmts ret pat ctxt) = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts ; new_ret <- zonkExpr env1 ret- ; return (ApplicativeArgMany x new_stmts new_ret pat) }+ ; return (ApplicativeArgMany x new_stmts new_ret pat ctxt) } --------------------------------------------------------------------------zonkRecFields :: ZonkEnv -> HsRecordBinds GhcTcId -> TcM (HsRecordBinds GhcTcId)+zonkRecFields :: ZonkEnv -> HsRecordBinds GhcTc -> TcM (HsRecordBinds GhcTc) zonkRecFields env (HsRecFields flds dd) = do { flds' <- mapM zonk_rbind flds ; return (HsRecFields flds' dd) }@@ -1277,8 +1278,8 @@ ; return (L l (fld { hsRecFieldLbl = new_id , hsRecFieldArg = new_expr })) } -zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField GhcTcId]- -> TcM [LHsRecUpdField GhcTcId]+zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField GhcTc]+ -> TcM [LHsRecUpdField GhcTc] zonkRecUpdFields env = mapM zonk_rbind where zonk_rbind (L l fld)@@ -1308,7 +1309,7 @@ -- to the right) zonkPat env pat = wrapLocSndM (zonk_pat env) pat -zonk_pat :: ZonkEnv -> Pat GhcTcId -> TcM (ZonkEnv, Pat GhcTc)+zonk_pat :: ZonkEnv -> Pat GhcTc -> TcM (ZonkEnv, Pat GhcTc) zonk_pat env (ParPat x p) = do { (env', p') <- zonkPat env p ; return (env', ParPat x p') }@@ -1482,11 +1483,11 @@ ************************************************************************ -} -zonkForeignExports :: ZonkEnv -> [LForeignDecl GhcTcId]+zonkForeignExports :: ZonkEnv -> [LForeignDecl GhcTc] -> TcM [LForeignDecl GhcTc] zonkForeignExports env ls = mapM (wrapLocM (zonkForeignExport env)) ls -zonkForeignExport :: ZonkEnv -> ForeignDecl GhcTcId -> TcM (ForeignDecl GhcTc)+zonkForeignExport :: ZonkEnv -> ForeignDecl GhcTc -> TcM (ForeignDecl GhcTc) zonkForeignExport env (ForeignExport { fd_name = i, fd_e_ext = co , fd_fe = spec }) = return (ForeignExport { fd_name = zonkLIdOcc env i@@ -1495,10 +1496,10 @@ zonkForeignExport _ for_imp = return for_imp -- Foreign imports don't need zonking -zonkRules :: ZonkEnv -> [LRuleDecl GhcTcId] -> TcM [LRuleDecl GhcTc]+zonkRules :: ZonkEnv -> [LRuleDecl GhcTc] -> TcM [LRuleDecl GhcTc] zonkRules env rs = mapM (wrapLocM (zonkRule env)) rs -zonkRule :: ZonkEnv -> RuleDecl GhcTcId -> TcM (RuleDecl GhcTc)+zonkRule :: ZonkEnv -> RuleDecl GhcTc -> TcM (RuleDecl GhcTc) zonkRule env rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-} , rd_lhs = lhs , rd_rhs = rhs })@@ -1514,7 +1515,7 @@ , rd_lhs = new_lhs , rd_rhs = new_rhs } } where- zonk_tm_bndr :: ZonkEnv -> LRuleBndr GhcTcId -> TcM (ZonkEnv, LRuleBndr GhcTcId)+ zonk_tm_bndr :: ZonkEnv -> LRuleBndr GhcTc -> TcM (ZonkEnv, LRuleBndr GhcTc) zonk_tm_bndr env (L l (RuleBndr x (L loc v))) = do { (env', v') <- zonk_it env v ; return (env', L l (RuleBndr x (L loc v'))) }@@ -1617,10 +1618,11 @@ = do { t1' <- zonkEvTerm env t1 ; t2' <- zonkEvTerm env t2 ; return (EvTypeableTyApp t1' t2') }-zonkEvTypeable env (EvTypeableTrFun t1 t2)- = do { t1' <- zonkEvTerm env t1+zonkEvTypeable env (EvTypeableTrFun tm t1 t2)+ = do { tm' <- zonkEvTerm env tm+ ; t1' <- zonkEvTerm env t1 ; t2' <- zonkEvTerm env t2- ; return (EvTypeableTrFun t1' t2') }+ ; return (EvTypeableTrFun tm' t1' t2') } zonkEvTypeable env (EvTypeableTyLit t1) = do { t1' <- zonkEvTerm env t1 ; return (EvTypeableTyLit t1') }@@ -1805,6 +1807,9 @@ | isRuntimeRepTy zonked_kind -> do { traceTc "Defaulting flexi tyvar to LiftedRep:" (pprTyVar tv) ; return liftedRepTy }+ | isMultiplicityTy zonked_kind+ -> do { traceTc "Defaulting flexi tyvar to Many:" (pprTyVar tv)+ ; return manyDataConTy } | otherwise -> do { traceTc "Defaulting flexi tyvar to Any:" (pprTyVar tv) ; return (anyTypeOfKind zonked_kind) }@@ -1871,11 +1876,19 @@ zonkTcTypesToTypes :: [TcType] -> TcM [Type] zonkTcTypesToTypes tys = initZonkEnv $ \ ze -> zonkTcTypesToTypesX ze tys +zonkScaledTcTypeToTypeX :: ZonkEnv -> Scaled TcType -> TcM (Scaled TcType)+zonkScaledTcTypeToTypeX env (Scaled m ty) = Scaled <$> zonkTcTypeToTypeX env m+ <*> zonkTcTypeToTypeX env ty+ zonkTcTypeToTypeX :: ZonkEnv -> TcType -> TcM Type zonkTcTypesToTypesX :: ZonkEnv -> [TcType] -> TcM [Type] zonkCoToCo :: ZonkEnv -> Coercion -> TcM Coercion (zonkTcTypeToTypeX, zonkTcTypesToTypesX, zonkCoToCo, _) = mapTyCoX zonk_tycomapper++zonkScaledTcTypesToTypesX :: ZonkEnv -> [Scaled TcType] -> TcM [Scaled Type]+zonkScaledTcTypesToTypesX env scaled_tys =+ mapM (zonkScaledTcTypeToTypeX env) scaled_tys zonkTcMethInfoToMethInfoX :: ZonkEnv -> TcMethInfo -> TcM MethInfo zonkTcMethInfoToMethInfoX ze (name, ty, gdm_spec)
compiler/GHC/Tc/Validity.hs view
@@ -27,14 +27,14 @@ import GHC.Data.Maybe -- friends:-import GHC.Tc.Utils.Unify ( tcSubType_NC )+import GHC.Tc.Utils.Unify ( tcSubTypeSigma ) 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.Types ( heqTyConName, eqTyConName, coercibleTyConName, manyDataConTy ) import GHC.Builtin.Names import GHC.Core.Type import GHC.Core.Unify ( tcMatchTyX_BM, BindFlag(..) )@@ -122,7 +122,7 @@ 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.+the originals, so in the case of 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.@@ -216,7 +216,7 @@ ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes ; (_wrap, wanted) <- addErrCtxt (mk_msg allow_ambiguous) $ captureConstraints $- tcSubType_NC ctxt ty ty+ tcSubTypeSigma ctxt ty ty ; simplifyAmbiguityCheck ty wanted ; traceTc "Done ambiguity check for" (ppr ty) }@@ -711,7 +711,7 @@ (theta, tau) = tcSplitPhiTy phi (env', tvbs') = tidyTyCoVarBinders env tvbs -check_type (ve@ValidityEnv{ve_rank = rank}) (FunTy _ arg_ty res_ty)+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@@ -1635,17 +1635,24 @@ tcInstHeadTyNotSynonym ty = case ty of -- Do not use splitTyConApp, -- because that expands synonyms!- TyConApp tc _ -> not (isTypeSynonymTyCon tc)+ TyConApp tc _ -> not (isTypeSynonymTyCon tc) || tc == unrestrictedFunTyCon+ -- Allow (->), e.g. instance Category (->),+ -- even though it's a type synonym for FUN 'Many _ -> 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.+-- But we allow+-- 1) kind instantiations+-- 2) the type (->) = FUN 'Many, even though it's not in this form. tcInstHeadTyAppAllTyVars ty | Just (tc, tys) <- tcSplitTyConApp_maybe (dropCasts ty)- = ok (filterOutInvisibleTypes tc tys) -- avoid kinds+ = let tys' = filterOutInvisibleTypes tc tys -- avoid kinds+ tys'' | tc == funTyCon, tys_h:tys_t <- tys', tys_h `eqType` manyDataConTy = tys_t+ | otherwise = tys'+ in ok tys'' | LitTy _ <- ty = True -- accept type literals (#13833) | otherwise = False@@ -1663,7 +1670,7 @@ -- 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 ty@(FunTy _ w t1 t2) = ty { ft_mult = dropCasts w, 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@@ -2831,7 +2838,7 @@ fvType (TyConApp _ tys) = fvTypes tys fvType (LitTy {}) = [] fvType (AppTy fun arg) = fvType fun ++ fvType arg-fvType (FunTy _ arg res) = fvType arg ++ fvType res+fvType (FunTy _ w arg res) = fvType w ++ fvType arg ++ fvType res fvType (ForAllTy (Bndr tv _) ty) = fvType (tyVarKind tv) ++ filter (/= tv) (fvType ty)@@ -2848,7 +2855,7 @@ 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 (FunTy _ w arg res) = sizeType w + sizeType arg + sizeType res + 1 sizeType (ForAllTy _ ty) = sizeType ty sizeType (CastTy ty _) = sizeType ty sizeType (CoercionTy _) = 0
compiler/GHC/ThToHs.hs view
@@ -50,7 +50,6 @@ 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 )@@ -571,7 +570,7 @@ cvtConstr (NormalC c strtys) = do { c' <- cNameL c ; tys' <- mapM cvt_arg strtys- ; returnL $ mkConDeclH98 c' Nothing Nothing (PrefixCon tys') }+ ; returnL $ mkConDeclH98 c' Nothing Nothing (PrefixCon (map hsLinear tys')) } cvtConstr (RecC c varstrtys) = do { c' <- cNameL c@@ -583,7 +582,8 @@ = do { c' <- cNameL c ; st1' <- cvt_arg st1 ; st2' <- cvt_arg st2- ; returnL $ mkConDeclH98 c' Nothing Nothing (InfixCon st1' st2') }+ ; returnL $ mkConDeclH98 c' Nothing Nothing (InfixCon (hsLinear st1')+ (hsLinear st2')) } cvtConstr (ForallC tvs ctxt con) = do { tvs' <- cvtTvs tvs@@ -595,6 +595,8 @@ add_cxt (L loc cxt1) (Just (L _ cxt2)) = Just (L loc (cxt1 ++ cxt2)) + add_forall :: [LHsTyVarBndr Hs.Specificity GhcPs] -> LHsContext GhcPs+ -> ConDecl GhcPs -> ConDecl GhcPs add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt }) = con { con_forall = noLoc $ not (null all_tvs) , con_qvars = all_tvs@@ -609,7 +611,13 @@ where all_tvs = tvs' ++ ex_tvs - add_forall _ _ (XConDecl nec) = noExtCon nec+ -- The GadtC and RecGadtC cases of cvtConstr will always return a+ -- ConDeclGADT, not a ConDeclGADTPrefixPs, so this case is unreachable.+ -- See Note [GADT abstract syntax] in GHC.Hs.Decls for more on the+ -- distinction between ConDeclGADT and ConDeclGADTPrefixPs.+ add_forall _ _ con@(XConDecl (ConDeclGADTPrefixPs {})) =+ pprPanic "cvtConstr.add_forall: Unexpected ConDeclGADTPrefixPs"+ (Outputable.ppr con) cvtConstr (GadtC [] _strtys _ty) = failWith (text "GadtC must have at least one constructor name")@@ -617,9 +625,8 @@ cvtConstr (GadtC c strtys ty) = do { c' <- mapM cNameL c ; args <- mapM cvt_arg strtys- ; L _ ty' <- cvtType ty- ; c_ty <- mk_arr_apps args ty'- ; returnL $ fst $ mkGadtDecl c' c_ty}+ ; ty' <- cvtType ty+ ; returnL $ mk_gadt_decl c' (PrefixCon $ map hsLinear args) ty'} cvtConstr (RecGadtC [] _varstrtys _ty) = failWith (text "RecGadtC must have at least one constructor name")@@ -628,10 +635,20 @@ = do { c' <- mapM cNameL c ; ty' <- cvtType ty ; rec_flds <- mapM cvt_id_arg varstrtys- ; let rec_ty = noLoc (HsFunTy noExtField- (noLoc $ HsRecTy noExtField rec_flds) ty')- ; returnL $ fst $ mkGadtDecl c' rec_ty }+ ; returnL $ mk_gadt_decl c' (RecCon $ noLoc rec_flds) ty' } +mk_gadt_decl :: [Located RdrName] -> HsConDeclDetails GhcPs -> LHsType GhcPs+ -> ConDecl GhcPs+mk_gadt_decl names args res_ty+ = ConDeclGADT { con_g_ext = noExtField+ , con_names = names+ , con_forall = noLoc False+ , con_qvars = []+ , con_mb_cxt = Nothing+ , con_args = args+ , con_res_ty = res_ty+ , con_doc = Nothing }+ cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack cvtSrcUnpackedness SourceNoUnpack = SrcNoUnpack@@ -939,8 +956,8 @@ ; th_origin <- getOrigin ; return $ HsCase noExtField e' (mkMatchGroup th_origin ms') }- cvt (DoE ss) = cvtHsDo DoExpr ss- cvt (MDoE ss) = cvtHsDo MDoExpr ss+ cvt (DoE m ss) = cvtHsDo (DoExpr (mk_mod <$> m)) ss+ cvt (MDoE m ss) = cvtHsDo (MDoExpr (mk_mod <$> m)) ss cvt (CompE ss) = cvtHsDo ListComp ss cvt (ArithSeqE dd) = do { dd' <- cvtDD dd ; return $ ArithSeq noExtField Nothing dd' }@@ -1243,7 +1260,7 @@ cvtLit _ = panic "Convert.cvtLit: Unexpected literal" -- cvtLit should not be called on IntegerL, RationalL -- That precondition is established right here in- -- Convert.hs, hence panic+ -- "GHC.ThToHs", hence panic quotedSourceText :: String -> SourceText quotedSourceText s = SourceText $ "\"" ++ s ++ "\""@@ -1448,9 +1465,25 @@ _ -> return $ parenthesizeHsType sigPrec x' let y'' = parenthesizeHsType sigPrec y'- returnL (HsFunTy noExtField x'' y'')+ returnL (HsFunTy noExtField HsUnrestrictedArrow x'' y'') | otherwise -> mk_apps+ (HsTyVar noExtField NotPromoted (noLoc (getRdrName unrestrictedFunTyCon)))+ tys'+ MulArrowT+ | Just normals <- m_normals+ , [w',x',y'] <- normals -> do+ x'' <- case unLoc x' of+ HsFunTy{} -> returnL (HsParTy noExtField x')+ HsForAllTy{} -> returnL (HsParTy noExtField x') -- #14646+ HsQualTy{} -> returnL (HsParTy noExtField x') -- #15324+ _ -> return $+ parenthesizeHsType sigPrec x'+ let y'' = parenthesizeHsType sigPrec y'+ w'' = hsTypeToArrow w'+ returnL (HsFunTy noExtField w'' x'' y'')+ | otherwise+ -> mk_apps (HsTyVar noExtField NotPromoted (noLoc (getRdrName funTyCon))) tys' ListT@@ -1474,19 +1507,19 @@ ; cxt' <- cvtContext funPrec cxt ; ty' <- cvtType ty ; loc <- getL- ; let hs_ty = mkHsForAllTy loc ForallInvis tvs' rho_ty+ ; let tele = mkHsForAllInvisTele tvs'+ hs_ty = mkHsForAllTy loc tele rho_ty rho_ty = mkHsQualTy cxt loc cxt' ty' ; return hs_ty } ForallVisT tvs ty | null tys'- -> do { let tvs_spec = map (TH.SpecifiedSpec <$) tvs- -- see Note [Specificity in HsForAllTy] in GHC.Hs.Type- ; tvs_spec' <- cvtTvs tvs_spec- ; ty' <- cvtType ty- ; loc <- getL- ; pure $ mkHsForAllTy loc ForallVis tvs_spec' ty' }+ -> do { tvs' <- cvtTvs tvs+ ; ty' <- cvtType ty+ ; loc <- getL+ ; let tele = mkHsForAllVisTele tvs'+ ; pure $ mkHsForAllTy loc tele ty' } SigT ty ki -> do { ty' <- cvtType ty@@ -1581,6 +1614,13 @@ _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty)) } +hsTypeToArrow :: LHsType GhcPs -> HsArrow GhcPs+hsTypeToArrow w = case unLoc w of+ HsTyVar _ _ (L _ (isExact_maybe -> Just n))+ | n == oneDataConName -> HsLinearArrow+ | n == manyDataConName -> HsUnrestrictedArrow+ _ -> HsExplicitMult w+ -- ConT/InfixT can contain both data constructor (i.e., promoted) names and -- other (i.e, unpromoted) names, as opposed to PromotedT, which can only -- contain data constructor names. See #15572/#17394. We use this function to@@ -1641,19 +1681,12 @@ In order to pretty-print this hsSyn AST, parens need to be adde back at certain points so that the code is readable with its original meaning. -So scattered through Convert.hs are various points where parens are added.+So scattered through "GHC.ThToHs" are various points where parens are added. See (among other closed issued) https://gitlab.haskell.org/ghc/ghc/issues/14289 -} -- --------------------------------------------------------------------- --- | Constructs an arrow type with a specified return type-mk_arr_apps :: [LHsType GhcPs] -> HsType GhcPs -> CvtM (LHsType GhcPs)-mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL- where go :: LHsType GhcPs -> HsType GhcPs -> CvtM (HsType GhcPs)- go arg ret_ty = do { ret_ty_l <- returnL ret_ty- ; return (HsFunTy noExtField arg ret_ty_l) }- split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsTypeArg GhcPs]) split_ty_app ty = go ty [] where@@ -1726,8 +1759,7 @@ ; univs' <- cvtTvs univs ; ty' <- cvtType (ForallT exis provs ty) ; let forTy = HsForAllTy- { hst_fvf = ForallInvis- , hst_bndrs = univs'+ { hst_tele = mkHsForAllInvisTele univs' , hst_xforall = noExtField , hst_body = L l cxtTy } cxtTy = HsQualTy { hst_ctxt = L l []@@ -1779,21 +1811,21 @@ mkHsForAllTy :: SrcSpan -- ^ The location of the returned 'LHsType' if it needs an -- explicit forall- -> ForallVisFlag- -- ^ Whether this is @forall@ is visible (e.g., @forall a ->@)- -- or invisible (e.g., @forall a.@)- -> [LHsTyVarBndr Hs.Specificity GhcPs]+ -> HsForAllTelescope GhcPs -- ^ The converted type variable binders -> LHsType GhcPs -- ^ The converted rho type -> LHsType GhcPs -- ^ The complete type, quantified with a forall if necessary-mkHsForAllTy loc fvf tvs rho_ty- | null tvs = rho_ty- | otherwise = L loc $ HsForAllTy { hst_fvf = fvf- , hst_bndrs = tvs+mkHsForAllTy loc tele rho_ty+ | no_tvs = rho_ty+ | otherwise = L loc $ HsForAllTy { hst_tele = tele , hst_xforall = noExtField , hst_body = rho_ty }+ where+ no_tvs = case tele of+ HsForAllVis { hsf_vis_bndrs = bndrs } -> null bndrs+ HsForAllInvis { hsf_invis_bndrs = bndrs } -> null bndrs -- | If passed an empty 'TH.Cxt', this simply returns the third argument -- (an 'LHsType'). Otherwise, return an 'HsQualTy' using the provided
compiler/GHC/Utils/Asm.hs view
@@ -1,7 +1,7 @@ -- | Various utilities used in generating assembler. -- -- These are used not only by the native code generator, but also by the--- GHC.Driver.Pipeline+-- "GHC.Driver.Pipeline" module GHC.Utils.Asm ( sectionType ) where
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-version: 0.20200601+version: 0.20200704 license: BSD3 license-file: LICENSE category: Development@@ -84,7 +84,7 @@ process >= 1 && < 1.7, hpc == 0.6.*, exceptions == 0.10.*,- ghc-lib-parser == 0.20200601+ ghc-lib-parser == 0.20200704 build-tools: alex >= 3.1, happy >= 1.19.4 other-extensions: BangPatterns@@ -160,8 +160,10 @@ GHC.Core.FVs, GHC.Core.FamInstEnv, GHC.Core.InstEnv,+ GHC.Core.Lint, GHC.Core.Make, GHC.Core.Map,+ GHC.Core.Multiplicity, GHC.Core.Opt.Arity, GHC.Core.Opt.ConstantFold, GHC.Core.Opt.Monad,@@ -182,6 +184,7 @@ GHC.Core.Type, GHC.Core.Unfold, GHC.Core.Unify,+ GHC.Core.UsageEnv, GHC.Core.Utils, GHC.CoreToIface, GHC.Data.Bag,@@ -270,6 +273,7 @@ GHC.Settings.Config, GHC.Settings.Constants, GHC.Stg.Syntax,+ GHC.StgToCmm.Types, GHC.SysTools.BaseDir, GHC.SysTools.FileCleanup, GHC.SysTools.Terminal,@@ -320,7 +324,6 @@ GHC.Unit.Parser, GHC.Unit.Ppr, GHC.Unit.State,- GHC.Unit.Subst, GHC.Unit.Types, GHC.Utils.Binary, GHC.Utils.BufHandle,@@ -460,7 +463,6 @@ GHC.CmmToLlvm.Mangler GHC.CmmToLlvm.Ppr GHC.CmmToLlvm.Regs- GHC.Core.Lint GHC.Core.Opt.CSE GHC.Core.Opt.CallArity GHC.Core.Opt.CprAnal@@ -535,7 +537,7 @@ GHC.Iface.Rename GHC.Iface.Tidy GHC.Iface.Tidy.StaticPtrTable- GHC.Iface.UpdateCafInfos+ GHC.Iface.UpdateIdInfos GHC.IfaceToCore GHC.Llvm GHC.Llvm.MetaData
ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl view
@@ -456,6 +456,8 @@ | WriteOffAddrOp_Word16 | WriteOffAddrOp_Word32 | WriteOffAddrOp_Word64+ | InterlockedExchange_Addr+ | InterlockedExchange_Int | NewMutVarOp | ReadMutVarOp | WriteMutVarOp@@ -465,9 +467,6 @@ | CasMutVarOp | CatchOp | RaiseOp- | RaiseDivZeroOp- | RaiseUnderflowOp- | RaiseOverflowOp | RaiseIOOp | MaskAsyncExceptionsOp | MaskUninterruptibleOp
ghc-lib/stage0/compiler/build/primop-docs.hs-incl view
@@ -1,5 +1,5 @@ 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 ")+ [ ("FUN","The builtin function type, written in infix form as @a # m -> b@.\n Values of this type are functions taking inputs of type @a@ and\n producing outputs of type @b@. The multiplicity of the input is\n @m@.\n\n Note that @FUN m 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 ")@@ -168,15 +168,14 @@ , ("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.")+ , ("interlockedExchangeAddr#","The atomic exchange operation. Atomically exchanges the value at the first address\n with the Addr# given as second argument. Implies a read barrier.")+ , ("interlockedExchangeInt#","The atomic exchange operation. Atomically exchanges the value at the address\n with the given value. Returns the old value. Implies a read barrier.") , ("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")@@ -226,7 +225,7 @@ , ("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. ")+ , ("traceBinaryEvent#"," Emits an event via the RTS tracing framework. The contents\n of the event is the binary object passed as the first argument with\n the given length passed as the second argument. The event will be\n emitted to the @.eventlog@ file. ") , ("traceMarker#"," Emits a marker event via the RTS tracing framework. The contents\n of the event is the zero-terminated byte string passed as the first\n argument. The event will be emitted either to the @.eventlog@ file,\n or to stderr, depending on the runtime RTS flags. ") , ("setThreadAllocationCounter#"," Sets the allocation counter for the current thread to the given value. ") , ("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 ")
ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl view
@@ -148,6 +148,8 @@ primOpHasSideEffects WriteOffAddrOp_Word16 = True primOpHasSideEffects WriteOffAddrOp_Word32 = True primOpHasSideEffects WriteOffAddrOp_Word64 = True+primOpHasSideEffects InterlockedExchange_Addr = True+primOpHasSideEffects InterlockedExchange_Int = True primOpHasSideEffects NewMutVarOp = True primOpHasSideEffects ReadMutVarOp = True primOpHasSideEffects WriteMutVarOp = True@@ -155,9 +157,6 @@ primOpHasSideEffects AtomicModifyMutVar_Op = True primOpHasSideEffects CasMutVarOp = True primOpHasSideEffects CatchOp = True-primOpHasSideEffects RaiseDivZeroOp = True-primOpHasSideEffects RaiseUnderflowOp = True-primOpHasSideEffects RaiseOverflowOp = True primOpHasSideEffects RaiseIOOp = True primOpHasSideEffects MaskAsyncExceptionsOp = True primOpHasSideEffects MaskUninterruptibleOp = True
ghc-lib/stage0/compiler/build/primop-list.hs-incl view
@@ -455,6 +455,8 @@ , WriteOffAddrOp_Word16 , WriteOffAddrOp_Word32 , WriteOffAddrOp_Word64+ , InterlockedExchange_Addr+ , InterlockedExchange_Int , NewMutVarOp , ReadMutVarOp , WriteMutVarOp@@ -464,9 +466,6 @@ , CasMutVarOp , CatchOp , RaiseOp- , RaiseDivZeroOp- , RaiseUnderflowOp- , RaiseOverflowOp , RaiseIOOp , MaskAsyncExceptionsOp , MaskUninterruptibleOp
ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl view
@@ -36,9 +36,6 @@ primOpOutOfLine CasMutVarOp = True primOpOutOfLine CatchOp = True primOpOutOfLine RaiseOp = True-primOpOutOfLine RaiseDivZeroOp = True-primOpOutOfLine RaiseUnderflowOp = True-primOpOutOfLine RaiseOverflowOp = True primOpOutOfLine RaiseIOOp = True primOpOutOfLine MaskAsyncExceptionsOp = True primOpOutOfLine MaskUninterruptibleOp = True
ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl view
@@ -455,27 +455,26 @@ primOpInfo WriteOffAddrOp_Word16 = mkGenPrimOp (fsLit "writeWord16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Word32 = mkGenPrimOp (fsLit "writeWord32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Word64 = mkGenPrimOp (fsLit "writeWord64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo InterlockedExchange_Addr = mkGenPrimOp (fsLit "interlockedExchangeAddr#") [deltaTyVar] [addrPrimTy, addrPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))+primOpInfo InterlockedExchange_Int = mkGenPrimOp (fsLit "interlockedExchangeInt#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo NewMutVarOp = mkGenPrimOp (fsLit "newMutVar#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutVarPrimTy deltaTy alphaTy])) primOpInfo ReadMutVarOp = mkGenPrimOp (fsLit "readMutVar#") [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) primOpInfo WriteMutVarOp = mkGenPrimOp (fsLit "writeMutVar#") [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo SameMutVarOp = mkGenPrimOp (fsLit "sameMutVar#") [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, mkMutVarPrimTy deltaTy alphaTy] (intPrimTy)-primOpInfo AtomicModifyMutVar2Op = mkGenPrimOp (fsLit "atomicModifyMutVar2#") [deltaTyVar, alphaTyVar, gammaTyVar] [mkMutVarPrimTy deltaTy alphaTy, (mkVisFunTy (alphaTy) (gammaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, gammaTy]))-primOpInfo AtomicModifyMutVar_Op = mkGenPrimOp (fsLit "atomicModifyMutVar_#") [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, (mkVisFunTy (alphaTy) (alphaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, alphaTy]))+primOpInfo AtomicModifyMutVar2Op = mkGenPrimOp (fsLit "atomicModifyMutVar2#") [deltaTyVar, alphaTyVar, gammaTyVar] [mkMutVarPrimTy deltaTy alphaTy, (mkVisFunTyMany (alphaTy) (gammaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, gammaTy]))+primOpInfo AtomicModifyMutVar_Op = mkGenPrimOp (fsLit "atomicModifyMutVar_#") [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, (mkVisFunTyMany (alphaTy) (alphaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, alphaTy])) primOpInfo CasMutVarOp = mkGenPrimOp (fsLit "casMutVar#") [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))-primOpInfo CatchOp = mkGenPrimOp (fsLit "catch#") [alphaTyVar, betaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTy (betaTy) ((mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo CatchOp = mkGenPrimOp (fsLit "catch#") [alphaTyVar, betaTyVar] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTyMany (betaTy) ((mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) primOpInfo RaiseOp = mkGenPrimOp (fsLit "raise#") [betaTyVar, runtimeRep1TyVar, openAlphaTyVar] [betaTy] (openAlphaTy)-primOpInfo RaiseDivZeroOp = mkGenPrimOp (fsLit "raiseDivZero#") [runtimeRep1TyVar, openAlphaTyVar] [voidPrimTy] (openAlphaTy)-primOpInfo RaiseUnderflowOp = mkGenPrimOp (fsLit "raiseUnderflow#") [runtimeRep1TyVar, openAlphaTyVar] [voidPrimTy] (openAlphaTy)-primOpInfo RaiseOverflowOp = mkGenPrimOp (fsLit "raiseOverflow#") [runtimeRep1TyVar, openAlphaTyVar] [voidPrimTy] (openAlphaTy) primOpInfo RaiseIOOp = mkGenPrimOp (fsLit "raiseIO#") [alphaTyVar, betaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy]))-primOpInfo MaskAsyncExceptionsOp = mkGenPrimOp (fsLit "maskAsyncExceptions#") [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))-primOpInfo MaskUninterruptibleOp = mkGenPrimOp (fsLit "maskUninterruptible#") [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))-primOpInfo UnmaskAsyncExceptionsOp = mkGenPrimOp (fsLit "unmaskAsyncExceptions#") [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo MaskAsyncExceptionsOp = mkGenPrimOp (fsLit "maskAsyncExceptions#") [alphaTyVar] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo MaskUninterruptibleOp = mkGenPrimOp (fsLit "maskUninterruptible#") [alphaTyVar] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo UnmaskAsyncExceptionsOp = mkGenPrimOp (fsLit "unmaskAsyncExceptions#") [alphaTyVar] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) primOpInfo MaskStatus = mkGenPrimOp (fsLit "getMaskingState#") [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))-primOpInfo AtomicallyOp = mkGenPrimOp (fsLit "atomically#") [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo AtomicallyOp = mkGenPrimOp (fsLit "atomically#") [alphaTyVar] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) primOpInfo RetryOp = mkGenPrimOp (fsLit "retry#") [alphaTyVar] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))-primOpInfo CatchRetryOp = mkGenPrimOp (fsLit "catchRetry#") [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))-primOpInfo CatchSTMOp = mkGenPrimOp (fsLit "catchSTM#") [alphaTyVar, betaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTy (betaTy) ((mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo CatchRetryOp = mkGenPrimOp (fsLit "catchRetry#") [alphaTyVar] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo CatchSTMOp = mkGenPrimOp (fsLit "catchSTM#") [alphaTyVar, betaTyVar] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTyMany (betaTy) ((mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) primOpInfo NewTVarOp = mkGenPrimOp (fsLit "newTVar#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkTVarPrimTy deltaTy alphaTy])) primOpInfo ReadTVarOp = mkGenPrimOp (fsLit "readTVar#") [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) primOpInfo ReadTVarIOOp = mkGenPrimOp (fsLit "readTVarIO#") [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))@@ -502,11 +501,11 @@ primOpInfo IsCurrentThreadBoundOp = mkGenPrimOp (fsLit "isCurrentThreadBound#") [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) primOpInfo NoDuplicateOp = mkGenPrimOp (fsLit "noDuplicate#") [deltaTyVar] [mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo ThreadStatusOp = mkGenPrimOp (fsLit "threadStatus#") [] [threadIdPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, intPrimTy, intPrimTy]))-primOpInfo MkWeakOp = mkGenPrimOp (fsLit "mkWeak#") [runtimeRep1TyVar, openAlphaTyVar, betaTyVar, gammaTyVar] [openAlphaTy, betaTy, (mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, gammaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy]))+primOpInfo MkWeakOp = mkGenPrimOp (fsLit "mkWeak#") [runtimeRep1TyVar, openAlphaTyVar, betaTyVar, gammaTyVar] [openAlphaTy, betaTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, gammaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy])) primOpInfo MkWeakNoFinalizerOp = mkGenPrimOp (fsLit "mkWeakNoFinalizer#") [runtimeRep1TyVar, openAlphaTyVar, betaTyVar] [openAlphaTy, betaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy])) primOpInfo AddCFinalizerToWeakOp = mkGenPrimOp (fsLit "addCFinalizerToWeak#") [betaTyVar] [addrPrimTy, addrPrimTy, intPrimTy, addrPrimTy, mkWeakPrimTy betaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) primOpInfo DeRefWeakOp = mkGenPrimOp (fsLit "deRefWeak#") [alphaTyVar] [mkWeakPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, alphaTy]))-primOpInfo FinalizeWeakOp = mkGenPrimOp (fsLit "finalizeWeak#") [alphaTyVar, betaTyVar] [mkWeakPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, (mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy])))]))+primOpInfo FinalizeWeakOp = mkGenPrimOp (fsLit "finalizeWeak#") [alphaTyVar, betaTyVar] [mkWeakPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy])))])) primOpInfo TouchOp = mkGenPrimOp (fsLit "touch#") [runtimeRep1TyVar, openAlphaTyVar] [openAlphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) primOpInfo MakeStablePtrOp = mkGenPrimOp (fsLit "makeStablePtr#") [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStablePtrPrimTy alphaTy])) primOpInfo DeRefStablePtrOp = mkGenPrimOp (fsLit "deRefStablePtr#") [alphaTyVar] [mkStablePtrPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))@@ -542,7 +541,7 @@ primOpInfo GetApStackValOp = mkGenPrimOp (fsLit "getApStackVal#") [alphaTyVar, betaTyVar] [alphaTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, betaTy])) primOpInfo GetCCSOfOp = mkGenPrimOp (fsLit "getCCSOf#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) primOpInfo GetCurrentCCSOp = mkGenPrimOp (fsLit "getCurrentCCS#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))-primOpInfo ClearCCSOp = mkGenPrimOp (fsLit "clearCCS#") [deltaTyVar, alphaTyVar] [(mkVisFunTy (mkStatePrimTy deltaTy) ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo ClearCCSOp = mkGenPrimOp (fsLit "clearCCS#") [deltaTyVar, alphaTyVar] [(mkVisFunTyMany (mkStatePrimTy deltaTy) ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) primOpInfo TraceEventOp = mkGenPrimOp (fsLit "traceEvent#") [deltaTyVar] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo TraceEventBinaryOp = mkGenPrimOp (fsLit "traceBinaryEvent#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo TraceMarkerOp = mkGenPrimOp (fsLit "traceMarker#") [deltaTyVar] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
ghc-lib/stage0/compiler/build/primop-strictness.hs-incl view
@@ -2,9 +2,6 @@ , lazyApply2Dmd , topDmd] topDiv primOpStrictness RaiseOp = \ _arity -> mkClosedStrictSig [topDmd] botDiv -primOpStrictness RaiseDivZeroOp = \ _arity -> mkClosedStrictSig [topDmd] botDiv -primOpStrictness RaiseUnderflowOp = \ _arity -> mkClosedStrictSig [topDmd] botDiv -primOpStrictness RaiseOverflowOp = \ _arity -> mkClosedStrictSig [topDmd] botDiv primOpStrictness RaiseIOOp = \ _arity -> mkClosedStrictSig [topDmd, topDmd] exnDiv primOpStrictness MaskAsyncExceptionsOp = \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topDiv primOpStrictness MaskUninterruptibleOp = \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topDiv
ghc-lib/stage0/compiler/build/primop-tag.hs-incl view
@@ -1,1210 +1,1209 @@ maxPrimOpTag :: Int-maxPrimOpTag = 1207-primOpTag :: PrimOp -> Int-primOpTag CharGtOp = 1-primOpTag CharGeOp = 2-primOpTag CharEqOp = 3-primOpTag CharNeOp = 4-primOpTag CharLtOp = 5-primOpTag CharLeOp = 6-primOpTag OrdOp = 7-primOpTag Int8Extend = 8-primOpTag Int8Narrow = 9-primOpTag Int8NegOp = 10-primOpTag Int8AddOp = 11-primOpTag Int8SubOp = 12-primOpTag Int8MulOp = 13-primOpTag Int8QuotOp = 14-primOpTag Int8RemOp = 15-primOpTag Int8QuotRemOp = 16-primOpTag Int8EqOp = 17-primOpTag Int8GeOp = 18-primOpTag Int8GtOp = 19-primOpTag Int8LeOp = 20-primOpTag Int8LtOp = 21-primOpTag Int8NeOp = 22-primOpTag Word8Extend = 23-primOpTag Word8Narrow = 24-primOpTag Word8NotOp = 25-primOpTag Word8AddOp = 26-primOpTag Word8SubOp = 27-primOpTag Word8MulOp = 28-primOpTag Word8QuotOp = 29-primOpTag Word8RemOp = 30-primOpTag Word8QuotRemOp = 31-primOpTag Word8EqOp = 32-primOpTag Word8GeOp = 33-primOpTag Word8GtOp = 34-primOpTag Word8LeOp = 35-primOpTag Word8LtOp = 36-primOpTag Word8NeOp = 37-primOpTag Int16Extend = 38-primOpTag Int16Narrow = 39-primOpTag Int16NegOp = 40-primOpTag Int16AddOp = 41-primOpTag Int16SubOp = 42-primOpTag Int16MulOp = 43-primOpTag Int16QuotOp = 44-primOpTag Int16RemOp = 45-primOpTag Int16QuotRemOp = 46-primOpTag Int16EqOp = 47-primOpTag Int16GeOp = 48-primOpTag Int16GtOp = 49-primOpTag Int16LeOp = 50-primOpTag Int16LtOp = 51-primOpTag Int16NeOp = 52-primOpTag Word16Extend = 53-primOpTag Word16Narrow = 54-primOpTag Word16NotOp = 55-primOpTag Word16AddOp = 56-primOpTag Word16SubOp = 57-primOpTag Word16MulOp = 58-primOpTag Word16QuotOp = 59-primOpTag Word16RemOp = 60-primOpTag Word16QuotRemOp = 61-primOpTag Word16EqOp = 62-primOpTag Word16GeOp = 63-primOpTag Word16GtOp = 64-primOpTag Word16LeOp = 65-primOpTag Word16LtOp = 66-primOpTag Word16NeOp = 67-primOpTag IntAddOp = 68-primOpTag IntSubOp = 69-primOpTag IntMulOp = 70-primOpTag IntMul2Op = 71-primOpTag IntMulMayOfloOp = 72-primOpTag IntQuotOp = 73-primOpTag IntRemOp = 74-primOpTag IntQuotRemOp = 75-primOpTag AndIOp = 76-primOpTag OrIOp = 77-primOpTag XorIOp = 78-primOpTag NotIOp = 79-primOpTag IntNegOp = 80-primOpTag IntAddCOp = 81-primOpTag IntSubCOp = 82-primOpTag IntGtOp = 83-primOpTag IntGeOp = 84-primOpTag IntEqOp = 85-primOpTag IntNeOp = 86-primOpTag IntLtOp = 87-primOpTag IntLeOp = 88-primOpTag ChrOp = 89-primOpTag Int2WordOp = 90-primOpTag Int2FloatOp = 91-primOpTag Int2DoubleOp = 92-primOpTag Word2FloatOp = 93-primOpTag Word2DoubleOp = 94-primOpTag ISllOp = 95-primOpTag ISraOp = 96-primOpTag ISrlOp = 97-primOpTag WordAddOp = 98-primOpTag WordAddCOp = 99-primOpTag WordSubCOp = 100-primOpTag WordAdd2Op = 101-primOpTag WordSubOp = 102-primOpTag WordMulOp = 103-primOpTag WordMul2Op = 104-primOpTag WordQuotOp = 105-primOpTag WordRemOp = 106-primOpTag WordQuotRemOp = 107-primOpTag WordQuotRem2Op = 108-primOpTag AndOp = 109-primOpTag OrOp = 110-primOpTag XorOp = 111-primOpTag NotOp = 112-primOpTag SllOp = 113-primOpTag SrlOp = 114-primOpTag Word2IntOp = 115-primOpTag WordGtOp = 116-primOpTag WordGeOp = 117-primOpTag WordEqOp = 118-primOpTag WordNeOp = 119-primOpTag WordLtOp = 120-primOpTag WordLeOp = 121-primOpTag PopCnt8Op = 122-primOpTag PopCnt16Op = 123-primOpTag PopCnt32Op = 124-primOpTag PopCnt64Op = 125-primOpTag PopCntOp = 126-primOpTag Pdep8Op = 127-primOpTag Pdep16Op = 128-primOpTag Pdep32Op = 129-primOpTag Pdep64Op = 130-primOpTag PdepOp = 131-primOpTag Pext8Op = 132-primOpTag Pext16Op = 133-primOpTag Pext32Op = 134-primOpTag Pext64Op = 135-primOpTag PextOp = 136-primOpTag Clz8Op = 137-primOpTag Clz16Op = 138-primOpTag Clz32Op = 139-primOpTag Clz64Op = 140-primOpTag ClzOp = 141-primOpTag Ctz8Op = 142-primOpTag Ctz16Op = 143-primOpTag Ctz32Op = 144-primOpTag Ctz64Op = 145-primOpTag CtzOp = 146-primOpTag BSwap16Op = 147-primOpTag BSwap32Op = 148-primOpTag BSwap64Op = 149-primOpTag BSwapOp = 150-primOpTag BRev8Op = 151-primOpTag BRev16Op = 152-primOpTag BRev32Op = 153-primOpTag BRev64Op = 154-primOpTag BRevOp = 155-primOpTag Narrow8IntOp = 156-primOpTag Narrow16IntOp = 157-primOpTag Narrow32IntOp = 158-primOpTag Narrow8WordOp = 159-primOpTag Narrow16WordOp = 160-primOpTag Narrow32WordOp = 161-primOpTag DoubleGtOp = 162-primOpTag DoubleGeOp = 163-primOpTag DoubleEqOp = 164-primOpTag DoubleNeOp = 165-primOpTag DoubleLtOp = 166-primOpTag DoubleLeOp = 167-primOpTag DoubleAddOp = 168-primOpTag DoubleSubOp = 169-primOpTag DoubleMulOp = 170-primOpTag DoubleDivOp = 171-primOpTag DoubleNegOp = 172-primOpTag DoubleFabsOp = 173-primOpTag Double2IntOp = 174-primOpTag Double2FloatOp = 175-primOpTag DoubleExpOp = 176-primOpTag DoubleExpM1Op = 177-primOpTag DoubleLogOp = 178-primOpTag DoubleLog1POp = 179-primOpTag DoubleSqrtOp = 180-primOpTag DoubleSinOp = 181-primOpTag DoubleCosOp = 182-primOpTag DoubleTanOp = 183-primOpTag DoubleAsinOp = 184-primOpTag DoubleAcosOp = 185-primOpTag DoubleAtanOp = 186-primOpTag DoubleSinhOp = 187-primOpTag DoubleCoshOp = 188-primOpTag DoubleTanhOp = 189-primOpTag DoubleAsinhOp = 190-primOpTag DoubleAcoshOp = 191-primOpTag DoubleAtanhOp = 192-primOpTag DoublePowerOp = 193-primOpTag DoubleDecode_2IntOp = 194-primOpTag DoubleDecode_Int64Op = 195-primOpTag FloatGtOp = 196-primOpTag FloatGeOp = 197-primOpTag FloatEqOp = 198-primOpTag FloatNeOp = 199-primOpTag FloatLtOp = 200-primOpTag FloatLeOp = 201-primOpTag FloatAddOp = 202-primOpTag FloatSubOp = 203-primOpTag FloatMulOp = 204-primOpTag FloatDivOp = 205-primOpTag FloatNegOp = 206-primOpTag FloatFabsOp = 207-primOpTag Float2IntOp = 208-primOpTag FloatExpOp = 209-primOpTag FloatExpM1Op = 210-primOpTag FloatLogOp = 211-primOpTag FloatLog1POp = 212-primOpTag FloatSqrtOp = 213-primOpTag FloatSinOp = 214-primOpTag FloatCosOp = 215-primOpTag FloatTanOp = 216-primOpTag FloatAsinOp = 217-primOpTag FloatAcosOp = 218-primOpTag FloatAtanOp = 219-primOpTag FloatSinhOp = 220-primOpTag FloatCoshOp = 221-primOpTag FloatTanhOp = 222-primOpTag FloatAsinhOp = 223-primOpTag FloatAcoshOp = 224-primOpTag FloatAtanhOp = 225-primOpTag FloatPowerOp = 226-primOpTag Float2DoubleOp = 227-primOpTag FloatDecode_IntOp = 228-primOpTag NewArrayOp = 229-primOpTag SameMutableArrayOp = 230-primOpTag ReadArrayOp = 231-primOpTag WriteArrayOp = 232-primOpTag SizeofArrayOp = 233-primOpTag SizeofMutableArrayOp = 234-primOpTag IndexArrayOp = 235-primOpTag UnsafeFreezeArrayOp = 236-primOpTag UnsafeThawArrayOp = 237-primOpTag CopyArrayOp = 238-primOpTag CopyMutableArrayOp = 239-primOpTag CloneArrayOp = 240-primOpTag CloneMutableArrayOp = 241-primOpTag FreezeArrayOp = 242-primOpTag ThawArrayOp = 243-primOpTag CasArrayOp = 244-primOpTag NewSmallArrayOp = 245-primOpTag SameSmallMutableArrayOp = 246-primOpTag ShrinkSmallMutableArrayOp_Char = 247-primOpTag ReadSmallArrayOp = 248-primOpTag WriteSmallArrayOp = 249-primOpTag SizeofSmallArrayOp = 250-primOpTag SizeofSmallMutableArrayOp = 251-primOpTag GetSizeofSmallMutableArrayOp = 252-primOpTag IndexSmallArrayOp = 253-primOpTag UnsafeFreezeSmallArrayOp = 254-primOpTag UnsafeThawSmallArrayOp = 255-primOpTag CopySmallArrayOp = 256-primOpTag CopySmallMutableArrayOp = 257-primOpTag CloneSmallArrayOp = 258-primOpTag CloneSmallMutableArrayOp = 259-primOpTag FreezeSmallArrayOp = 260-primOpTag ThawSmallArrayOp = 261-primOpTag CasSmallArrayOp = 262-primOpTag NewByteArrayOp_Char = 263-primOpTag NewPinnedByteArrayOp_Char = 264-primOpTag NewAlignedPinnedByteArrayOp_Char = 265-primOpTag MutableByteArrayIsPinnedOp = 266-primOpTag ByteArrayIsPinnedOp = 267-primOpTag ByteArrayContents_Char = 268-primOpTag SameMutableByteArrayOp = 269-primOpTag ShrinkMutableByteArrayOp_Char = 270-primOpTag ResizeMutableByteArrayOp_Char = 271-primOpTag UnsafeFreezeByteArrayOp = 272-primOpTag SizeofByteArrayOp = 273-primOpTag SizeofMutableByteArrayOp = 274-primOpTag GetSizeofMutableByteArrayOp = 275-primOpTag IndexByteArrayOp_Char = 276-primOpTag IndexByteArrayOp_WideChar = 277-primOpTag IndexByteArrayOp_Int = 278-primOpTag IndexByteArrayOp_Word = 279-primOpTag IndexByteArrayOp_Addr = 280-primOpTag IndexByteArrayOp_Float = 281-primOpTag IndexByteArrayOp_Double = 282-primOpTag IndexByteArrayOp_StablePtr = 283-primOpTag IndexByteArrayOp_Int8 = 284-primOpTag IndexByteArrayOp_Int16 = 285-primOpTag IndexByteArrayOp_Int32 = 286-primOpTag IndexByteArrayOp_Int64 = 287-primOpTag IndexByteArrayOp_Word8 = 288-primOpTag IndexByteArrayOp_Word16 = 289-primOpTag IndexByteArrayOp_Word32 = 290-primOpTag IndexByteArrayOp_Word64 = 291-primOpTag IndexByteArrayOp_Word8AsChar = 292-primOpTag IndexByteArrayOp_Word8AsWideChar = 293-primOpTag IndexByteArrayOp_Word8AsAddr = 294-primOpTag IndexByteArrayOp_Word8AsFloat = 295-primOpTag IndexByteArrayOp_Word8AsDouble = 296-primOpTag IndexByteArrayOp_Word8AsStablePtr = 297-primOpTag IndexByteArrayOp_Word8AsInt16 = 298-primOpTag IndexByteArrayOp_Word8AsInt32 = 299-primOpTag IndexByteArrayOp_Word8AsInt64 = 300-primOpTag IndexByteArrayOp_Word8AsInt = 301-primOpTag IndexByteArrayOp_Word8AsWord16 = 302-primOpTag IndexByteArrayOp_Word8AsWord32 = 303-primOpTag IndexByteArrayOp_Word8AsWord64 = 304-primOpTag IndexByteArrayOp_Word8AsWord = 305-primOpTag ReadByteArrayOp_Char = 306-primOpTag ReadByteArrayOp_WideChar = 307-primOpTag ReadByteArrayOp_Int = 308-primOpTag ReadByteArrayOp_Word = 309-primOpTag ReadByteArrayOp_Addr = 310-primOpTag ReadByteArrayOp_Float = 311-primOpTag ReadByteArrayOp_Double = 312-primOpTag ReadByteArrayOp_StablePtr = 313-primOpTag ReadByteArrayOp_Int8 = 314-primOpTag ReadByteArrayOp_Int16 = 315-primOpTag ReadByteArrayOp_Int32 = 316-primOpTag ReadByteArrayOp_Int64 = 317-primOpTag ReadByteArrayOp_Word8 = 318-primOpTag ReadByteArrayOp_Word16 = 319-primOpTag ReadByteArrayOp_Word32 = 320-primOpTag ReadByteArrayOp_Word64 = 321-primOpTag ReadByteArrayOp_Word8AsChar = 322-primOpTag ReadByteArrayOp_Word8AsWideChar = 323-primOpTag ReadByteArrayOp_Word8AsAddr = 324-primOpTag ReadByteArrayOp_Word8AsFloat = 325-primOpTag ReadByteArrayOp_Word8AsDouble = 326-primOpTag ReadByteArrayOp_Word8AsStablePtr = 327-primOpTag ReadByteArrayOp_Word8AsInt16 = 328-primOpTag ReadByteArrayOp_Word8AsInt32 = 329-primOpTag ReadByteArrayOp_Word8AsInt64 = 330-primOpTag ReadByteArrayOp_Word8AsInt = 331-primOpTag ReadByteArrayOp_Word8AsWord16 = 332-primOpTag ReadByteArrayOp_Word8AsWord32 = 333-primOpTag ReadByteArrayOp_Word8AsWord64 = 334-primOpTag ReadByteArrayOp_Word8AsWord = 335-primOpTag WriteByteArrayOp_Char = 336-primOpTag WriteByteArrayOp_WideChar = 337-primOpTag WriteByteArrayOp_Int = 338-primOpTag WriteByteArrayOp_Word = 339-primOpTag WriteByteArrayOp_Addr = 340-primOpTag WriteByteArrayOp_Float = 341-primOpTag WriteByteArrayOp_Double = 342-primOpTag WriteByteArrayOp_StablePtr = 343-primOpTag WriteByteArrayOp_Int8 = 344-primOpTag WriteByteArrayOp_Int16 = 345-primOpTag WriteByteArrayOp_Int32 = 346-primOpTag WriteByteArrayOp_Int64 = 347-primOpTag WriteByteArrayOp_Word8 = 348-primOpTag WriteByteArrayOp_Word16 = 349-primOpTag WriteByteArrayOp_Word32 = 350-primOpTag WriteByteArrayOp_Word64 = 351-primOpTag WriteByteArrayOp_Word8AsChar = 352-primOpTag WriteByteArrayOp_Word8AsWideChar = 353-primOpTag WriteByteArrayOp_Word8AsAddr = 354-primOpTag WriteByteArrayOp_Word8AsFloat = 355-primOpTag WriteByteArrayOp_Word8AsDouble = 356-primOpTag WriteByteArrayOp_Word8AsStablePtr = 357-primOpTag WriteByteArrayOp_Word8AsInt16 = 358-primOpTag WriteByteArrayOp_Word8AsInt32 = 359-primOpTag WriteByteArrayOp_Word8AsInt64 = 360-primOpTag WriteByteArrayOp_Word8AsInt = 361-primOpTag WriteByteArrayOp_Word8AsWord16 = 362-primOpTag WriteByteArrayOp_Word8AsWord32 = 363-primOpTag WriteByteArrayOp_Word8AsWord64 = 364-primOpTag WriteByteArrayOp_Word8AsWord = 365-primOpTag CompareByteArraysOp = 366-primOpTag CopyByteArrayOp = 367-primOpTag CopyMutableByteArrayOp = 368-primOpTag CopyByteArrayToAddrOp = 369-primOpTag CopyMutableByteArrayToAddrOp = 370-primOpTag CopyAddrToByteArrayOp = 371-primOpTag SetByteArrayOp = 372-primOpTag AtomicReadByteArrayOp_Int = 373-primOpTag AtomicWriteByteArrayOp_Int = 374-primOpTag CasByteArrayOp_Int = 375-primOpTag FetchAddByteArrayOp_Int = 376-primOpTag FetchSubByteArrayOp_Int = 377-primOpTag FetchAndByteArrayOp_Int = 378-primOpTag FetchNandByteArrayOp_Int = 379-primOpTag FetchOrByteArrayOp_Int = 380-primOpTag FetchXorByteArrayOp_Int = 381-primOpTag NewArrayArrayOp = 382-primOpTag SameMutableArrayArrayOp = 383-primOpTag UnsafeFreezeArrayArrayOp = 384-primOpTag SizeofArrayArrayOp = 385-primOpTag SizeofMutableArrayArrayOp = 386-primOpTag IndexArrayArrayOp_ByteArray = 387-primOpTag IndexArrayArrayOp_ArrayArray = 388-primOpTag ReadArrayArrayOp_ByteArray = 389-primOpTag ReadArrayArrayOp_MutableByteArray = 390-primOpTag ReadArrayArrayOp_ArrayArray = 391-primOpTag ReadArrayArrayOp_MutableArrayArray = 392-primOpTag WriteArrayArrayOp_ByteArray = 393-primOpTag WriteArrayArrayOp_MutableByteArray = 394-primOpTag WriteArrayArrayOp_ArrayArray = 395-primOpTag WriteArrayArrayOp_MutableArrayArray = 396-primOpTag CopyArrayArrayOp = 397-primOpTag CopyMutableArrayArrayOp = 398-primOpTag AddrAddOp = 399-primOpTag AddrSubOp = 400-primOpTag AddrRemOp = 401-primOpTag Addr2IntOp = 402-primOpTag Int2AddrOp = 403-primOpTag AddrGtOp = 404-primOpTag AddrGeOp = 405-primOpTag AddrEqOp = 406-primOpTag AddrNeOp = 407-primOpTag AddrLtOp = 408-primOpTag AddrLeOp = 409-primOpTag IndexOffAddrOp_Char = 410-primOpTag IndexOffAddrOp_WideChar = 411-primOpTag IndexOffAddrOp_Int = 412-primOpTag IndexOffAddrOp_Word = 413-primOpTag IndexOffAddrOp_Addr = 414-primOpTag IndexOffAddrOp_Float = 415-primOpTag IndexOffAddrOp_Double = 416-primOpTag IndexOffAddrOp_StablePtr = 417-primOpTag IndexOffAddrOp_Int8 = 418-primOpTag IndexOffAddrOp_Int16 = 419-primOpTag IndexOffAddrOp_Int32 = 420-primOpTag IndexOffAddrOp_Int64 = 421-primOpTag IndexOffAddrOp_Word8 = 422-primOpTag IndexOffAddrOp_Word16 = 423-primOpTag IndexOffAddrOp_Word32 = 424-primOpTag IndexOffAddrOp_Word64 = 425-primOpTag ReadOffAddrOp_Char = 426-primOpTag ReadOffAddrOp_WideChar = 427-primOpTag ReadOffAddrOp_Int = 428-primOpTag ReadOffAddrOp_Word = 429-primOpTag ReadOffAddrOp_Addr = 430-primOpTag ReadOffAddrOp_Float = 431-primOpTag ReadOffAddrOp_Double = 432-primOpTag ReadOffAddrOp_StablePtr = 433-primOpTag ReadOffAddrOp_Int8 = 434-primOpTag ReadOffAddrOp_Int16 = 435-primOpTag ReadOffAddrOp_Int32 = 436-primOpTag ReadOffAddrOp_Int64 = 437-primOpTag ReadOffAddrOp_Word8 = 438-primOpTag ReadOffAddrOp_Word16 = 439-primOpTag ReadOffAddrOp_Word32 = 440-primOpTag ReadOffAddrOp_Word64 = 441-primOpTag WriteOffAddrOp_Char = 442-primOpTag WriteOffAddrOp_WideChar = 443-primOpTag WriteOffAddrOp_Int = 444-primOpTag WriteOffAddrOp_Word = 445-primOpTag WriteOffAddrOp_Addr = 446-primOpTag WriteOffAddrOp_Float = 447-primOpTag WriteOffAddrOp_Double = 448-primOpTag WriteOffAddrOp_StablePtr = 449-primOpTag WriteOffAddrOp_Int8 = 450-primOpTag WriteOffAddrOp_Int16 = 451-primOpTag WriteOffAddrOp_Int32 = 452-primOpTag WriteOffAddrOp_Int64 = 453-primOpTag WriteOffAddrOp_Word8 = 454-primOpTag WriteOffAddrOp_Word16 = 455-primOpTag WriteOffAddrOp_Word32 = 456-primOpTag WriteOffAddrOp_Word64 = 457-primOpTag NewMutVarOp = 458-primOpTag ReadMutVarOp = 459-primOpTag WriteMutVarOp = 460-primOpTag SameMutVarOp = 461-primOpTag AtomicModifyMutVar2Op = 462-primOpTag AtomicModifyMutVar_Op = 463-primOpTag CasMutVarOp = 464-primOpTag CatchOp = 465-primOpTag RaiseOp = 466-primOpTag RaiseDivZeroOp = 467-primOpTag RaiseUnderflowOp = 468-primOpTag RaiseOverflowOp = 469-primOpTag RaiseIOOp = 470-primOpTag MaskAsyncExceptionsOp = 471-primOpTag MaskUninterruptibleOp = 472-primOpTag UnmaskAsyncExceptionsOp = 473-primOpTag MaskStatus = 474-primOpTag AtomicallyOp = 475-primOpTag RetryOp = 476-primOpTag CatchRetryOp = 477-primOpTag CatchSTMOp = 478-primOpTag NewTVarOp = 479-primOpTag ReadTVarOp = 480-primOpTag ReadTVarIOOp = 481-primOpTag WriteTVarOp = 482-primOpTag SameTVarOp = 483-primOpTag NewMVarOp = 484-primOpTag TakeMVarOp = 485-primOpTag TryTakeMVarOp = 486-primOpTag PutMVarOp = 487-primOpTag TryPutMVarOp = 488-primOpTag ReadMVarOp = 489-primOpTag TryReadMVarOp = 490-primOpTag SameMVarOp = 491-primOpTag IsEmptyMVarOp = 492-primOpTag DelayOp = 493-primOpTag WaitReadOp = 494-primOpTag WaitWriteOp = 495-primOpTag ForkOp = 496-primOpTag ForkOnOp = 497-primOpTag KillThreadOp = 498-primOpTag YieldOp = 499-primOpTag MyThreadIdOp = 500-primOpTag LabelThreadOp = 501-primOpTag IsCurrentThreadBoundOp = 502-primOpTag NoDuplicateOp = 503-primOpTag ThreadStatusOp = 504-primOpTag MkWeakOp = 505-primOpTag MkWeakNoFinalizerOp = 506-primOpTag AddCFinalizerToWeakOp = 507-primOpTag DeRefWeakOp = 508-primOpTag FinalizeWeakOp = 509-primOpTag TouchOp = 510-primOpTag MakeStablePtrOp = 511-primOpTag DeRefStablePtrOp = 512-primOpTag EqStablePtrOp = 513-primOpTag MakeStableNameOp = 514-primOpTag EqStableNameOp = 515-primOpTag StableNameToIntOp = 516-primOpTag CompactNewOp = 517-primOpTag CompactResizeOp = 518-primOpTag CompactContainsOp = 519-primOpTag CompactContainsAnyOp = 520-primOpTag CompactGetFirstBlockOp = 521-primOpTag CompactGetNextBlockOp = 522-primOpTag CompactAllocateBlockOp = 523-primOpTag CompactFixupPointersOp = 524-primOpTag CompactAdd = 525-primOpTag CompactAddWithSharing = 526-primOpTag CompactSize = 527-primOpTag ReallyUnsafePtrEqualityOp = 528-primOpTag ParOp = 529-primOpTag SparkOp = 530-primOpTag SeqOp = 531-primOpTag GetSparkOp = 532-primOpTag NumSparks = 533-primOpTag DataToTagOp = 534-primOpTag TagToEnumOp = 535-primOpTag AddrToAnyOp = 536-primOpTag AnyToAddrOp = 537-primOpTag MkApUpd0_Op = 538-primOpTag NewBCOOp = 539-primOpTag UnpackClosureOp = 540-primOpTag ClosureSizeOp = 541-primOpTag GetApStackValOp = 542-primOpTag GetCCSOfOp = 543-primOpTag GetCurrentCCSOp = 544-primOpTag ClearCCSOp = 545-primOpTag TraceEventOp = 546-primOpTag TraceEventBinaryOp = 547-primOpTag TraceMarkerOp = 548-primOpTag SetThreadAllocationCounter = 549-primOpTag (VecBroadcastOp IntVec 16 W8) = 550-primOpTag (VecBroadcastOp IntVec 8 W16) = 551-primOpTag (VecBroadcastOp IntVec 4 W32) = 552-primOpTag (VecBroadcastOp IntVec 2 W64) = 553-primOpTag (VecBroadcastOp IntVec 32 W8) = 554-primOpTag (VecBroadcastOp IntVec 16 W16) = 555-primOpTag (VecBroadcastOp IntVec 8 W32) = 556-primOpTag (VecBroadcastOp IntVec 4 W64) = 557-primOpTag (VecBroadcastOp IntVec 64 W8) = 558-primOpTag (VecBroadcastOp IntVec 32 W16) = 559-primOpTag (VecBroadcastOp IntVec 16 W32) = 560-primOpTag (VecBroadcastOp IntVec 8 W64) = 561-primOpTag (VecBroadcastOp WordVec 16 W8) = 562-primOpTag (VecBroadcastOp WordVec 8 W16) = 563-primOpTag (VecBroadcastOp WordVec 4 W32) = 564-primOpTag (VecBroadcastOp WordVec 2 W64) = 565-primOpTag (VecBroadcastOp WordVec 32 W8) = 566-primOpTag (VecBroadcastOp WordVec 16 W16) = 567-primOpTag (VecBroadcastOp WordVec 8 W32) = 568-primOpTag (VecBroadcastOp WordVec 4 W64) = 569-primOpTag (VecBroadcastOp WordVec 64 W8) = 570-primOpTag (VecBroadcastOp WordVec 32 W16) = 571-primOpTag (VecBroadcastOp WordVec 16 W32) = 572-primOpTag (VecBroadcastOp WordVec 8 W64) = 573-primOpTag (VecBroadcastOp FloatVec 4 W32) = 574-primOpTag (VecBroadcastOp FloatVec 2 W64) = 575-primOpTag (VecBroadcastOp FloatVec 8 W32) = 576-primOpTag (VecBroadcastOp FloatVec 4 W64) = 577-primOpTag (VecBroadcastOp FloatVec 16 W32) = 578-primOpTag (VecBroadcastOp FloatVec 8 W64) = 579-primOpTag (VecPackOp IntVec 16 W8) = 580-primOpTag (VecPackOp IntVec 8 W16) = 581-primOpTag (VecPackOp IntVec 4 W32) = 582-primOpTag (VecPackOp IntVec 2 W64) = 583-primOpTag (VecPackOp IntVec 32 W8) = 584-primOpTag (VecPackOp IntVec 16 W16) = 585-primOpTag (VecPackOp IntVec 8 W32) = 586-primOpTag (VecPackOp IntVec 4 W64) = 587-primOpTag (VecPackOp IntVec 64 W8) = 588-primOpTag (VecPackOp IntVec 32 W16) = 589-primOpTag (VecPackOp IntVec 16 W32) = 590-primOpTag (VecPackOp IntVec 8 W64) = 591-primOpTag (VecPackOp WordVec 16 W8) = 592-primOpTag (VecPackOp WordVec 8 W16) = 593-primOpTag (VecPackOp WordVec 4 W32) = 594-primOpTag (VecPackOp WordVec 2 W64) = 595-primOpTag (VecPackOp WordVec 32 W8) = 596-primOpTag (VecPackOp WordVec 16 W16) = 597-primOpTag (VecPackOp WordVec 8 W32) = 598-primOpTag (VecPackOp WordVec 4 W64) = 599-primOpTag (VecPackOp WordVec 64 W8) = 600-primOpTag (VecPackOp WordVec 32 W16) = 601-primOpTag (VecPackOp WordVec 16 W32) = 602-primOpTag (VecPackOp WordVec 8 W64) = 603-primOpTag (VecPackOp FloatVec 4 W32) = 604-primOpTag (VecPackOp FloatVec 2 W64) = 605-primOpTag (VecPackOp FloatVec 8 W32) = 606-primOpTag (VecPackOp FloatVec 4 W64) = 607-primOpTag (VecPackOp FloatVec 16 W32) = 608-primOpTag (VecPackOp FloatVec 8 W64) = 609-primOpTag (VecUnpackOp IntVec 16 W8) = 610-primOpTag (VecUnpackOp IntVec 8 W16) = 611-primOpTag (VecUnpackOp IntVec 4 W32) = 612-primOpTag (VecUnpackOp IntVec 2 W64) = 613-primOpTag (VecUnpackOp IntVec 32 W8) = 614-primOpTag (VecUnpackOp IntVec 16 W16) = 615-primOpTag (VecUnpackOp IntVec 8 W32) = 616-primOpTag (VecUnpackOp IntVec 4 W64) = 617-primOpTag (VecUnpackOp IntVec 64 W8) = 618-primOpTag (VecUnpackOp IntVec 32 W16) = 619-primOpTag (VecUnpackOp IntVec 16 W32) = 620-primOpTag (VecUnpackOp IntVec 8 W64) = 621-primOpTag (VecUnpackOp WordVec 16 W8) = 622-primOpTag (VecUnpackOp WordVec 8 W16) = 623-primOpTag (VecUnpackOp WordVec 4 W32) = 624-primOpTag (VecUnpackOp WordVec 2 W64) = 625-primOpTag (VecUnpackOp WordVec 32 W8) = 626-primOpTag (VecUnpackOp WordVec 16 W16) = 627-primOpTag (VecUnpackOp WordVec 8 W32) = 628-primOpTag (VecUnpackOp WordVec 4 W64) = 629-primOpTag (VecUnpackOp WordVec 64 W8) = 630-primOpTag (VecUnpackOp WordVec 32 W16) = 631-primOpTag (VecUnpackOp WordVec 16 W32) = 632-primOpTag (VecUnpackOp WordVec 8 W64) = 633-primOpTag (VecUnpackOp FloatVec 4 W32) = 634-primOpTag (VecUnpackOp FloatVec 2 W64) = 635-primOpTag (VecUnpackOp FloatVec 8 W32) = 636-primOpTag (VecUnpackOp FloatVec 4 W64) = 637-primOpTag (VecUnpackOp FloatVec 16 W32) = 638-primOpTag (VecUnpackOp FloatVec 8 W64) = 639-primOpTag (VecInsertOp IntVec 16 W8) = 640-primOpTag (VecInsertOp IntVec 8 W16) = 641-primOpTag (VecInsertOp IntVec 4 W32) = 642-primOpTag (VecInsertOp IntVec 2 W64) = 643-primOpTag (VecInsertOp IntVec 32 W8) = 644-primOpTag (VecInsertOp IntVec 16 W16) = 645-primOpTag (VecInsertOp IntVec 8 W32) = 646-primOpTag (VecInsertOp IntVec 4 W64) = 647-primOpTag (VecInsertOp IntVec 64 W8) = 648-primOpTag (VecInsertOp IntVec 32 W16) = 649-primOpTag (VecInsertOp IntVec 16 W32) = 650-primOpTag (VecInsertOp IntVec 8 W64) = 651-primOpTag (VecInsertOp WordVec 16 W8) = 652-primOpTag (VecInsertOp WordVec 8 W16) = 653-primOpTag (VecInsertOp WordVec 4 W32) = 654-primOpTag (VecInsertOp WordVec 2 W64) = 655-primOpTag (VecInsertOp WordVec 32 W8) = 656-primOpTag (VecInsertOp WordVec 16 W16) = 657-primOpTag (VecInsertOp WordVec 8 W32) = 658-primOpTag (VecInsertOp WordVec 4 W64) = 659-primOpTag (VecInsertOp WordVec 64 W8) = 660-primOpTag (VecInsertOp WordVec 32 W16) = 661-primOpTag (VecInsertOp WordVec 16 W32) = 662-primOpTag (VecInsertOp WordVec 8 W64) = 663-primOpTag (VecInsertOp FloatVec 4 W32) = 664-primOpTag (VecInsertOp FloatVec 2 W64) = 665-primOpTag (VecInsertOp FloatVec 8 W32) = 666-primOpTag (VecInsertOp FloatVec 4 W64) = 667-primOpTag (VecInsertOp FloatVec 16 W32) = 668-primOpTag (VecInsertOp FloatVec 8 W64) = 669-primOpTag (VecAddOp IntVec 16 W8) = 670-primOpTag (VecAddOp IntVec 8 W16) = 671-primOpTag (VecAddOp IntVec 4 W32) = 672-primOpTag (VecAddOp IntVec 2 W64) = 673-primOpTag (VecAddOp IntVec 32 W8) = 674-primOpTag (VecAddOp IntVec 16 W16) = 675-primOpTag (VecAddOp IntVec 8 W32) = 676-primOpTag (VecAddOp IntVec 4 W64) = 677-primOpTag (VecAddOp IntVec 64 W8) = 678-primOpTag (VecAddOp IntVec 32 W16) = 679-primOpTag (VecAddOp IntVec 16 W32) = 680-primOpTag (VecAddOp IntVec 8 W64) = 681-primOpTag (VecAddOp WordVec 16 W8) = 682-primOpTag (VecAddOp WordVec 8 W16) = 683-primOpTag (VecAddOp WordVec 4 W32) = 684-primOpTag (VecAddOp WordVec 2 W64) = 685-primOpTag (VecAddOp WordVec 32 W8) = 686-primOpTag (VecAddOp WordVec 16 W16) = 687-primOpTag (VecAddOp WordVec 8 W32) = 688-primOpTag (VecAddOp WordVec 4 W64) = 689-primOpTag (VecAddOp WordVec 64 W8) = 690-primOpTag (VecAddOp WordVec 32 W16) = 691-primOpTag (VecAddOp WordVec 16 W32) = 692-primOpTag (VecAddOp WordVec 8 W64) = 693-primOpTag (VecAddOp FloatVec 4 W32) = 694-primOpTag (VecAddOp FloatVec 2 W64) = 695-primOpTag (VecAddOp FloatVec 8 W32) = 696-primOpTag (VecAddOp FloatVec 4 W64) = 697-primOpTag (VecAddOp FloatVec 16 W32) = 698-primOpTag (VecAddOp FloatVec 8 W64) = 699-primOpTag (VecSubOp IntVec 16 W8) = 700-primOpTag (VecSubOp IntVec 8 W16) = 701-primOpTag (VecSubOp IntVec 4 W32) = 702-primOpTag (VecSubOp IntVec 2 W64) = 703-primOpTag (VecSubOp IntVec 32 W8) = 704-primOpTag (VecSubOp IntVec 16 W16) = 705-primOpTag (VecSubOp IntVec 8 W32) = 706-primOpTag (VecSubOp IntVec 4 W64) = 707-primOpTag (VecSubOp IntVec 64 W8) = 708-primOpTag (VecSubOp IntVec 32 W16) = 709-primOpTag (VecSubOp IntVec 16 W32) = 710-primOpTag (VecSubOp IntVec 8 W64) = 711-primOpTag (VecSubOp WordVec 16 W8) = 712-primOpTag (VecSubOp WordVec 8 W16) = 713-primOpTag (VecSubOp WordVec 4 W32) = 714-primOpTag (VecSubOp WordVec 2 W64) = 715-primOpTag (VecSubOp WordVec 32 W8) = 716-primOpTag (VecSubOp WordVec 16 W16) = 717-primOpTag (VecSubOp WordVec 8 W32) = 718-primOpTag (VecSubOp WordVec 4 W64) = 719-primOpTag (VecSubOp WordVec 64 W8) = 720-primOpTag (VecSubOp WordVec 32 W16) = 721-primOpTag (VecSubOp WordVec 16 W32) = 722-primOpTag (VecSubOp WordVec 8 W64) = 723-primOpTag (VecSubOp FloatVec 4 W32) = 724-primOpTag (VecSubOp FloatVec 2 W64) = 725-primOpTag (VecSubOp FloatVec 8 W32) = 726-primOpTag (VecSubOp FloatVec 4 W64) = 727-primOpTag (VecSubOp FloatVec 16 W32) = 728-primOpTag (VecSubOp FloatVec 8 W64) = 729-primOpTag (VecMulOp IntVec 16 W8) = 730-primOpTag (VecMulOp IntVec 8 W16) = 731-primOpTag (VecMulOp IntVec 4 W32) = 732-primOpTag (VecMulOp IntVec 2 W64) = 733-primOpTag (VecMulOp IntVec 32 W8) = 734-primOpTag (VecMulOp IntVec 16 W16) = 735-primOpTag (VecMulOp IntVec 8 W32) = 736-primOpTag (VecMulOp IntVec 4 W64) = 737-primOpTag (VecMulOp IntVec 64 W8) = 738-primOpTag (VecMulOp IntVec 32 W16) = 739-primOpTag (VecMulOp IntVec 16 W32) = 740-primOpTag (VecMulOp IntVec 8 W64) = 741-primOpTag (VecMulOp WordVec 16 W8) = 742-primOpTag (VecMulOp WordVec 8 W16) = 743-primOpTag (VecMulOp WordVec 4 W32) = 744-primOpTag (VecMulOp WordVec 2 W64) = 745-primOpTag (VecMulOp WordVec 32 W8) = 746-primOpTag (VecMulOp WordVec 16 W16) = 747-primOpTag (VecMulOp WordVec 8 W32) = 748-primOpTag (VecMulOp WordVec 4 W64) = 749-primOpTag (VecMulOp WordVec 64 W8) = 750-primOpTag (VecMulOp WordVec 32 W16) = 751-primOpTag (VecMulOp WordVec 16 W32) = 752-primOpTag (VecMulOp WordVec 8 W64) = 753-primOpTag (VecMulOp FloatVec 4 W32) = 754-primOpTag (VecMulOp FloatVec 2 W64) = 755-primOpTag (VecMulOp FloatVec 8 W32) = 756-primOpTag (VecMulOp FloatVec 4 W64) = 757-primOpTag (VecMulOp FloatVec 16 W32) = 758-primOpTag (VecMulOp FloatVec 8 W64) = 759-primOpTag (VecDivOp FloatVec 4 W32) = 760-primOpTag (VecDivOp FloatVec 2 W64) = 761-primOpTag (VecDivOp FloatVec 8 W32) = 762-primOpTag (VecDivOp FloatVec 4 W64) = 763-primOpTag (VecDivOp FloatVec 16 W32) = 764-primOpTag (VecDivOp FloatVec 8 W64) = 765-primOpTag (VecQuotOp IntVec 16 W8) = 766-primOpTag (VecQuotOp IntVec 8 W16) = 767-primOpTag (VecQuotOp IntVec 4 W32) = 768-primOpTag (VecQuotOp IntVec 2 W64) = 769-primOpTag (VecQuotOp IntVec 32 W8) = 770-primOpTag (VecQuotOp IntVec 16 W16) = 771-primOpTag (VecQuotOp IntVec 8 W32) = 772-primOpTag (VecQuotOp IntVec 4 W64) = 773-primOpTag (VecQuotOp IntVec 64 W8) = 774-primOpTag (VecQuotOp IntVec 32 W16) = 775-primOpTag (VecQuotOp IntVec 16 W32) = 776-primOpTag (VecQuotOp IntVec 8 W64) = 777-primOpTag (VecQuotOp WordVec 16 W8) = 778-primOpTag (VecQuotOp WordVec 8 W16) = 779-primOpTag (VecQuotOp WordVec 4 W32) = 780-primOpTag (VecQuotOp WordVec 2 W64) = 781-primOpTag (VecQuotOp WordVec 32 W8) = 782-primOpTag (VecQuotOp WordVec 16 W16) = 783-primOpTag (VecQuotOp WordVec 8 W32) = 784-primOpTag (VecQuotOp WordVec 4 W64) = 785-primOpTag (VecQuotOp WordVec 64 W8) = 786-primOpTag (VecQuotOp WordVec 32 W16) = 787-primOpTag (VecQuotOp WordVec 16 W32) = 788-primOpTag (VecQuotOp WordVec 8 W64) = 789-primOpTag (VecRemOp IntVec 16 W8) = 790-primOpTag (VecRemOp IntVec 8 W16) = 791-primOpTag (VecRemOp IntVec 4 W32) = 792-primOpTag (VecRemOp IntVec 2 W64) = 793-primOpTag (VecRemOp IntVec 32 W8) = 794-primOpTag (VecRemOp IntVec 16 W16) = 795-primOpTag (VecRemOp IntVec 8 W32) = 796-primOpTag (VecRemOp IntVec 4 W64) = 797-primOpTag (VecRemOp IntVec 64 W8) = 798-primOpTag (VecRemOp IntVec 32 W16) = 799-primOpTag (VecRemOp IntVec 16 W32) = 800-primOpTag (VecRemOp IntVec 8 W64) = 801-primOpTag (VecRemOp WordVec 16 W8) = 802-primOpTag (VecRemOp WordVec 8 W16) = 803-primOpTag (VecRemOp WordVec 4 W32) = 804-primOpTag (VecRemOp WordVec 2 W64) = 805-primOpTag (VecRemOp WordVec 32 W8) = 806-primOpTag (VecRemOp WordVec 16 W16) = 807-primOpTag (VecRemOp WordVec 8 W32) = 808-primOpTag (VecRemOp WordVec 4 W64) = 809-primOpTag (VecRemOp WordVec 64 W8) = 810-primOpTag (VecRemOp WordVec 32 W16) = 811-primOpTag (VecRemOp WordVec 16 W32) = 812-primOpTag (VecRemOp WordVec 8 W64) = 813-primOpTag (VecNegOp IntVec 16 W8) = 814-primOpTag (VecNegOp IntVec 8 W16) = 815-primOpTag (VecNegOp IntVec 4 W32) = 816-primOpTag (VecNegOp IntVec 2 W64) = 817-primOpTag (VecNegOp IntVec 32 W8) = 818-primOpTag (VecNegOp IntVec 16 W16) = 819-primOpTag (VecNegOp IntVec 8 W32) = 820-primOpTag (VecNegOp IntVec 4 W64) = 821-primOpTag (VecNegOp IntVec 64 W8) = 822-primOpTag (VecNegOp IntVec 32 W16) = 823-primOpTag (VecNegOp IntVec 16 W32) = 824-primOpTag (VecNegOp IntVec 8 W64) = 825-primOpTag (VecNegOp FloatVec 4 W32) = 826-primOpTag (VecNegOp FloatVec 2 W64) = 827-primOpTag (VecNegOp FloatVec 8 W32) = 828-primOpTag (VecNegOp FloatVec 4 W64) = 829-primOpTag (VecNegOp FloatVec 16 W32) = 830-primOpTag (VecNegOp FloatVec 8 W64) = 831-primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 832-primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 833-primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 834-primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 835-primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 836-primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 837-primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 838-primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 839-primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 840-primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 841-primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 842-primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 843-primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 844-primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 845-primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 846-primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 847-primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 848-primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 849-primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 850-primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 851-primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 852-primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 853-primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 854-primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 855-primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 856-primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 857-primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 858-primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 859-primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 860-primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 861-primOpTag (VecReadByteArrayOp IntVec 16 W8) = 862-primOpTag (VecReadByteArrayOp IntVec 8 W16) = 863-primOpTag (VecReadByteArrayOp IntVec 4 W32) = 864-primOpTag (VecReadByteArrayOp IntVec 2 W64) = 865-primOpTag (VecReadByteArrayOp IntVec 32 W8) = 866-primOpTag (VecReadByteArrayOp IntVec 16 W16) = 867-primOpTag (VecReadByteArrayOp IntVec 8 W32) = 868-primOpTag (VecReadByteArrayOp IntVec 4 W64) = 869-primOpTag (VecReadByteArrayOp IntVec 64 W8) = 870-primOpTag (VecReadByteArrayOp IntVec 32 W16) = 871-primOpTag (VecReadByteArrayOp IntVec 16 W32) = 872-primOpTag (VecReadByteArrayOp IntVec 8 W64) = 873-primOpTag (VecReadByteArrayOp WordVec 16 W8) = 874-primOpTag (VecReadByteArrayOp WordVec 8 W16) = 875-primOpTag (VecReadByteArrayOp WordVec 4 W32) = 876-primOpTag (VecReadByteArrayOp WordVec 2 W64) = 877-primOpTag (VecReadByteArrayOp WordVec 32 W8) = 878-primOpTag (VecReadByteArrayOp WordVec 16 W16) = 879-primOpTag (VecReadByteArrayOp WordVec 8 W32) = 880-primOpTag (VecReadByteArrayOp WordVec 4 W64) = 881-primOpTag (VecReadByteArrayOp WordVec 64 W8) = 882-primOpTag (VecReadByteArrayOp WordVec 32 W16) = 883-primOpTag (VecReadByteArrayOp WordVec 16 W32) = 884-primOpTag (VecReadByteArrayOp WordVec 8 W64) = 885-primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 886-primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 887-primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 888-primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 889-primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 890-primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 891-primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 892-primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 893-primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 894-primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 895-primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 896-primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 897-primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 898-primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 899-primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 900-primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 901-primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 902-primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 903-primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 904-primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 905-primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 906-primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 907-primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 908-primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 909-primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 910-primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 911-primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 912-primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 913-primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 914-primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 915-primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 916-primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 917-primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 918-primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 919-primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 920-primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 921-primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 922-primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 923-primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 924-primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 925-primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 926-primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 927-primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 928-primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 929-primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 930-primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 931-primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 932-primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 933-primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 934-primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 935-primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 936-primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 937-primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 938-primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 939-primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 940-primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 941-primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 942-primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 943-primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 944-primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 945-primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 946-primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 947-primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 948-primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 949-primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 950-primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 951-primOpTag (VecReadOffAddrOp IntVec 16 W8) = 952-primOpTag (VecReadOffAddrOp IntVec 8 W16) = 953-primOpTag (VecReadOffAddrOp IntVec 4 W32) = 954-primOpTag (VecReadOffAddrOp IntVec 2 W64) = 955-primOpTag (VecReadOffAddrOp IntVec 32 W8) = 956-primOpTag (VecReadOffAddrOp IntVec 16 W16) = 957-primOpTag (VecReadOffAddrOp IntVec 8 W32) = 958-primOpTag (VecReadOffAddrOp IntVec 4 W64) = 959-primOpTag (VecReadOffAddrOp IntVec 64 W8) = 960-primOpTag (VecReadOffAddrOp IntVec 32 W16) = 961-primOpTag (VecReadOffAddrOp IntVec 16 W32) = 962-primOpTag (VecReadOffAddrOp IntVec 8 W64) = 963-primOpTag (VecReadOffAddrOp WordVec 16 W8) = 964-primOpTag (VecReadOffAddrOp WordVec 8 W16) = 965-primOpTag (VecReadOffAddrOp WordVec 4 W32) = 966-primOpTag (VecReadOffAddrOp WordVec 2 W64) = 967-primOpTag (VecReadOffAddrOp WordVec 32 W8) = 968-primOpTag (VecReadOffAddrOp WordVec 16 W16) = 969-primOpTag (VecReadOffAddrOp WordVec 8 W32) = 970-primOpTag (VecReadOffAddrOp WordVec 4 W64) = 971-primOpTag (VecReadOffAddrOp WordVec 64 W8) = 972-primOpTag (VecReadOffAddrOp WordVec 32 W16) = 973-primOpTag (VecReadOffAddrOp WordVec 16 W32) = 974-primOpTag (VecReadOffAddrOp WordVec 8 W64) = 975-primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 976-primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 977-primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 978-primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 979-primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 980-primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 981-primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 982-primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 983-primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 984-primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 985-primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 986-primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 987-primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 988-primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 989-primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 990-primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 991-primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 992-primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 993-primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 994-primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 995-primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 996-primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 997-primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 998-primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 999-primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 1000-primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 1001-primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 1002-primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 1003-primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1004-primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1005-primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1006-primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1007-primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1008-primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1009-primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1010-primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1011-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1012-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1013-primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1014-primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1015-primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1016-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1017-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1018-primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1019-primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1020-primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1021-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1022-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1023-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1024-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1025-primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1026-primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1027-primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1028-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1029-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1030-primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1031-primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1032-primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1033-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1034-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1035-primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1036-primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1037-primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1038-primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1039-primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1040-primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1041-primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1042-primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1043-primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1044-primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1045-primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1046-primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1047-primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1048-primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1049-primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1050-primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1051-primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1052-primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1053-primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1054-primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1055-primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1056-primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1057-primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1058-primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1059-primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1060-primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1061-primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1062-primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1063-primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1064-primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1065-primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1066-primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1067-primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1068-primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1069-primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1070-primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1071-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1072-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1073-primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1074-primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1075-primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1076-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1077-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1078-primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1079-primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1080-primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1081-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1082-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1083-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1084-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1085-primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1086-primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1087-primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1088-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1089-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1090-primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1091-primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1092-primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1093-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1094-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1095-primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1096-primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1097-primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1098-primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1099-primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1100-primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1101-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1102-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1103-primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1104-primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1105-primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1106-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1107-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1108-primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1109-primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1110-primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1111-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1112-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1113-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1114-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1115-primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1116-primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1117-primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1118-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1119-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1120-primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1121-primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1122-primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1123-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1124-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1125-primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1126-primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1127-primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1128-primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1129-primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1130-primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1131-primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1132-primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1133-primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1134-primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1135-primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1136-primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1137-primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1138-primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1139-primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1140-primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1141-primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1142-primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1143-primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1144-primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1145-primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1146-primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1147-primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1148-primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1149-primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1150-primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1151-primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1152-primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1153-primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1154-primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1155-primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1156-primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1157-primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1158-primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1159-primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1160-primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1161-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1162-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1163-primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1164-primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1165-primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1166-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1167-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1168-primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1169-primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1170-primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1171-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1172-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1173-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1174-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1175-primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1176-primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1177-primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1178-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1179-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1180-primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1181-primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1182-primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1183-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1184-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1185-primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1186-primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1187-primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1188-primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1189-primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1190-primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1191-primOpTag PrefetchByteArrayOp3 = 1192-primOpTag PrefetchMutableByteArrayOp3 = 1193-primOpTag PrefetchAddrOp3 = 1194-primOpTag PrefetchValueOp3 = 1195-primOpTag PrefetchByteArrayOp2 = 1196-primOpTag PrefetchMutableByteArrayOp2 = 1197-primOpTag PrefetchAddrOp2 = 1198-primOpTag PrefetchValueOp2 = 1199-primOpTag PrefetchByteArrayOp1 = 1200-primOpTag PrefetchMutableByteArrayOp1 = 1201-primOpTag PrefetchAddrOp1 = 1202-primOpTag PrefetchValueOp1 = 1203-primOpTag PrefetchByteArrayOp0 = 1204-primOpTag PrefetchMutableByteArrayOp0 = 1205-primOpTag PrefetchAddrOp0 = 1206-primOpTag PrefetchValueOp0 = 1207+maxPrimOpTag = 1206+primOpTag :: PrimOp -> Int+primOpTag CharGtOp = 1+primOpTag CharGeOp = 2+primOpTag CharEqOp = 3+primOpTag CharNeOp = 4+primOpTag CharLtOp = 5+primOpTag CharLeOp = 6+primOpTag OrdOp = 7+primOpTag Int8Extend = 8+primOpTag Int8Narrow = 9+primOpTag Int8NegOp = 10+primOpTag Int8AddOp = 11+primOpTag Int8SubOp = 12+primOpTag Int8MulOp = 13+primOpTag Int8QuotOp = 14+primOpTag Int8RemOp = 15+primOpTag Int8QuotRemOp = 16+primOpTag Int8EqOp = 17+primOpTag Int8GeOp = 18+primOpTag Int8GtOp = 19+primOpTag Int8LeOp = 20+primOpTag Int8LtOp = 21+primOpTag Int8NeOp = 22+primOpTag Word8Extend = 23+primOpTag Word8Narrow = 24+primOpTag Word8NotOp = 25+primOpTag Word8AddOp = 26+primOpTag Word8SubOp = 27+primOpTag Word8MulOp = 28+primOpTag Word8QuotOp = 29+primOpTag Word8RemOp = 30+primOpTag Word8QuotRemOp = 31+primOpTag Word8EqOp = 32+primOpTag Word8GeOp = 33+primOpTag Word8GtOp = 34+primOpTag Word8LeOp = 35+primOpTag Word8LtOp = 36+primOpTag Word8NeOp = 37+primOpTag Int16Extend = 38+primOpTag Int16Narrow = 39+primOpTag Int16NegOp = 40+primOpTag Int16AddOp = 41+primOpTag Int16SubOp = 42+primOpTag Int16MulOp = 43+primOpTag Int16QuotOp = 44+primOpTag Int16RemOp = 45+primOpTag Int16QuotRemOp = 46+primOpTag Int16EqOp = 47+primOpTag Int16GeOp = 48+primOpTag Int16GtOp = 49+primOpTag Int16LeOp = 50+primOpTag Int16LtOp = 51+primOpTag Int16NeOp = 52+primOpTag Word16Extend = 53+primOpTag Word16Narrow = 54+primOpTag Word16NotOp = 55+primOpTag Word16AddOp = 56+primOpTag Word16SubOp = 57+primOpTag Word16MulOp = 58+primOpTag Word16QuotOp = 59+primOpTag Word16RemOp = 60+primOpTag Word16QuotRemOp = 61+primOpTag Word16EqOp = 62+primOpTag Word16GeOp = 63+primOpTag Word16GtOp = 64+primOpTag Word16LeOp = 65+primOpTag Word16LtOp = 66+primOpTag Word16NeOp = 67+primOpTag IntAddOp = 68+primOpTag IntSubOp = 69+primOpTag IntMulOp = 70+primOpTag IntMul2Op = 71+primOpTag IntMulMayOfloOp = 72+primOpTag IntQuotOp = 73+primOpTag IntRemOp = 74+primOpTag IntQuotRemOp = 75+primOpTag AndIOp = 76+primOpTag OrIOp = 77+primOpTag XorIOp = 78+primOpTag NotIOp = 79+primOpTag IntNegOp = 80+primOpTag IntAddCOp = 81+primOpTag IntSubCOp = 82+primOpTag IntGtOp = 83+primOpTag IntGeOp = 84+primOpTag IntEqOp = 85+primOpTag IntNeOp = 86+primOpTag IntLtOp = 87+primOpTag IntLeOp = 88+primOpTag ChrOp = 89+primOpTag Int2WordOp = 90+primOpTag Int2FloatOp = 91+primOpTag Int2DoubleOp = 92+primOpTag Word2FloatOp = 93+primOpTag Word2DoubleOp = 94+primOpTag ISllOp = 95+primOpTag ISraOp = 96+primOpTag ISrlOp = 97+primOpTag WordAddOp = 98+primOpTag WordAddCOp = 99+primOpTag WordSubCOp = 100+primOpTag WordAdd2Op = 101+primOpTag WordSubOp = 102+primOpTag WordMulOp = 103+primOpTag WordMul2Op = 104+primOpTag WordQuotOp = 105+primOpTag WordRemOp = 106+primOpTag WordQuotRemOp = 107+primOpTag WordQuotRem2Op = 108+primOpTag AndOp = 109+primOpTag OrOp = 110+primOpTag XorOp = 111+primOpTag NotOp = 112+primOpTag SllOp = 113+primOpTag SrlOp = 114+primOpTag Word2IntOp = 115+primOpTag WordGtOp = 116+primOpTag WordGeOp = 117+primOpTag WordEqOp = 118+primOpTag WordNeOp = 119+primOpTag WordLtOp = 120+primOpTag WordLeOp = 121+primOpTag PopCnt8Op = 122+primOpTag PopCnt16Op = 123+primOpTag PopCnt32Op = 124+primOpTag PopCnt64Op = 125+primOpTag PopCntOp = 126+primOpTag Pdep8Op = 127+primOpTag Pdep16Op = 128+primOpTag Pdep32Op = 129+primOpTag Pdep64Op = 130+primOpTag PdepOp = 131+primOpTag Pext8Op = 132+primOpTag Pext16Op = 133+primOpTag Pext32Op = 134+primOpTag Pext64Op = 135+primOpTag PextOp = 136+primOpTag Clz8Op = 137+primOpTag Clz16Op = 138+primOpTag Clz32Op = 139+primOpTag Clz64Op = 140+primOpTag ClzOp = 141+primOpTag Ctz8Op = 142+primOpTag Ctz16Op = 143+primOpTag Ctz32Op = 144+primOpTag Ctz64Op = 145+primOpTag CtzOp = 146+primOpTag BSwap16Op = 147+primOpTag BSwap32Op = 148+primOpTag BSwap64Op = 149+primOpTag BSwapOp = 150+primOpTag BRev8Op = 151+primOpTag BRev16Op = 152+primOpTag BRev32Op = 153+primOpTag BRev64Op = 154+primOpTag BRevOp = 155+primOpTag Narrow8IntOp = 156+primOpTag Narrow16IntOp = 157+primOpTag Narrow32IntOp = 158+primOpTag Narrow8WordOp = 159+primOpTag Narrow16WordOp = 160+primOpTag Narrow32WordOp = 161+primOpTag DoubleGtOp = 162+primOpTag DoubleGeOp = 163+primOpTag DoubleEqOp = 164+primOpTag DoubleNeOp = 165+primOpTag DoubleLtOp = 166+primOpTag DoubleLeOp = 167+primOpTag DoubleAddOp = 168+primOpTag DoubleSubOp = 169+primOpTag DoubleMulOp = 170+primOpTag DoubleDivOp = 171+primOpTag DoubleNegOp = 172+primOpTag DoubleFabsOp = 173+primOpTag Double2IntOp = 174+primOpTag Double2FloatOp = 175+primOpTag DoubleExpOp = 176+primOpTag DoubleExpM1Op = 177+primOpTag DoubleLogOp = 178+primOpTag DoubleLog1POp = 179+primOpTag DoubleSqrtOp = 180+primOpTag DoubleSinOp = 181+primOpTag DoubleCosOp = 182+primOpTag DoubleTanOp = 183+primOpTag DoubleAsinOp = 184+primOpTag DoubleAcosOp = 185+primOpTag DoubleAtanOp = 186+primOpTag DoubleSinhOp = 187+primOpTag DoubleCoshOp = 188+primOpTag DoubleTanhOp = 189+primOpTag DoubleAsinhOp = 190+primOpTag DoubleAcoshOp = 191+primOpTag DoubleAtanhOp = 192+primOpTag DoublePowerOp = 193+primOpTag DoubleDecode_2IntOp = 194+primOpTag DoubleDecode_Int64Op = 195+primOpTag FloatGtOp = 196+primOpTag FloatGeOp = 197+primOpTag FloatEqOp = 198+primOpTag FloatNeOp = 199+primOpTag FloatLtOp = 200+primOpTag FloatLeOp = 201+primOpTag FloatAddOp = 202+primOpTag FloatSubOp = 203+primOpTag FloatMulOp = 204+primOpTag FloatDivOp = 205+primOpTag FloatNegOp = 206+primOpTag FloatFabsOp = 207+primOpTag Float2IntOp = 208+primOpTag FloatExpOp = 209+primOpTag FloatExpM1Op = 210+primOpTag FloatLogOp = 211+primOpTag FloatLog1POp = 212+primOpTag FloatSqrtOp = 213+primOpTag FloatSinOp = 214+primOpTag FloatCosOp = 215+primOpTag FloatTanOp = 216+primOpTag FloatAsinOp = 217+primOpTag FloatAcosOp = 218+primOpTag FloatAtanOp = 219+primOpTag FloatSinhOp = 220+primOpTag FloatCoshOp = 221+primOpTag FloatTanhOp = 222+primOpTag FloatAsinhOp = 223+primOpTag FloatAcoshOp = 224+primOpTag FloatAtanhOp = 225+primOpTag FloatPowerOp = 226+primOpTag Float2DoubleOp = 227+primOpTag FloatDecode_IntOp = 228+primOpTag NewArrayOp = 229+primOpTag SameMutableArrayOp = 230+primOpTag ReadArrayOp = 231+primOpTag WriteArrayOp = 232+primOpTag SizeofArrayOp = 233+primOpTag SizeofMutableArrayOp = 234+primOpTag IndexArrayOp = 235+primOpTag UnsafeFreezeArrayOp = 236+primOpTag UnsafeThawArrayOp = 237+primOpTag CopyArrayOp = 238+primOpTag CopyMutableArrayOp = 239+primOpTag CloneArrayOp = 240+primOpTag CloneMutableArrayOp = 241+primOpTag FreezeArrayOp = 242+primOpTag ThawArrayOp = 243+primOpTag CasArrayOp = 244+primOpTag NewSmallArrayOp = 245+primOpTag SameSmallMutableArrayOp = 246+primOpTag ShrinkSmallMutableArrayOp_Char = 247+primOpTag ReadSmallArrayOp = 248+primOpTag WriteSmallArrayOp = 249+primOpTag SizeofSmallArrayOp = 250+primOpTag SizeofSmallMutableArrayOp = 251+primOpTag GetSizeofSmallMutableArrayOp = 252+primOpTag IndexSmallArrayOp = 253+primOpTag UnsafeFreezeSmallArrayOp = 254+primOpTag UnsafeThawSmallArrayOp = 255+primOpTag CopySmallArrayOp = 256+primOpTag CopySmallMutableArrayOp = 257+primOpTag CloneSmallArrayOp = 258+primOpTag CloneSmallMutableArrayOp = 259+primOpTag FreezeSmallArrayOp = 260+primOpTag ThawSmallArrayOp = 261+primOpTag CasSmallArrayOp = 262+primOpTag NewByteArrayOp_Char = 263+primOpTag NewPinnedByteArrayOp_Char = 264+primOpTag NewAlignedPinnedByteArrayOp_Char = 265+primOpTag MutableByteArrayIsPinnedOp = 266+primOpTag ByteArrayIsPinnedOp = 267+primOpTag ByteArrayContents_Char = 268+primOpTag SameMutableByteArrayOp = 269+primOpTag ShrinkMutableByteArrayOp_Char = 270+primOpTag ResizeMutableByteArrayOp_Char = 271+primOpTag UnsafeFreezeByteArrayOp = 272+primOpTag SizeofByteArrayOp = 273+primOpTag SizeofMutableByteArrayOp = 274+primOpTag GetSizeofMutableByteArrayOp = 275+primOpTag IndexByteArrayOp_Char = 276+primOpTag IndexByteArrayOp_WideChar = 277+primOpTag IndexByteArrayOp_Int = 278+primOpTag IndexByteArrayOp_Word = 279+primOpTag IndexByteArrayOp_Addr = 280+primOpTag IndexByteArrayOp_Float = 281+primOpTag IndexByteArrayOp_Double = 282+primOpTag IndexByteArrayOp_StablePtr = 283+primOpTag IndexByteArrayOp_Int8 = 284+primOpTag IndexByteArrayOp_Int16 = 285+primOpTag IndexByteArrayOp_Int32 = 286+primOpTag IndexByteArrayOp_Int64 = 287+primOpTag IndexByteArrayOp_Word8 = 288+primOpTag IndexByteArrayOp_Word16 = 289+primOpTag IndexByteArrayOp_Word32 = 290+primOpTag IndexByteArrayOp_Word64 = 291+primOpTag IndexByteArrayOp_Word8AsChar = 292+primOpTag IndexByteArrayOp_Word8AsWideChar = 293+primOpTag IndexByteArrayOp_Word8AsAddr = 294+primOpTag IndexByteArrayOp_Word8AsFloat = 295+primOpTag IndexByteArrayOp_Word8AsDouble = 296+primOpTag IndexByteArrayOp_Word8AsStablePtr = 297+primOpTag IndexByteArrayOp_Word8AsInt16 = 298+primOpTag IndexByteArrayOp_Word8AsInt32 = 299+primOpTag IndexByteArrayOp_Word8AsInt64 = 300+primOpTag IndexByteArrayOp_Word8AsInt = 301+primOpTag IndexByteArrayOp_Word8AsWord16 = 302+primOpTag IndexByteArrayOp_Word8AsWord32 = 303+primOpTag IndexByteArrayOp_Word8AsWord64 = 304+primOpTag IndexByteArrayOp_Word8AsWord = 305+primOpTag ReadByteArrayOp_Char = 306+primOpTag ReadByteArrayOp_WideChar = 307+primOpTag ReadByteArrayOp_Int = 308+primOpTag ReadByteArrayOp_Word = 309+primOpTag ReadByteArrayOp_Addr = 310+primOpTag ReadByteArrayOp_Float = 311+primOpTag ReadByteArrayOp_Double = 312+primOpTag ReadByteArrayOp_StablePtr = 313+primOpTag ReadByteArrayOp_Int8 = 314+primOpTag ReadByteArrayOp_Int16 = 315+primOpTag ReadByteArrayOp_Int32 = 316+primOpTag ReadByteArrayOp_Int64 = 317+primOpTag ReadByteArrayOp_Word8 = 318+primOpTag ReadByteArrayOp_Word16 = 319+primOpTag ReadByteArrayOp_Word32 = 320+primOpTag ReadByteArrayOp_Word64 = 321+primOpTag ReadByteArrayOp_Word8AsChar = 322+primOpTag ReadByteArrayOp_Word8AsWideChar = 323+primOpTag ReadByteArrayOp_Word8AsAddr = 324+primOpTag ReadByteArrayOp_Word8AsFloat = 325+primOpTag ReadByteArrayOp_Word8AsDouble = 326+primOpTag ReadByteArrayOp_Word8AsStablePtr = 327+primOpTag ReadByteArrayOp_Word8AsInt16 = 328+primOpTag ReadByteArrayOp_Word8AsInt32 = 329+primOpTag ReadByteArrayOp_Word8AsInt64 = 330+primOpTag ReadByteArrayOp_Word8AsInt = 331+primOpTag ReadByteArrayOp_Word8AsWord16 = 332+primOpTag ReadByteArrayOp_Word8AsWord32 = 333+primOpTag ReadByteArrayOp_Word8AsWord64 = 334+primOpTag ReadByteArrayOp_Word8AsWord = 335+primOpTag WriteByteArrayOp_Char = 336+primOpTag WriteByteArrayOp_WideChar = 337+primOpTag WriteByteArrayOp_Int = 338+primOpTag WriteByteArrayOp_Word = 339+primOpTag WriteByteArrayOp_Addr = 340+primOpTag WriteByteArrayOp_Float = 341+primOpTag WriteByteArrayOp_Double = 342+primOpTag WriteByteArrayOp_StablePtr = 343+primOpTag WriteByteArrayOp_Int8 = 344+primOpTag WriteByteArrayOp_Int16 = 345+primOpTag WriteByteArrayOp_Int32 = 346+primOpTag WriteByteArrayOp_Int64 = 347+primOpTag WriteByteArrayOp_Word8 = 348+primOpTag WriteByteArrayOp_Word16 = 349+primOpTag WriteByteArrayOp_Word32 = 350+primOpTag WriteByteArrayOp_Word64 = 351+primOpTag WriteByteArrayOp_Word8AsChar = 352+primOpTag WriteByteArrayOp_Word8AsWideChar = 353+primOpTag WriteByteArrayOp_Word8AsAddr = 354+primOpTag WriteByteArrayOp_Word8AsFloat = 355+primOpTag WriteByteArrayOp_Word8AsDouble = 356+primOpTag WriteByteArrayOp_Word8AsStablePtr = 357+primOpTag WriteByteArrayOp_Word8AsInt16 = 358+primOpTag WriteByteArrayOp_Word8AsInt32 = 359+primOpTag WriteByteArrayOp_Word8AsInt64 = 360+primOpTag WriteByteArrayOp_Word8AsInt = 361+primOpTag WriteByteArrayOp_Word8AsWord16 = 362+primOpTag WriteByteArrayOp_Word8AsWord32 = 363+primOpTag WriteByteArrayOp_Word8AsWord64 = 364+primOpTag WriteByteArrayOp_Word8AsWord = 365+primOpTag CompareByteArraysOp = 366+primOpTag CopyByteArrayOp = 367+primOpTag CopyMutableByteArrayOp = 368+primOpTag CopyByteArrayToAddrOp = 369+primOpTag CopyMutableByteArrayToAddrOp = 370+primOpTag CopyAddrToByteArrayOp = 371+primOpTag SetByteArrayOp = 372+primOpTag AtomicReadByteArrayOp_Int = 373+primOpTag AtomicWriteByteArrayOp_Int = 374+primOpTag CasByteArrayOp_Int = 375+primOpTag FetchAddByteArrayOp_Int = 376+primOpTag FetchSubByteArrayOp_Int = 377+primOpTag FetchAndByteArrayOp_Int = 378+primOpTag FetchNandByteArrayOp_Int = 379+primOpTag FetchOrByteArrayOp_Int = 380+primOpTag FetchXorByteArrayOp_Int = 381+primOpTag NewArrayArrayOp = 382+primOpTag SameMutableArrayArrayOp = 383+primOpTag UnsafeFreezeArrayArrayOp = 384+primOpTag SizeofArrayArrayOp = 385+primOpTag SizeofMutableArrayArrayOp = 386+primOpTag IndexArrayArrayOp_ByteArray = 387+primOpTag IndexArrayArrayOp_ArrayArray = 388+primOpTag ReadArrayArrayOp_ByteArray = 389+primOpTag ReadArrayArrayOp_MutableByteArray = 390+primOpTag ReadArrayArrayOp_ArrayArray = 391+primOpTag ReadArrayArrayOp_MutableArrayArray = 392+primOpTag WriteArrayArrayOp_ByteArray = 393+primOpTag WriteArrayArrayOp_MutableByteArray = 394+primOpTag WriteArrayArrayOp_ArrayArray = 395+primOpTag WriteArrayArrayOp_MutableArrayArray = 396+primOpTag CopyArrayArrayOp = 397+primOpTag CopyMutableArrayArrayOp = 398+primOpTag AddrAddOp = 399+primOpTag AddrSubOp = 400+primOpTag AddrRemOp = 401+primOpTag Addr2IntOp = 402+primOpTag Int2AddrOp = 403+primOpTag AddrGtOp = 404+primOpTag AddrGeOp = 405+primOpTag AddrEqOp = 406+primOpTag AddrNeOp = 407+primOpTag AddrLtOp = 408+primOpTag AddrLeOp = 409+primOpTag IndexOffAddrOp_Char = 410+primOpTag IndexOffAddrOp_WideChar = 411+primOpTag IndexOffAddrOp_Int = 412+primOpTag IndexOffAddrOp_Word = 413+primOpTag IndexOffAddrOp_Addr = 414+primOpTag IndexOffAddrOp_Float = 415+primOpTag IndexOffAddrOp_Double = 416+primOpTag IndexOffAddrOp_StablePtr = 417+primOpTag IndexOffAddrOp_Int8 = 418+primOpTag IndexOffAddrOp_Int16 = 419+primOpTag IndexOffAddrOp_Int32 = 420+primOpTag IndexOffAddrOp_Int64 = 421+primOpTag IndexOffAddrOp_Word8 = 422+primOpTag IndexOffAddrOp_Word16 = 423+primOpTag IndexOffAddrOp_Word32 = 424+primOpTag IndexOffAddrOp_Word64 = 425+primOpTag ReadOffAddrOp_Char = 426+primOpTag ReadOffAddrOp_WideChar = 427+primOpTag ReadOffAddrOp_Int = 428+primOpTag ReadOffAddrOp_Word = 429+primOpTag ReadOffAddrOp_Addr = 430+primOpTag ReadOffAddrOp_Float = 431+primOpTag ReadOffAddrOp_Double = 432+primOpTag ReadOffAddrOp_StablePtr = 433+primOpTag ReadOffAddrOp_Int8 = 434+primOpTag ReadOffAddrOp_Int16 = 435+primOpTag ReadOffAddrOp_Int32 = 436+primOpTag ReadOffAddrOp_Int64 = 437+primOpTag ReadOffAddrOp_Word8 = 438+primOpTag ReadOffAddrOp_Word16 = 439+primOpTag ReadOffAddrOp_Word32 = 440+primOpTag ReadOffAddrOp_Word64 = 441+primOpTag WriteOffAddrOp_Char = 442+primOpTag WriteOffAddrOp_WideChar = 443+primOpTag WriteOffAddrOp_Int = 444+primOpTag WriteOffAddrOp_Word = 445+primOpTag WriteOffAddrOp_Addr = 446+primOpTag WriteOffAddrOp_Float = 447+primOpTag WriteOffAddrOp_Double = 448+primOpTag WriteOffAddrOp_StablePtr = 449+primOpTag WriteOffAddrOp_Int8 = 450+primOpTag WriteOffAddrOp_Int16 = 451+primOpTag WriteOffAddrOp_Int32 = 452+primOpTag WriteOffAddrOp_Int64 = 453+primOpTag WriteOffAddrOp_Word8 = 454+primOpTag WriteOffAddrOp_Word16 = 455+primOpTag WriteOffAddrOp_Word32 = 456+primOpTag WriteOffAddrOp_Word64 = 457+primOpTag InterlockedExchange_Addr = 458+primOpTag InterlockedExchange_Int = 459+primOpTag NewMutVarOp = 460+primOpTag ReadMutVarOp = 461+primOpTag WriteMutVarOp = 462+primOpTag SameMutVarOp = 463+primOpTag AtomicModifyMutVar2Op = 464+primOpTag AtomicModifyMutVar_Op = 465+primOpTag CasMutVarOp = 466+primOpTag CatchOp = 467+primOpTag RaiseOp = 468+primOpTag RaiseIOOp = 469+primOpTag MaskAsyncExceptionsOp = 470+primOpTag MaskUninterruptibleOp = 471+primOpTag UnmaskAsyncExceptionsOp = 472+primOpTag MaskStatus = 473+primOpTag AtomicallyOp = 474+primOpTag RetryOp = 475+primOpTag CatchRetryOp = 476+primOpTag CatchSTMOp = 477+primOpTag NewTVarOp = 478+primOpTag ReadTVarOp = 479+primOpTag ReadTVarIOOp = 480+primOpTag WriteTVarOp = 481+primOpTag SameTVarOp = 482+primOpTag NewMVarOp = 483+primOpTag TakeMVarOp = 484+primOpTag TryTakeMVarOp = 485+primOpTag PutMVarOp = 486+primOpTag TryPutMVarOp = 487+primOpTag ReadMVarOp = 488+primOpTag TryReadMVarOp = 489+primOpTag SameMVarOp = 490+primOpTag IsEmptyMVarOp = 491+primOpTag DelayOp = 492+primOpTag WaitReadOp = 493+primOpTag WaitWriteOp = 494+primOpTag ForkOp = 495+primOpTag ForkOnOp = 496+primOpTag KillThreadOp = 497+primOpTag YieldOp = 498+primOpTag MyThreadIdOp = 499+primOpTag LabelThreadOp = 500+primOpTag IsCurrentThreadBoundOp = 501+primOpTag NoDuplicateOp = 502+primOpTag ThreadStatusOp = 503+primOpTag MkWeakOp = 504+primOpTag MkWeakNoFinalizerOp = 505+primOpTag AddCFinalizerToWeakOp = 506+primOpTag DeRefWeakOp = 507+primOpTag FinalizeWeakOp = 508+primOpTag TouchOp = 509+primOpTag MakeStablePtrOp = 510+primOpTag DeRefStablePtrOp = 511+primOpTag EqStablePtrOp = 512+primOpTag MakeStableNameOp = 513+primOpTag EqStableNameOp = 514+primOpTag StableNameToIntOp = 515+primOpTag CompactNewOp = 516+primOpTag CompactResizeOp = 517+primOpTag CompactContainsOp = 518+primOpTag CompactContainsAnyOp = 519+primOpTag CompactGetFirstBlockOp = 520+primOpTag CompactGetNextBlockOp = 521+primOpTag CompactAllocateBlockOp = 522+primOpTag CompactFixupPointersOp = 523+primOpTag CompactAdd = 524+primOpTag CompactAddWithSharing = 525+primOpTag CompactSize = 526+primOpTag ReallyUnsafePtrEqualityOp = 527+primOpTag ParOp = 528+primOpTag SparkOp = 529+primOpTag SeqOp = 530+primOpTag GetSparkOp = 531+primOpTag NumSparks = 532+primOpTag DataToTagOp = 533+primOpTag TagToEnumOp = 534+primOpTag AddrToAnyOp = 535+primOpTag AnyToAddrOp = 536+primOpTag MkApUpd0_Op = 537+primOpTag NewBCOOp = 538+primOpTag UnpackClosureOp = 539+primOpTag ClosureSizeOp = 540+primOpTag GetApStackValOp = 541+primOpTag GetCCSOfOp = 542+primOpTag GetCurrentCCSOp = 543+primOpTag ClearCCSOp = 544+primOpTag TraceEventOp = 545+primOpTag TraceEventBinaryOp = 546+primOpTag TraceMarkerOp = 547+primOpTag SetThreadAllocationCounter = 548+primOpTag (VecBroadcastOp IntVec 16 W8) = 549+primOpTag (VecBroadcastOp IntVec 8 W16) = 550+primOpTag (VecBroadcastOp IntVec 4 W32) = 551+primOpTag (VecBroadcastOp IntVec 2 W64) = 552+primOpTag (VecBroadcastOp IntVec 32 W8) = 553+primOpTag (VecBroadcastOp IntVec 16 W16) = 554+primOpTag (VecBroadcastOp IntVec 8 W32) = 555+primOpTag (VecBroadcastOp IntVec 4 W64) = 556+primOpTag (VecBroadcastOp IntVec 64 W8) = 557+primOpTag (VecBroadcastOp IntVec 32 W16) = 558+primOpTag (VecBroadcastOp IntVec 16 W32) = 559+primOpTag (VecBroadcastOp IntVec 8 W64) = 560+primOpTag (VecBroadcastOp WordVec 16 W8) = 561+primOpTag (VecBroadcastOp WordVec 8 W16) = 562+primOpTag (VecBroadcastOp WordVec 4 W32) = 563+primOpTag (VecBroadcastOp WordVec 2 W64) = 564+primOpTag (VecBroadcastOp WordVec 32 W8) = 565+primOpTag (VecBroadcastOp WordVec 16 W16) = 566+primOpTag (VecBroadcastOp WordVec 8 W32) = 567+primOpTag (VecBroadcastOp WordVec 4 W64) = 568+primOpTag (VecBroadcastOp WordVec 64 W8) = 569+primOpTag (VecBroadcastOp WordVec 32 W16) = 570+primOpTag (VecBroadcastOp WordVec 16 W32) = 571+primOpTag (VecBroadcastOp WordVec 8 W64) = 572+primOpTag (VecBroadcastOp FloatVec 4 W32) = 573+primOpTag (VecBroadcastOp FloatVec 2 W64) = 574+primOpTag (VecBroadcastOp FloatVec 8 W32) = 575+primOpTag (VecBroadcastOp FloatVec 4 W64) = 576+primOpTag (VecBroadcastOp FloatVec 16 W32) = 577+primOpTag (VecBroadcastOp FloatVec 8 W64) = 578+primOpTag (VecPackOp IntVec 16 W8) = 579+primOpTag (VecPackOp IntVec 8 W16) = 580+primOpTag (VecPackOp IntVec 4 W32) = 581+primOpTag (VecPackOp IntVec 2 W64) = 582+primOpTag (VecPackOp IntVec 32 W8) = 583+primOpTag (VecPackOp IntVec 16 W16) = 584+primOpTag (VecPackOp IntVec 8 W32) = 585+primOpTag (VecPackOp IntVec 4 W64) = 586+primOpTag (VecPackOp IntVec 64 W8) = 587+primOpTag (VecPackOp IntVec 32 W16) = 588+primOpTag (VecPackOp IntVec 16 W32) = 589+primOpTag (VecPackOp IntVec 8 W64) = 590+primOpTag (VecPackOp WordVec 16 W8) = 591+primOpTag (VecPackOp WordVec 8 W16) = 592+primOpTag (VecPackOp WordVec 4 W32) = 593+primOpTag (VecPackOp WordVec 2 W64) = 594+primOpTag (VecPackOp WordVec 32 W8) = 595+primOpTag (VecPackOp WordVec 16 W16) = 596+primOpTag (VecPackOp WordVec 8 W32) = 597+primOpTag (VecPackOp WordVec 4 W64) = 598+primOpTag (VecPackOp WordVec 64 W8) = 599+primOpTag (VecPackOp WordVec 32 W16) = 600+primOpTag (VecPackOp WordVec 16 W32) = 601+primOpTag (VecPackOp WordVec 8 W64) = 602+primOpTag (VecPackOp FloatVec 4 W32) = 603+primOpTag (VecPackOp FloatVec 2 W64) = 604+primOpTag (VecPackOp FloatVec 8 W32) = 605+primOpTag (VecPackOp FloatVec 4 W64) = 606+primOpTag (VecPackOp FloatVec 16 W32) = 607+primOpTag (VecPackOp FloatVec 8 W64) = 608+primOpTag (VecUnpackOp IntVec 16 W8) = 609+primOpTag (VecUnpackOp IntVec 8 W16) = 610+primOpTag (VecUnpackOp IntVec 4 W32) = 611+primOpTag (VecUnpackOp IntVec 2 W64) = 612+primOpTag (VecUnpackOp IntVec 32 W8) = 613+primOpTag (VecUnpackOp IntVec 16 W16) = 614+primOpTag (VecUnpackOp IntVec 8 W32) = 615+primOpTag (VecUnpackOp IntVec 4 W64) = 616+primOpTag (VecUnpackOp IntVec 64 W8) = 617+primOpTag (VecUnpackOp IntVec 32 W16) = 618+primOpTag (VecUnpackOp IntVec 16 W32) = 619+primOpTag (VecUnpackOp IntVec 8 W64) = 620+primOpTag (VecUnpackOp WordVec 16 W8) = 621+primOpTag (VecUnpackOp WordVec 8 W16) = 622+primOpTag (VecUnpackOp WordVec 4 W32) = 623+primOpTag (VecUnpackOp WordVec 2 W64) = 624+primOpTag (VecUnpackOp WordVec 32 W8) = 625+primOpTag (VecUnpackOp WordVec 16 W16) = 626+primOpTag (VecUnpackOp WordVec 8 W32) = 627+primOpTag (VecUnpackOp WordVec 4 W64) = 628+primOpTag (VecUnpackOp WordVec 64 W8) = 629+primOpTag (VecUnpackOp WordVec 32 W16) = 630+primOpTag (VecUnpackOp WordVec 16 W32) = 631+primOpTag (VecUnpackOp WordVec 8 W64) = 632+primOpTag (VecUnpackOp FloatVec 4 W32) = 633+primOpTag (VecUnpackOp FloatVec 2 W64) = 634+primOpTag (VecUnpackOp FloatVec 8 W32) = 635+primOpTag (VecUnpackOp FloatVec 4 W64) = 636+primOpTag (VecUnpackOp FloatVec 16 W32) = 637+primOpTag (VecUnpackOp FloatVec 8 W64) = 638+primOpTag (VecInsertOp IntVec 16 W8) = 639+primOpTag (VecInsertOp IntVec 8 W16) = 640+primOpTag (VecInsertOp IntVec 4 W32) = 641+primOpTag (VecInsertOp IntVec 2 W64) = 642+primOpTag (VecInsertOp IntVec 32 W8) = 643+primOpTag (VecInsertOp IntVec 16 W16) = 644+primOpTag (VecInsertOp IntVec 8 W32) = 645+primOpTag (VecInsertOp IntVec 4 W64) = 646+primOpTag (VecInsertOp IntVec 64 W8) = 647+primOpTag (VecInsertOp IntVec 32 W16) = 648+primOpTag (VecInsertOp IntVec 16 W32) = 649+primOpTag (VecInsertOp IntVec 8 W64) = 650+primOpTag (VecInsertOp WordVec 16 W8) = 651+primOpTag (VecInsertOp WordVec 8 W16) = 652+primOpTag (VecInsertOp WordVec 4 W32) = 653+primOpTag (VecInsertOp WordVec 2 W64) = 654+primOpTag (VecInsertOp WordVec 32 W8) = 655+primOpTag (VecInsertOp WordVec 16 W16) = 656+primOpTag (VecInsertOp WordVec 8 W32) = 657+primOpTag (VecInsertOp WordVec 4 W64) = 658+primOpTag (VecInsertOp WordVec 64 W8) = 659+primOpTag (VecInsertOp WordVec 32 W16) = 660+primOpTag (VecInsertOp WordVec 16 W32) = 661+primOpTag (VecInsertOp WordVec 8 W64) = 662+primOpTag (VecInsertOp FloatVec 4 W32) = 663+primOpTag (VecInsertOp FloatVec 2 W64) = 664+primOpTag (VecInsertOp FloatVec 8 W32) = 665+primOpTag (VecInsertOp FloatVec 4 W64) = 666+primOpTag (VecInsertOp FloatVec 16 W32) = 667+primOpTag (VecInsertOp FloatVec 8 W64) = 668+primOpTag (VecAddOp IntVec 16 W8) = 669+primOpTag (VecAddOp IntVec 8 W16) = 670+primOpTag (VecAddOp IntVec 4 W32) = 671+primOpTag (VecAddOp IntVec 2 W64) = 672+primOpTag (VecAddOp IntVec 32 W8) = 673+primOpTag (VecAddOp IntVec 16 W16) = 674+primOpTag (VecAddOp IntVec 8 W32) = 675+primOpTag (VecAddOp IntVec 4 W64) = 676+primOpTag (VecAddOp IntVec 64 W8) = 677+primOpTag (VecAddOp IntVec 32 W16) = 678+primOpTag (VecAddOp IntVec 16 W32) = 679+primOpTag (VecAddOp IntVec 8 W64) = 680+primOpTag (VecAddOp WordVec 16 W8) = 681+primOpTag (VecAddOp WordVec 8 W16) = 682+primOpTag (VecAddOp WordVec 4 W32) = 683+primOpTag (VecAddOp WordVec 2 W64) = 684+primOpTag (VecAddOp WordVec 32 W8) = 685+primOpTag (VecAddOp WordVec 16 W16) = 686+primOpTag (VecAddOp WordVec 8 W32) = 687+primOpTag (VecAddOp WordVec 4 W64) = 688+primOpTag (VecAddOp WordVec 64 W8) = 689+primOpTag (VecAddOp WordVec 32 W16) = 690+primOpTag (VecAddOp WordVec 16 W32) = 691+primOpTag (VecAddOp WordVec 8 W64) = 692+primOpTag (VecAddOp FloatVec 4 W32) = 693+primOpTag (VecAddOp FloatVec 2 W64) = 694+primOpTag (VecAddOp FloatVec 8 W32) = 695+primOpTag (VecAddOp FloatVec 4 W64) = 696+primOpTag (VecAddOp FloatVec 16 W32) = 697+primOpTag (VecAddOp FloatVec 8 W64) = 698+primOpTag (VecSubOp IntVec 16 W8) = 699+primOpTag (VecSubOp IntVec 8 W16) = 700+primOpTag (VecSubOp IntVec 4 W32) = 701+primOpTag (VecSubOp IntVec 2 W64) = 702+primOpTag (VecSubOp IntVec 32 W8) = 703+primOpTag (VecSubOp IntVec 16 W16) = 704+primOpTag (VecSubOp IntVec 8 W32) = 705+primOpTag (VecSubOp IntVec 4 W64) = 706+primOpTag (VecSubOp IntVec 64 W8) = 707+primOpTag (VecSubOp IntVec 32 W16) = 708+primOpTag (VecSubOp IntVec 16 W32) = 709+primOpTag (VecSubOp IntVec 8 W64) = 710+primOpTag (VecSubOp WordVec 16 W8) = 711+primOpTag (VecSubOp WordVec 8 W16) = 712+primOpTag (VecSubOp WordVec 4 W32) = 713+primOpTag (VecSubOp WordVec 2 W64) = 714+primOpTag (VecSubOp WordVec 32 W8) = 715+primOpTag (VecSubOp WordVec 16 W16) = 716+primOpTag (VecSubOp WordVec 8 W32) = 717+primOpTag (VecSubOp WordVec 4 W64) = 718+primOpTag (VecSubOp WordVec 64 W8) = 719+primOpTag (VecSubOp WordVec 32 W16) = 720+primOpTag (VecSubOp WordVec 16 W32) = 721+primOpTag (VecSubOp WordVec 8 W64) = 722+primOpTag (VecSubOp FloatVec 4 W32) = 723+primOpTag (VecSubOp FloatVec 2 W64) = 724+primOpTag (VecSubOp FloatVec 8 W32) = 725+primOpTag (VecSubOp FloatVec 4 W64) = 726+primOpTag (VecSubOp FloatVec 16 W32) = 727+primOpTag (VecSubOp FloatVec 8 W64) = 728+primOpTag (VecMulOp IntVec 16 W8) = 729+primOpTag (VecMulOp IntVec 8 W16) = 730+primOpTag (VecMulOp IntVec 4 W32) = 731+primOpTag (VecMulOp IntVec 2 W64) = 732+primOpTag (VecMulOp IntVec 32 W8) = 733+primOpTag (VecMulOp IntVec 16 W16) = 734+primOpTag (VecMulOp IntVec 8 W32) = 735+primOpTag (VecMulOp IntVec 4 W64) = 736+primOpTag (VecMulOp IntVec 64 W8) = 737+primOpTag (VecMulOp IntVec 32 W16) = 738+primOpTag (VecMulOp IntVec 16 W32) = 739+primOpTag (VecMulOp IntVec 8 W64) = 740+primOpTag (VecMulOp WordVec 16 W8) = 741+primOpTag (VecMulOp WordVec 8 W16) = 742+primOpTag (VecMulOp WordVec 4 W32) = 743+primOpTag (VecMulOp WordVec 2 W64) = 744+primOpTag (VecMulOp WordVec 32 W8) = 745+primOpTag (VecMulOp WordVec 16 W16) = 746+primOpTag (VecMulOp WordVec 8 W32) = 747+primOpTag (VecMulOp WordVec 4 W64) = 748+primOpTag (VecMulOp WordVec 64 W8) = 749+primOpTag (VecMulOp WordVec 32 W16) = 750+primOpTag (VecMulOp WordVec 16 W32) = 751+primOpTag (VecMulOp WordVec 8 W64) = 752+primOpTag (VecMulOp FloatVec 4 W32) = 753+primOpTag (VecMulOp FloatVec 2 W64) = 754+primOpTag (VecMulOp FloatVec 8 W32) = 755+primOpTag (VecMulOp FloatVec 4 W64) = 756+primOpTag (VecMulOp FloatVec 16 W32) = 757+primOpTag (VecMulOp FloatVec 8 W64) = 758+primOpTag (VecDivOp FloatVec 4 W32) = 759+primOpTag (VecDivOp FloatVec 2 W64) = 760+primOpTag (VecDivOp FloatVec 8 W32) = 761+primOpTag (VecDivOp FloatVec 4 W64) = 762+primOpTag (VecDivOp FloatVec 16 W32) = 763+primOpTag (VecDivOp FloatVec 8 W64) = 764+primOpTag (VecQuotOp IntVec 16 W8) = 765+primOpTag (VecQuotOp IntVec 8 W16) = 766+primOpTag (VecQuotOp IntVec 4 W32) = 767+primOpTag (VecQuotOp IntVec 2 W64) = 768+primOpTag (VecQuotOp IntVec 32 W8) = 769+primOpTag (VecQuotOp IntVec 16 W16) = 770+primOpTag (VecQuotOp IntVec 8 W32) = 771+primOpTag (VecQuotOp IntVec 4 W64) = 772+primOpTag (VecQuotOp IntVec 64 W8) = 773+primOpTag (VecQuotOp IntVec 32 W16) = 774+primOpTag (VecQuotOp IntVec 16 W32) = 775+primOpTag (VecQuotOp IntVec 8 W64) = 776+primOpTag (VecQuotOp WordVec 16 W8) = 777+primOpTag (VecQuotOp WordVec 8 W16) = 778+primOpTag (VecQuotOp WordVec 4 W32) = 779+primOpTag (VecQuotOp WordVec 2 W64) = 780+primOpTag (VecQuotOp WordVec 32 W8) = 781+primOpTag (VecQuotOp WordVec 16 W16) = 782+primOpTag (VecQuotOp WordVec 8 W32) = 783+primOpTag (VecQuotOp WordVec 4 W64) = 784+primOpTag (VecQuotOp WordVec 64 W8) = 785+primOpTag (VecQuotOp WordVec 32 W16) = 786+primOpTag (VecQuotOp WordVec 16 W32) = 787+primOpTag (VecQuotOp WordVec 8 W64) = 788+primOpTag (VecRemOp IntVec 16 W8) = 789+primOpTag (VecRemOp IntVec 8 W16) = 790+primOpTag (VecRemOp IntVec 4 W32) = 791+primOpTag (VecRemOp IntVec 2 W64) = 792+primOpTag (VecRemOp IntVec 32 W8) = 793+primOpTag (VecRemOp IntVec 16 W16) = 794+primOpTag (VecRemOp IntVec 8 W32) = 795+primOpTag (VecRemOp IntVec 4 W64) = 796+primOpTag (VecRemOp IntVec 64 W8) = 797+primOpTag (VecRemOp IntVec 32 W16) = 798+primOpTag (VecRemOp IntVec 16 W32) = 799+primOpTag (VecRemOp IntVec 8 W64) = 800+primOpTag (VecRemOp WordVec 16 W8) = 801+primOpTag (VecRemOp WordVec 8 W16) = 802+primOpTag (VecRemOp WordVec 4 W32) = 803+primOpTag (VecRemOp WordVec 2 W64) = 804+primOpTag (VecRemOp WordVec 32 W8) = 805+primOpTag (VecRemOp WordVec 16 W16) = 806+primOpTag (VecRemOp WordVec 8 W32) = 807+primOpTag (VecRemOp WordVec 4 W64) = 808+primOpTag (VecRemOp WordVec 64 W8) = 809+primOpTag (VecRemOp WordVec 32 W16) = 810+primOpTag (VecRemOp WordVec 16 W32) = 811+primOpTag (VecRemOp WordVec 8 W64) = 812+primOpTag (VecNegOp IntVec 16 W8) = 813+primOpTag (VecNegOp IntVec 8 W16) = 814+primOpTag (VecNegOp IntVec 4 W32) = 815+primOpTag (VecNegOp IntVec 2 W64) = 816+primOpTag (VecNegOp IntVec 32 W8) = 817+primOpTag (VecNegOp IntVec 16 W16) = 818+primOpTag (VecNegOp IntVec 8 W32) = 819+primOpTag (VecNegOp IntVec 4 W64) = 820+primOpTag (VecNegOp IntVec 64 W8) = 821+primOpTag (VecNegOp IntVec 32 W16) = 822+primOpTag (VecNegOp IntVec 16 W32) = 823+primOpTag (VecNegOp IntVec 8 W64) = 824+primOpTag (VecNegOp FloatVec 4 W32) = 825+primOpTag (VecNegOp FloatVec 2 W64) = 826+primOpTag (VecNegOp FloatVec 8 W32) = 827+primOpTag (VecNegOp FloatVec 4 W64) = 828+primOpTag (VecNegOp FloatVec 16 W32) = 829+primOpTag (VecNegOp FloatVec 8 W64) = 830+primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 831+primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 832+primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 833+primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 834+primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 835+primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 836+primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 837+primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 838+primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 839+primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 840+primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 841+primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 842+primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 843+primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 844+primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 845+primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 846+primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 847+primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 848+primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 849+primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 850+primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 851+primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 852+primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 853+primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 854+primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 855+primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 856+primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 857+primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 858+primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 859+primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 860+primOpTag (VecReadByteArrayOp IntVec 16 W8) = 861+primOpTag (VecReadByteArrayOp IntVec 8 W16) = 862+primOpTag (VecReadByteArrayOp IntVec 4 W32) = 863+primOpTag (VecReadByteArrayOp IntVec 2 W64) = 864+primOpTag (VecReadByteArrayOp IntVec 32 W8) = 865+primOpTag (VecReadByteArrayOp IntVec 16 W16) = 866+primOpTag (VecReadByteArrayOp IntVec 8 W32) = 867+primOpTag (VecReadByteArrayOp IntVec 4 W64) = 868+primOpTag (VecReadByteArrayOp IntVec 64 W8) = 869+primOpTag (VecReadByteArrayOp IntVec 32 W16) = 870+primOpTag (VecReadByteArrayOp IntVec 16 W32) = 871+primOpTag (VecReadByteArrayOp IntVec 8 W64) = 872+primOpTag (VecReadByteArrayOp WordVec 16 W8) = 873+primOpTag (VecReadByteArrayOp WordVec 8 W16) = 874+primOpTag (VecReadByteArrayOp WordVec 4 W32) = 875+primOpTag (VecReadByteArrayOp WordVec 2 W64) = 876+primOpTag (VecReadByteArrayOp WordVec 32 W8) = 877+primOpTag (VecReadByteArrayOp WordVec 16 W16) = 878+primOpTag (VecReadByteArrayOp WordVec 8 W32) = 879+primOpTag (VecReadByteArrayOp WordVec 4 W64) = 880+primOpTag (VecReadByteArrayOp WordVec 64 W8) = 881+primOpTag (VecReadByteArrayOp WordVec 32 W16) = 882+primOpTag (VecReadByteArrayOp WordVec 16 W32) = 883+primOpTag (VecReadByteArrayOp WordVec 8 W64) = 884+primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 885+primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 886+primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 887+primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 888+primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 889+primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 890+primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 891+primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 892+primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 893+primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 894+primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 895+primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 896+primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 897+primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 898+primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 899+primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 900+primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 901+primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 902+primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 903+primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 904+primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 905+primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 906+primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 907+primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 908+primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 909+primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 910+primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 911+primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 912+primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 913+primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 914+primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 915+primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 916+primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 917+primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 918+primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 919+primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 920+primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 921+primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 922+primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 923+primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 924+primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 925+primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 926+primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 927+primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 928+primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 929+primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 930+primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 931+primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 932+primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 933+primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 934+primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 935+primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 936+primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 937+primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 938+primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 939+primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 940+primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 941+primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 942+primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 943+primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 944+primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 945+primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 946+primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 947+primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 948+primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 949+primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 950+primOpTag (VecReadOffAddrOp IntVec 16 W8) = 951+primOpTag (VecReadOffAddrOp IntVec 8 W16) = 952+primOpTag (VecReadOffAddrOp IntVec 4 W32) = 953+primOpTag (VecReadOffAddrOp IntVec 2 W64) = 954+primOpTag (VecReadOffAddrOp IntVec 32 W8) = 955+primOpTag (VecReadOffAddrOp IntVec 16 W16) = 956+primOpTag (VecReadOffAddrOp IntVec 8 W32) = 957+primOpTag (VecReadOffAddrOp IntVec 4 W64) = 958+primOpTag (VecReadOffAddrOp IntVec 64 W8) = 959+primOpTag (VecReadOffAddrOp IntVec 32 W16) = 960+primOpTag (VecReadOffAddrOp IntVec 16 W32) = 961+primOpTag (VecReadOffAddrOp IntVec 8 W64) = 962+primOpTag (VecReadOffAddrOp WordVec 16 W8) = 963+primOpTag (VecReadOffAddrOp WordVec 8 W16) = 964+primOpTag (VecReadOffAddrOp WordVec 4 W32) = 965+primOpTag (VecReadOffAddrOp WordVec 2 W64) = 966+primOpTag (VecReadOffAddrOp WordVec 32 W8) = 967+primOpTag (VecReadOffAddrOp WordVec 16 W16) = 968+primOpTag (VecReadOffAddrOp WordVec 8 W32) = 969+primOpTag (VecReadOffAddrOp WordVec 4 W64) = 970+primOpTag (VecReadOffAddrOp WordVec 64 W8) = 971+primOpTag (VecReadOffAddrOp WordVec 32 W16) = 972+primOpTag (VecReadOffAddrOp WordVec 16 W32) = 973+primOpTag (VecReadOffAddrOp WordVec 8 W64) = 974+primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 975+primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 976+primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 977+primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 978+primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 979+primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 980+primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 981+primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 982+primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 983+primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 984+primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 985+primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 986+primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 987+primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 988+primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 989+primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 990+primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 991+primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 992+primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 993+primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 994+primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 995+primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 996+primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 997+primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 998+primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 999+primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 1000+primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 1001+primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 1002+primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1003+primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1004+primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1005+primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1006+primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1007+primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1008+primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1009+primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1010+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1011+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1012+primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1013+primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1014+primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1015+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1016+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1017+primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1018+primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1019+primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1020+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1021+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1022+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1023+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1024+primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1025+primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1026+primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1027+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1028+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1029+primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1030+primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1031+primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1032+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1033+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1034+primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1035+primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1036+primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1037+primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1038+primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1039+primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1040+primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1041+primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1042+primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1043+primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1044+primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1045+primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1046+primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1047+primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1048+primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1049+primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1050+primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1051+primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1052+primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1053+primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1054+primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1055+primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1056+primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1057+primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1058+primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1059+primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1060+primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1061+primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1062+primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1063+primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1064+primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1065+primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1066+primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1067+primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1068+primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1069+primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1070+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1071+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1072+primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1073+primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1074+primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1075+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1076+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1077+primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1078+primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1079+primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1080+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1081+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1082+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1083+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1084+primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1085+primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1086+primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1087+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1088+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1089+primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1090+primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1091+primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1092+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1093+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1094+primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1095+primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1096+primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1097+primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1098+primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1099+primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1100+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1101+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1102+primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1103+primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1104+primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1105+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1106+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1107+primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1108+primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1109+primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1110+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1111+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1112+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1113+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1114+primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1115+primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1116+primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1117+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1118+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1119+primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1120+primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1121+primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1122+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1123+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1124+primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1125+primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1126+primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1127+primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1128+primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1129+primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1130+primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1131+primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1132+primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1133+primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1134+primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1135+primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1136+primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1137+primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1138+primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1139+primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1140+primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1141+primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1142+primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1143+primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1144+primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1145+primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1146+primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1147+primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1148+primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1149+primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1150+primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1151+primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1152+primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1153+primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1154+primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1155+primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1156+primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1157+primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1158+primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1159+primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1160+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1161+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1162+primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1163+primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1164+primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1165+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1166+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1167+primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1168+primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1169+primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1170+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1171+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1172+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1173+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1174+primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1175+primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1176+primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1177+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1178+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1179+primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1180+primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1181+primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1182+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1183+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1184+primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1185+primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1186+primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1187+primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1188+primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1189+primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1190+primOpTag PrefetchByteArrayOp3 = 1191+primOpTag PrefetchMutableByteArrayOp3 = 1192+primOpTag PrefetchAddrOp3 = 1193+primOpTag PrefetchValueOp3 = 1194+primOpTag PrefetchByteArrayOp2 = 1195+primOpTag PrefetchMutableByteArrayOp2 = 1196+primOpTag PrefetchAddrOp2 = 1197+primOpTag PrefetchValueOp2 = 1198+primOpTag PrefetchByteArrayOp1 = 1199+primOpTag PrefetchMutableByteArrayOp1 = 1200+primOpTag PrefetchAddrOp1 = 1201+primOpTag PrefetchValueOp1 = 1202+primOpTag PrefetchByteArrayOp0 = 1203+primOpTag PrefetchMutableByteArrayOp0 = 1204+primOpTag PrefetchAddrOp0 = 1205+primOpTag PrefetchValueOp0 = 1206
ghc-lib/stage0/lib/ghcversion.h view
@@ -2,11 +2,14 @@ #define __GHCVERSION_H__ #if !defined(__GLASGOW_HASKELL__)-# define __GLASGOW_HASKELL__ 811+#define __GLASGOW_HASKELL__ 811 #endif+#if !defined(__GLASGOW_HASKELL_FULL_VERSION__)+#define __GLASGOW_HASKELL_FULL_VERSION__ 8.11.0.20200703+#endif #define __GLASGOW_HASKELL_PATCHLEVEL1__ 0-#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20200601+#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20200703 #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\ ((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \
ghc-lib/stage0/lib/settings view
@@ -36,7 +36,7 @@ ,("LLVM llc command", "llc") ,("LLVM opt command", "opt") ,("LLVM clang command", "clang")-,("integer library", "integer-simple")+,("BigNum backend", "native") ,("Use interpreter", "YES") ,("Use native code generator", "YES") ,("Support SMP", "YES")
libraries/ghc-boot/GHC/Settings/Platform.hs view
@@ -43,6 +43,7 @@ targetHasIdentDirective <- getBooleanSetting "target has .ident directive" targetHasSubsectionsViaSymbols <- getBooleanSetting "target has subsections via symbols" crossCompiling <- getBooleanSetting "cross compiling"+ tablesNextToCode <- getBooleanSetting "Tables next to code" pure $ Platform { platformMini = PlatformMini@@ -57,6 +58,7 @@ , platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols , platformIsCrossCompiling = crossCompiling , platformLeadingUnderscore = targetLeadingUnderscore+ , platformTablesNextToCode = tablesNextToCode } -----------------------------------------------------------------------------
libraries/ghci/GHCi/InfoTable.hsc view
@@ -25,7 +25,7 @@ import qualified Data.ByteString as BS -- NOTE: Must return a pointer acceptable for use in the header of a closure.--- If tables_next_to_code is enabled, then it must point the the 'code' field.+-- If tables_next_to_code is enabled, then it must point the 'code' field. -- Otherwise, it should point to the start of the StgInfoTable. mkConInfoTable :: Bool -- TABLES_NEXT_TO_CODE
libraries/ghci/GHCi/Run.hs view
@@ -250,10 +250,10 @@ measureAlloc :: IO (EvalResult a) -> IO (EvalStatus a) measureAlloc io = do- setAllocationCounter maxBound+ setAllocationCounter 0 -- #16012 a <- io ctr <- getAllocationCounter- let allocs = fromIntegral (maxBound::Int64) - fromIntegral ctr+ let allocs = negate $ fromIntegral ctr return (EvalComplete allocs a) -- Exceptions can't be marshaled because they're dynamically typed, so