ghc-lib 0.20201001 → 0.20201101
raw patch · 205 files changed
+7354/−6051 lines, 205 filesdep ~ghc-lib-parser
Dependency ranges changed: ghc-lib-parser
Files
- compiler/GHC.hs +188/−71
- compiler/GHC/Builtin/Names/TH.hs +2/−1
- compiler/GHC/Builtin/Types/Literals.hs +6/−8
- compiler/GHC/Builtin/Utils.hs +18/−16
- compiler/GHC/ByteCode/Asm.hs +25/−18
- compiler/GHC/ByteCode/InfoTable.hs +10/−4
- compiler/GHC/ByteCode/Instr.hs +8/−3
- compiler/GHC/ByteCode/Linker.hs +15/−10
- compiler/GHC/Cmm/CallConv.hs +2/−2
- compiler/GHC/Cmm/DebugBlock.hs +17/−12
- compiler/GHC/Cmm/Graph.hs +5/−5
- compiler/GHC/Cmm/LayoutStack.hs +17/−18
- compiler/GHC/Cmm/Lexer.x +3/−2
- compiler/GHC/Cmm/Monad.hs +0/−73
- compiler/GHC/Cmm/Parser.y +116/−96
- compiler/GHC/Cmm/Parser/Monad.hs +84/−0
- compiler/GHC/Cmm/Pipeline.hs +77/−79
- compiler/GHC/Cmm/ProcPoint.hs +138/−138
- compiler/GHC/CmmToAsm.hs +16/−18
- compiler/GHC/CmmToAsm/BlockLayout.hs +9/−16
- compiler/GHC/CmmToAsm/CFG.hs +6/−8
- compiler/GHC/CmmToAsm/CFG/Dominators.hs +5/−2
- compiler/GHC/CmmToAsm/PPC/CodeGen.hs +8/−8
- compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs +29/−34
- compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs +3/−1
- compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs +0/−2
- compiler/GHC/CmmToAsm/Reg/Linear/SPARC.hs +0/−1
- compiler/GHC/CmmToAsm/SPARC/CodeGen.hs +3/−5
- compiler/GHC/CmmToAsm/X86/CodeGen.hs +24/−21
- compiler/GHC/CmmToAsm/X86/Instr.hs +3/−2
- compiler/GHC/CmmToC.hs +4/−2
- compiler/GHC/CmmToLlvm/CodeGen.hs +14/−16
- compiler/GHC/CmmToLlvm/Regs.hs +6/−6
- compiler/GHC/Core/Opt/CprAnal.hs +112/−80
- compiler/GHC/Core/Opt/DmdAnal.hs +42/−52
- compiler/GHC/Core/Opt/Exitify.hs +1/−3
- compiler/GHC/Core/Opt/FloatIn.hs +9/−5
- compiler/GHC/Core/Opt/Pipeline.hs +47/−22
- compiler/GHC/Core/Opt/SetLevels.hs +7/−6
- compiler/GHC/Core/Opt/Simplify.hs +11/−12
- compiler/GHC/Core/Opt/Simplify/Env.hs +1/−1
- compiler/GHC/Core/Opt/Simplify/Utils.hs +15/−8
- compiler/GHC/Core/Opt/SpecConstr.hs +6/−14
- compiler/GHC/Core/Opt/Specialise.hs +34/−29
- compiler/GHC/Core/Opt/StaticArgs.hs +5/−4
- compiler/GHC/Core/Opt/WorkWrap.hs +14/−7
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs +3/−4
- compiler/GHC/Core/Ppr/TyThing.hs +0/−207
- compiler/GHC/Core/TyCon/Set.hs +73/−0
- compiler/GHC/CoreToByteCode.hs +15/−11
- compiler/GHC/CoreToStg.hs +9/−14
- compiler/GHC/CoreToStg/Prep.hs +35/−26
- compiler/GHC/Driver/Backpack.hs +59/−45
- compiler/GHC/Driver/CodeOutput.hs +35/−30
- compiler/GHC/Driver/Finder.hs +0/−855
- compiler/GHC/Driver/Main.hs +137/−95
- compiler/GHC/Driver/Make.hs +52/−25
- compiler/GHC/Driver/MakeFile.hs +7/−3
- compiler/GHC/Driver/Pipeline.hs +113/−77
- compiler/GHC/Hs/Stats.hs +3/−4
- compiler/GHC/HsToCore.hs +45/−31
- compiler/GHC/HsToCore/Arrows.hs +5/−6
- compiler/GHC/HsToCore/Binds.hs +16/−19
- compiler/GHC/HsToCore/Coverage.hs +52/−47
- compiler/GHC/HsToCore/Docs.hs +24/−16
- compiler/GHC/HsToCore/Expr.hs +132/−58
- compiler/GHC/HsToCore/Foreign/Call.hs +1/−0
- compiler/GHC/HsToCore/Foreign/Decl.hs +12/−12
- compiler/GHC/HsToCore/GuardedRHSs.hs +2/−3
- compiler/GHC/HsToCore/ListComp.hs +3/−4
- compiler/GHC/HsToCore/Match.hs +11/−12
- compiler/GHC/HsToCore/Match/Constructor.hs +5/−6
- compiler/GHC/HsToCore/Match/Literal.hs +9/−9
- compiler/GHC/HsToCore/Monad.hs +52/−34
- compiler/GHC/HsToCore/Pmc.hs +9/−14
- compiler/GHC/HsToCore/Pmc/Check.hs +4/−9
- compiler/GHC/HsToCore/Pmc/Desugar.hs +7/−13
- compiler/GHC/HsToCore/Pmc/Ppr.hs +1/−1
- compiler/GHC/HsToCore/Pmc/Solver.hs +16/−12
- compiler/GHC/HsToCore/Pmc/Solver/Types.hs +9/−11
- compiler/GHC/HsToCore/Pmc/Types.hs +5/−6
- compiler/GHC/HsToCore/Pmc/Utils.hs +2/−2
- compiler/GHC/HsToCore/Quote.hs +91/−90
- compiler/GHC/HsToCore/Types.hs +1/−1
- compiler/GHC/HsToCore/Usage.hs +22/−13
- compiler/GHC/HsToCore/Utils.hs +6/−7
- compiler/GHC/Iface/Binary.hs +1/−1
- compiler/GHC/Iface/Env.hs +30/−6
- compiler/GHC/Iface/Ext/Ast.hs +34/−28
- compiler/GHC/Iface/Ext/Binary.hs +2/−5
- compiler/GHC/Iface/Ext/Debug.hs +3/−3
- compiler/GHC/Iface/Ext/Types.hs +8/−8
- compiler/GHC/Iface/Ext/Utils.hs +2/−3
- compiler/GHC/Iface/Load.hs +53/−139
- compiler/GHC/Iface/Load.hs-boot +1/−1
- compiler/GHC/Iface/Make.hs +38/−16
- compiler/GHC/Iface/Recomp.hs +39/−31
- compiler/GHC/Iface/Recomp/Flags.hs +2/−2
- compiler/GHC/Iface/Rename.hs +21/−17
- compiler/GHC/Iface/Tidy.hs +35/−20
- compiler/GHC/Iface/Tidy/StaticPtrTable.hs +17/−10
- compiler/GHC/Iface/UpdateIdInfos.hs +7/−1
- compiler/GHC/IfaceToCore.hs +154/−32
- compiler/GHC/IfaceToCore.hs-boot +5/−2
- compiler/GHC/Llvm/MetaData.hs +0/−1
- compiler/GHC/Llvm/Types.hs +1/−1
- compiler/GHC/Plugins.hs +13/−5
- compiler/GHC/Rename/Bind.hs +9/−9
- compiler/GHC/Rename/Doc.hs +0/−25
- compiler/GHC/Rename/Env.hs +55/−13
- compiler/GHC/Rename/Expr.hs +22/−23
- compiler/GHC/Rename/Fixity.hs +15/−12
- compiler/GHC/Rename/HsType.hs +48/−36
- compiler/GHC/Rename/Module.hs +83/−97
- compiler/GHC/Rename/Names.hs +42/−26
- compiler/GHC/Rename/Pat.hs +18/−19
- compiler/GHC/Rename/Splice.hs +7/−8
- compiler/GHC/Rename/Unbound.hs +15/−9
- compiler/GHC/Rename/Utils.hs +22/−11
- compiler/GHC/Runtime/Debugger.hs +18/−15
- compiler/GHC/Runtime/Eval.hs +55/−38
- compiler/GHC/Runtime/Heap/Inspect.hs +2/−2
- compiler/GHC/Runtime/Interpreter.hs +31/−23
- compiler/GHC/Runtime/Linker.hs +54/−39
- compiler/GHC/Runtime/Loader.hs +22/−16
- compiler/GHC/Settings/IO.hs +0/−4
- compiler/GHC/Stg/Lift.hs +2/−2
- compiler/GHC/Stg/Lift/Analysis.hs +0/−1
- compiler/GHC/Stg/Lint.hs +2/−2
- compiler/GHC/Stg/Unarise.hs +4/−4
- compiler/GHC/StgToCmm.hs +15/−10
- compiler/GHC/StgToCmm/Expr.hs +3/−5
- compiler/GHC/StgToCmm/Foreign.hs +2/−1
- compiler/GHC/StgToCmm/Heap.hs +1/−1
- compiler/GHC/StgToCmm/Hpc.hs +7/−5
- compiler/GHC/StgToCmm/Monad.hs +1/−1
- compiler/GHC/StgToCmm/Prim.hs +256/−252
- compiler/GHC/StgToCmm/Prof.hs +1/−1
- compiler/GHC/StgToCmm/Utils.hs +2/−2
- compiler/GHC/SysTools.hs +33/−28
- compiler/GHC/SysTools/ExtraObj.hs +3/−2
- compiler/GHC/SysTools/Info.hs +75/−76
- compiler/GHC/SysTools/Process.hs +3/−3
- compiler/GHC/SysTools/Tasks.hs +14/−15
- compiler/GHC/Tc/Deriv.hs +2/−4
- compiler/GHC/Tc/Deriv/Generate.hs +2/−0
- compiler/GHC/Tc/Deriv/Generics.hs +85/−14
- compiler/GHC/Tc/Deriv/Infer.hs +2/−4
- compiler/GHC/Tc/Deriv/Utils.hs +20/−17
- compiler/GHC/Tc/Errors.hs +2/−3
- compiler/GHC/Tc/Errors/Hole.hs +3/−2
- compiler/GHC/Tc/Gen/Annotation.hs +10/−5
- compiler/GHC/Tc/Gen/App.hs +14/−11
- compiler/GHC/Tc/Gen/Arrow.hs +5/−5
- compiler/GHC/Tc/Gen/Bind.hs +7/−5
- compiler/GHC/Tc/Gen/Export.hs +24/−33
- compiler/GHC/Tc/Gen/Expr.hs +18/−13
- compiler/GHC/Tc/Gen/Foreign.hs +1/−0
- compiler/GHC/Tc/Gen/Head.hs +40/−14
- compiler/GHC/Tc/Gen/HsType.hs +30/−45
- compiler/GHC/Tc/Gen/Match.hs +22/−19
- compiler/GHC/Tc/Gen/Pat.hs +8/−7
- compiler/GHC/Tc/Gen/Rule.hs +2/−3
- compiler/GHC/Tc/Gen/Splice.hs +85/−74
- compiler/GHC/Tc/Instance/Class.hs +17/−13
- compiler/GHC/Tc/Instance/Family.hs +28/−15
- compiler/GHC/Tc/Instance/Typeable.hs +4/−3
- compiler/GHC/Tc/Module.hs +90/−67
- compiler/GHC/Tc/Module.hs-boot +1/−1
- compiler/GHC/Tc/Plugin.hs +7/−6
- compiler/GHC/Tc/Solver.hs +24/−6
- compiler/GHC/Tc/Solver/Canonical.hs +60/−1
- compiler/GHC/Tc/Solver/Flatten.hs +7/−3
- compiler/GHC/Tc/Solver/Interact.hs +17/−16
- compiler/GHC/Tc/Solver/Monad.hs +6/−5
- compiler/GHC/Tc/TyCl.hs +139/−78
- compiler/GHC/Tc/TyCl/Build.hs +1/−0
- compiler/GHC/Tc/TyCl/Class.hs +5/−3
- compiler/GHC/Tc/TyCl/Instance.hs +14/−3
- compiler/GHC/Tc/TyCl/PatSyn.hs +19/−13
- compiler/GHC/Tc/TyCl/Utils.hs +61/−49
- compiler/GHC/Tc/Types/EvTerm.hs +14/−8
- compiler/GHC/Tc/Utils/Backpack.hs +63/−45
- compiler/GHC/Tc/Utils/Env.hs +39/−24
- compiler/GHC/Tc/Utils/Instantiate.hs +52/−47
- compiler/GHC/Tc/Utils/Monad.hs +77/−60
- compiler/GHC/Tc/Utils/TcMType.hs +5/−5
- compiler/GHC/Tc/Utils/Unify.hs +9/−8
- compiler/GHC/Tc/Utils/Zonk.hs +31/−23
- compiler/GHC/Tc/Validity.hs +32/−12
- compiler/GHC/ThToHs.hs +29/−27
- compiler/GHC/Types/Name/Shape.hs +7/−4
- compiler/GHC/Types/TyThing/Ppr.hs +211/−0
- compiler/GHC/Unit/Finder.hs +855/−0
- ghc-lib.cabal +43/−8
- ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl +6/−6
- ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl +8/−6
- ghc-lib/stage0/compiler/build/primop-docs.hs-incl +94/−32
- ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl +6/−4
- ghc-lib/stage0/compiler/build/primop-list.hs-incl +8/−6
- ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl +10/−8
- ghc-lib/stage0/compiler/build/primop-tag.hs-incl +1214/−1212
- ghc-lib/stage0/lib/ghcautoconf.h +1/−1
- ghc-lib/stage0/lib/ghcversion.h +2/−2
- ghc-lib/stage0/lib/settings +0/−2
compiler/GHC.hs view
@@ -29,7 +29,7 @@ -- * Flags and settings DynFlags(..), GeneralFlag(..), Severity(..), Backend(..), gopt, GhcMode(..), GhcLink(..),- parseDynamicFlags,+ parseDynamicFlags, parseTargetFiles, getSessionDynFlags, setSessionDynFlags, getProgramDynFlags, setProgramDynFlags, setLogAction, getInteractiveDynFlags, setInteractiveDynFlags,@@ -264,6 +264,7 @@ -- * Exceptions GhcException(..), showGhcException,+ GhcApiError(..), -- * Token stream manipulations Token,@@ -294,14 +295,14 @@ import GHC.Prelude hiding (init) -import GHC.ByteCode.Types-import GHC.Runtime.Eval-import GHC.Runtime.Eval.Types-import GHC.Runtime.Interpreter-import GHC.Runtime.Interpreter.Types-import GHCi.RemoteTypes+import GHC.Platform+import GHC.Platform.Ways -import GHC.Core.Ppr.TyThing ( pprFamInst )+import GHC.Driver.Phases ( Phase(..), isHaskellSrcFilename+ , isSourceFilename, startPhase )+import GHC.Driver.Env+import GHC.Driver.CmdLine+import GHC.Driver.Session hiding (WarnReason(..)) import GHC.Driver.Backend import GHC.Driver.Config import GHC.Driver.Main@@ -309,19 +310,49 @@ import GHC.Driver.Hooks import GHC.Driver.Pipeline ( compileOne' ) import GHC.Driver.Monad-import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn )+import GHC.Driver.Ppr++import GHC.ByteCode.Types+import GHC.Runtime.Eval+import GHC.Runtime.Eval.Types+import GHC.Runtime.Interpreter+import GHC.Runtime.Interpreter.Types+import GHC.Runtime.Context+import GHCi.RemoteTypes++import qualified GHC.Parser as Parser+import GHC.Parser.Lexer+import GHC.Parser.Annotation+import GHC.Parser.Errors.Ppr+ import GHC.Iface.Load ( loadSysInterface )+import GHC.Hs+import GHC.Builtin.Types.Prim ( alphaTyVars )+import GHC.Iface.Tidy+import GHC.Data.Bag ( listToBag )+import GHC.Data.StringBuffer+import GHC.Data.FastString+import qualified GHC.LanguageExtensions as LangExt++import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn ) import GHC.Tc.Types+import GHC.Tc.Utils.TcType+import GHC.Tc.Module+import GHC.Tc.Utils.Instantiate+import GHC.Tc.Instance.Family++import GHC.SysTools.FileCleanup+import GHC.SysTools+import GHC.SysTools.BaseDir++import GHC.Utils.Error+import GHC.Utils.Monad+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic+ import GHC.Core.Predicate-import GHC.Unit-import GHC.Unit.State-import GHC.Types.Name.Set-import GHC.Types.Name.Reader-import GHC.Hs import GHC.Core.Type hiding( typeKind )-import GHC.Tc.Utils.TcType-import GHC.Types.Id-import GHC.Builtin.Types.Prim ( alphaTyVars ) import GHC.Core.TyCon import GHC.Core.TyCo.Ppr ( pprForAll ) import GHC.Core.Class@@ -329,41 +360,38 @@ import GHC.Core.FVs ( orphNamesOfFamInst ) import GHC.Core.FamInstEnv ( FamInst, famInstEnvElts ) import GHC.Core.InstEnv+import GHC.Core++import GHC.Types.Id import GHC.Types.Name hiding ( varName ) import GHC.Types.Avail import GHC.Types.SrcLoc-import GHC.Core-import GHC.Iface.Tidy-import GHC.Driver.Phases ( Phase(..), isHaskellSrcFilename )-import GHC.Driver.Finder-import GHC.Driver.Types-import GHC.Driver.CmdLine-import GHC.Driver.Session hiding (WarnReason(..))-import GHC.Platform.Ways-import GHC.Driver.Ppr-import GHC.SysTools-import GHC.SysTools.BaseDir+import GHC.Types.TyThing.Ppr ( pprFamInst ) import GHC.Types.Annotations-import GHC.Utils.Panic-import GHC.Platform-import GHC.Data.Bag ( listToBag )-import GHC.Utils.Error-import GHC.Utils.Monad-import GHC.Utils.Misc-import GHC.Data.StringBuffer-import GHC.Utils.Outputable+import GHC.Types.Name.Set+import GHC.Types.Name.Reader+import GHC.Types.SourceError+import GHC.Types.SafeHaskell+import GHC.Types.Fixity+import GHC.Types.Target import GHC.Types.Basic-import GHC.Data.FastString-import qualified GHC.Parser as Parser-import GHC.Parser.Lexer-import GHC.Parser.Annotation-import qualified GHC.LanguageExtensions as LangExt+import GHC.Types.TyThing import GHC.Types.Name.Env-import GHC.Tc.Module-import GHC.Tc.Utils.Instantiate-import GHC.Tc.Instance.Family-import GHC.SysTools.FileCleanup+import GHC.Types.Name.Ppr+import GHC.Types.TypeEnv+import GHC.Types.SourceFile +import GHC.Unit+import GHC.Unit.External+import GHC.Unit.State+import GHC.Unit.Finder+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModGuts+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.Graph+import GHC.Unit.Home.ModInfo+ import Data.Foldable import qualified Data.Map.Strict as Map import Data.Set (Set)@@ -386,6 +414,7 @@ import System.IO.Error ( isDoesNotExistError ) import System.Environment ( getEnv ) import System.Directory+import Data.List (isPrefixOf) -- %************************************************************************@@ -599,9 +628,9 @@ -- can ignore the list of packages returned. -- setSessionDynFlags :: GhcMonad m => DynFlags -> m ()-setSessionDynFlags dflags = do- dflags' <- checkNewDynFlags dflags- dflags''' <- liftIO $ initUnits dflags'+setSessionDynFlags dflags0 = do+ dflags1 <- checkNewDynFlags dflags0+ dflags <- liftIO $ initUnits dflags1 -- Interpreter interp <- if gopt Opt_ExternalInterpreter dflags@@ -636,11 +665,12 @@ return Nothing #endif - modifySession $ \h -> h{ hsc_dflags = dflags'''- , hsc_IC = (hsc_IC h){ ic_dflags = dflags''' }+ modifySession $ \h -> h{ hsc_dflags = dflags+ , hsc_IC = (hsc_IC h){ ic_dflags = dflags } , hsc_interp = hsc_interp h <|> interp -- we only update the interpreter if there wasn't -- already one set up+ , hsc_home_unit = mkHomeUnitFromFlags dflags } invalidateModSummaryCache @@ -727,7 +757,89 @@ dflags2 <- liftIO $ interpretPackageEnv dflags1 return (dflags2, leftovers, warns) +-- | Parse command line arguments that look like files.+-- First normalises its arguments and then splits them into source files+-- and object files.+-- A source file can be turned into a 'Target' via 'guessTarget'+parseTargetFiles :: DynFlags -> [String] -> (DynFlags, [(String, Maybe Phase)], [String])+parseTargetFiles dflags0 fileish_args =+ let+ normal_fileish_paths = map normalise_hyp fileish_args+ (srcs, objs) = partition_args normal_fileish_paths [] [] + dflags1 = dflags0 { ldInputs = map (FileOption "") objs+ ++ ldInputs dflags0 }+ {-+ We split out the object files (.o, .dll) and add them+ to ldInputs for use by the linker.++ The following things should be considered compilation manager inputs:++ - haskell source files (strings ending in .hs, .lhs or other+ haskellish extension),++ - module names (not forgetting hierarchical module names),++ - things beginning with '-' are flags that were not recognised by+ the flag parser, and we want them to generate errors later in+ checkOptions, so we class them as source files (#5921)++ - and finally we consider everything without an extension to be+ a comp manager input, as shorthand for a .hs or .lhs filename.++ Everything else is considered to be a linker object, and passed+ straight through to the linker.+ -}+ in (dflags1, srcs, objs)++-- -----------------------------------------------------------------------------++-- | Splitting arguments into source files and object files. This is where we+-- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source+-- file indicating the phase specified by the -x option in force, if any.+partition_args :: [String] -> [(String, Maybe Phase)] -> [String]+ -> ([(String, Maybe Phase)], [String])+partition_args [] srcs objs = (reverse srcs, reverse objs)+partition_args ("-x":suff:args) srcs objs+ | "none" <- suff = partition_args args srcs objs+ | StopLn <- phase = partition_args args srcs (slurp ++ objs)+ | otherwise = partition_args rest (these_srcs ++ srcs) objs+ where phase = startPhase suff+ (slurp,rest) = break (== "-x") args+ these_srcs = zip slurp (repeat (Just phase))+partition_args (arg:args) srcs objs+ | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs+ | otherwise = partition_args args srcs (arg:objs)+++looks_like_an_input :: String -> Bool+looks_like_an_input m = isSourceFilename m+ || looksLikeModuleName m+ || "-" `isPrefixOf` m+ || not (hasExtension m)+++-- | To simplify the handling of filepaths, we normalise all filepaths right+-- away. Note the asymmetry of FilePath.normalise:+-- Linux: p\/q -> p\/q; p\\q -> p\\q+-- Windows: p\/q -> p\\q; p\\q -> p\\q+-- #12674: Filenames starting with a hypen get normalised from ./-foo.hs+-- to -foo.hs. We have to re-prepend the current directory.+normalise_hyp :: FilePath -> FilePath+normalise_hyp fp+ | strt_dot_sl && "-" `isPrefixOf` nfp = cur_dir ++ nfp+ | otherwise = nfp+ where+#if defined(mingw32_HOST_OS)+ strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp+#else+ strt_dot_sl = "./" `isPrefixOf` fp+#endif+ cur_dir = '.' : [pathSeparator]+ nfp = normalise fp++-----------------------------------------------------------------------------+ -- | Checks the set of new DynFlags for possibly erroneous option -- combinations when invoking 'setSessionDynFlags' and friends, and if -- found, returns a fixed copy (if possible).@@ -1170,7 +1282,7 @@ let dflags = hsc_dflags hsc_env return $ icPrintUnqual (unitState dflags)- (mkHomeUnitFromFlags dflags)+ (hsc_home_unit hsc_env) (hsc_IC hsc_env) -- | Container for information about a 'Module'.@@ -1269,7 +1381,7 @@ let dflags = hsc_dflags hsc_env mk_print_unqual = mkPrintUnqualified (unitState dflags)- (mkHomeUnitFromFlags dflags)+ (hsc_home_unit hsc_env) return (fmap mk_print_unqual (minf_rdr_env minf)) modInfoLookupName :: GhcMonad m =>@@ -1278,10 +1390,7 @@ modInfoLookupName minf name = withSession $ \hsc_env -> do case lookupTypeEnv (minf_type_env minf) name of Just tyThing -> return (Just tyThing)- Nothing -> do- eps <- liftIO $ readIORef (hsc_EPS hsc_env)- return $! lookupType (hsc_dflags hsc_env)- (hsc_HPT hsc_env) (eps_PTE eps) name+ Nothing -> liftIO (lookupType hsc_env name) modInfoIface :: ModuleInfo -> Maybe ModIface modInfoIface = minf_iface@@ -1307,7 +1416,7 @@ -- 'setContext'. lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing) lookupGlobalName name = withSession $ \hsc_env -> do- liftIO $ lookupTypeHscEnv hsc_env name+ liftIO $ lookupType hsc_env name findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a] findGlobalAnns deserialize target = withSession $ \hsc_env -> do@@ -1424,16 +1533,14 @@ -- | Return module source as token stream, including comments. -- -- The module must be in the module graph and its source must be available.--- Throws a 'GHC.Driver.Types.SourceError' on parse error.+-- Throws a 'GHC.Driver.Env.SourceError' on parse error. getTokenStream :: GhcMonad m => Module -> m [Located Token] getTokenStream mod = do (sourceFile, source, dflags) <- getModuleSourceAndFlags mod let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 case lexTokenStream (initParserOpts dflags) source startLoc of- POk _ ts -> return ts- PFailed pst ->- do dflags <- getDynFlags- throwErrors (getErrorMessages pst dflags)+ POk _ ts -> return ts+ PFailed pst -> throwErrors (fmap pprError (getErrorMessages pst)) -- | Give even more information on the source than 'getTokenStream' -- This function allows reconstructing the source completely with@@ -1443,10 +1550,8 @@ (sourceFile, source, dflags) <- getModuleSourceAndFlags mod let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 case lexTokenStream (initParserOpts dflags) source startLoc of- POk _ ts -> return $ addSourceToTokens startLoc source ts- PFailed pst ->- do dflags <- getDynFlags- throwErrors (getErrorMessages pst dflags)+ POk _ ts -> return $ addSourceToTokens startLoc source ts+ PFailed pst -> throwErrors (fmap pprError (getErrorMessages pst)) -- | Given a source location and a StringBuffer corresponding to this -- location, return a rich token stream with the source associated to the@@ -1504,7 +1609,7 @@ findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module findModule mod_name maybe_pkg = withSession $ \hsc_env -> do let dflags = hsc_dflags hsc_env- home_unit = mkHomeUnitFromFlags dflags+ home_unit = hsc_home_unit hsc_env case maybe_pkg of Just pkg | not (isHomeUnit home_unit (fsToUnit pkg)) && pkg /= fsLit "this" -> liftIO $ do res <- findImportedModule hsc_env mod_name maybe_pkg@@ -1620,12 +1725,12 @@ case unP Parser.parseModule (initParserState (initParserOpts dflags) buf loc) of PFailed pst ->- let (warns,errs) = getMessages pst dflags in- (warns, Left errs)+ let (warns,errs) = getMessages pst in+ (fmap pprWarning warns, Left (fmap pprError errs)) POk pst rdr_module ->- let (warns,_) = getMessages pst dflags in- (warns, Right rdr_module)+ let (warns,_) = getMessages pst in+ (fmap pprWarning warns, Right rdr_module) -- ----------------------------------------------------------------------------- -- | Find the package environment (if one exists)@@ -1763,3 +1868,15 @@ "Package environment " ++ show env ++ " (specified in GHC_ENVIRONMENT) not found"++-- | An error thrown if the GHC API is used in an incorrect fashion.+newtype GhcApiError = GhcApiError String++instance Show GhcApiError where+ show (GhcApiError msg) = msg++instance Exception GhcApiError++mkApiErr :: DynFlags -> SDoc -> GhcApiError+mkApiErr dflags msg = GhcApiError (showSDoc dflags msg)+
compiler/GHC/Builtin/Names/TH.hs view
@@ -9,7 +9,8 @@ import GHC.Prelude () import GHC.Builtin.Names( mk_known_key_name )-import GHC.Unit+import GHC.Unit.Types+import GHC.Unit.Module.Name import GHC.Types.Name( Name ) import GHC.Types.Name.Occurrence( tcName, clsName, dataName, varName ) import GHC.Types.Name.Reader( RdrName, nameRdrName )
compiler/GHC/Builtin/Types/Literals.hs view
@@ -236,7 +236,7 @@ typeNatLeqTyCon :: TyCon typeNatLeqTyCon = mkFamilyTyCon name- (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ])+ (mkTemplateAnonTyConBinders [ naturalTy, naturalTy ]) boolTy Nothing (BuiltInSynFamTyCon ops)@@ -255,7 +255,7 @@ typeNatCmpTyCon :: TyCon typeNatCmpTyCon = mkFamilyTyCon name- (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ])+ (mkTemplateAnonTyConBinders [ naturalTy, naturalTy ]) orderingKind Nothing (BuiltInSynFamTyCon ops)@@ -301,14 +301,12 @@ name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "AppendSymbol") typeSymbolAppendFamNameKey typeSymbolAppendTyCon -- -- Make a unary built-in constructor of kind: Nat -> Nat mkTypeNatFunTyCon1 :: Name -> BuiltInSynFamily -> TyCon mkTypeNatFunTyCon1 op tcb = mkFamilyTyCon op- (mkTemplateAnonTyConBinders [ typeNatKind ])- typeNatKind+ (mkTemplateAnonTyConBinders [ naturalTy ])+ naturalTy Nothing (BuiltInSynFamTyCon tcb) Nothing@@ -319,8 +317,8 @@ mkTypeNatFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon mkTypeNatFunTyCon2 op tcb = mkFamilyTyCon op- (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ])- typeNatKind+ (mkTemplateAnonTyConBinders [ naturalTy, naturalTy ])+ naturalTy Nothing (BuiltInSynFamTyCon tcb) Nothing
compiler/GHC/Builtin/Utils.hs view
@@ -50,31 +50,34 @@ import GHC.Prelude import GHC.Builtin.Uniques-import GHC.Types.Unique ( isValidKnownKeyUnique )--import GHC.Core.ConLike ( ConLike(..) )+import GHC.Builtin.PrimOps+import GHC.Builtin.Types+import GHC.Builtin.Types.Literals ( typeNatTyCons )+import GHC.Builtin.Types.Prim import GHC.Builtin.Names.TH ( templateHaskellNames ) import GHC.Builtin.Names++import GHC.Core.ConLike ( ConLike(..) ) import GHC.Core.Opt.ConstantFold-import GHC.Types.Avail-import GHC.Builtin.PrimOps import GHC.Core.DataCon+import GHC.Core.Class+import GHC.Core.TyCon++import GHC.Types.Avail import GHC.Types.Basic import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Id.Make-import GHC.Utils.Outputable-import GHC.Builtin.Types.Prim-import GHC.Builtin.Types-import GHC.Driver.Types-import GHC.Core.Class-import GHC.Core.TyCon import GHC.Types.Unique.FM+import GHC.Types.TyThing+import GHC.Types.Unique ( isValidKnownKeyUnique )++import GHC.Utils.Outputable import GHC.Utils.Misc as Utils import GHC.Utils.Panic-import GHC.Builtin.Types.Literals ( typeNatTyCons ) import GHC.Hs.Doc+import GHC.Unit.Module.ModIface (IfaceExport) import Control.Applicative ((<|>)) import Data.List ( intercalate , find )@@ -133,8 +136,7 @@ -- See Note [One-tuples] (Wrinkle: Make boxed one-tuple names have known keys) -- in GHC.Builtin.Types. tupleTyConName BoxedTuple 1 : tupleDataConName Boxed 1 :- concat [ wired_tycon_kk_names funTyCon- , concatMap wired_tycon_kk_names primTyCons+ concat [ concatMap wired_tycon_kk_names primTyCons , concatMap wired_tycon_kk_names wiredInTyCons , concatMap wired_tycon_kk_names typeNatTyCons , map idName wiredInIds@@ -264,14 +266,14 @@ = map (avail . idName) ghcPrimIds ++ map (avail . idName . primOpId) allThePrimOps ++ [ AvailTC n [n] []- | tc <- funTyCon : exposedPrimTyCons, let n = tyConName tc ]+ | tc <- exposedPrimTyCons, let n = tyConName tc ] ghcPrimDeclDocs :: DeclDocMap ghcPrimDeclDocs = DeclDocMap $ Map.fromList $ mapMaybe findName primOpDocs where names = map idName ghcPrimIds ++ map (idName . primOpId) allThePrimOps ++- map tyConName (funTyCon : exposedPrimTyCons)+ map tyConName exposedPrimTyCons findName (nameStr, doc) | Just name <- find ((nameStr ==) . getOccString) names = Just (name, mkHsDocString doc)
compiler/GHC/ByteCode/Asm.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE BangPatterns, CPP, DeriveFunctor, MagicHash, RecordWildCards #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} -- -- (c) The University of Glasgow 2002-2006@@ -17,27 +19,30 @@ import GHC.Prelude +import GHC.Driver.Env+import GHC.Driver.Session+ import GHC.ByteCode.Instr import GHC.ByteCode.InfoTable import GHC.ByteCode.Types import GHCi.RemoteTypes import GHC.Runtime.Interpreter+import GHC.Runtime.Heap.Layout -import GHC.Driver.Types import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Literal+import GHC.Types.Unique+import GHC.Types.Unique.DSet++import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc+ import GHC.Core.TyCon import GHC.Data.FastString import GHC.StgToCmm.Layout ( ArgRep(..) )-import GHC.Runtime.Heap.Layout-import GHC.Driver.Session-import GHC.Utils.Outputable-import GHC.Utils.Panic import GHC.Platform-import GHC.Utils.Misc-import GHC.Types.Unique-import GHC.Types.Unique.DSet -- From iserv import SizedSeq@@ -57,9 +62,9 @@ import Foreign import Data.Char ( ord ) import Data.List ( genericLength )-import Data.Map (Map)+import Data.Map.Strict (Map) import Data.Maybe (fromMaybe)-import qualified Data.Map as Map+import qualified Data.Map.Strict as Map -- ----------------------------------------------------------------------------- -- Unlinked BCOs@@ -177,10 +182,12 @@ -- this BCO to be long. (n_insns0, lbl_map0) = inspectAsm platform False initial_offset asm ((n_insns, lbl_map), long_jumps)- | isLarge n_insns0 = (inspectAsm platform True initial_offset asm, True)+ | isLarge (fromIntegral $ Map.size lbl_map0)+ || isLarge n_insns0+ = (inspectAsm platform True initial_offset asm, True) | otherwise = ((n_insns0, lbl_map0), False) - env :: Word16 -> Word+ env :: LocalLabel -> Word env lbl = fromMaybe (pprPanic "assembleBCO.findLabel" (ppr lbl)) (Map.lookup lbl lbl_map)@@ -220,13 +227,13 @@ data Operand = Op Word | SmallOp Word16- | LabelOp Word16+ | LabelOp LocalLabel -- (unused) | LargeOp Word data Assembler a = AllocPtr (IO BCOPtr) (Word -> Assembler a) | AllocLit [BCONPtr] (Word -> Assembler a)- | AllocLabel Word16 (Assembler a)+ | AllocLabel LocalLabel (Assembler a) | Emit Word16 [Operand] (Assembler a) | NullAsm a deriving (Functor)@@ -251,13 +258,13 @@ lit :: [BCONPtr] -> Assembler Word lit l = AllocLit l return -label :: Word16 -> Assembler ()+label :: LocalLabel -> Assembler () label w = AllocLabel w (return ()) emit :: Word16 -> [Operand] -> Assembler () emit w ops = Emit w ops (return ()) -type LabelEnv = Word16 -> Word+type LabelEnv = LocalLabel -> Word largeOp :: Bool -> Operand -> Bool largeOp long_jumps op = case op of@@ -297,7 +304,7 @@ in ((), (st_i1,st_l0,st_p0)) go k -type LabelEnvMap = Map Word16 Word+type LabelEnvMap = Map LocalLabel Word data InspectState = InspectState { instrCount :: !Word
compiler/GHC/ByteCode/InfoTable.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE CPP, MagicHash, ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} -- -- (c) The University of Glasgow 2002-2006@@ -11,21 +12,26 @@ import GHC.Prelude +import GHC.Driver.Session+import GHC.Driver.Env+ import GHC.Platform import GHC.Platform.Profile import GHC.ByteCode.Types import GHC.Runtime.Interpreter-import GHC.Driver.Session-import GHC.Driver.Types+ import GHC.Types.Name ( Name, getName ) import GHC.Types.Name.Env+import GHC.Types.RepType+ 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 (..) )+ import GHC.Utils.Misc import GHC.Utils.Panic
compiler/GHC/ByteCode/Instr.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, MagicHash #-}+{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -- -- (c) The University of Glasgow 2002-2006@@ -6,7 +6,7 @@ -- | Bytecode instruction definitions module GHC.ByteCode.Instr (- BCInstr(..), ProtoBCO(..), bciStackUse,+ BCInstr(..), ProtoBCO(..), bciStackUse, LocalLabel(..) ) where #include "GhclibHsVersions.h"@@ -50,7 +50,12 @@ protoBCOFFIs :: [FFIInfo] } -type LocalLabel = Word16+-- | A local block label (e.g. identifying a case alternative).+newtype LocalLabel = LocalLabel { getLocalLabel :: Word32 }+ deriving (Eq, Ord)++instance Outputable LocalLabel where+ ppr (LocalLabel lbl) = text "lbl:" <> ppr lbl data BCInstr -- Messing with the stack
compiler/GHC/ByteCode/Linker.hs view
@@ -1,7 +1,6 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MagicHash #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} --@@ -20,22 +19,28 @@ import GHC.Prelude +import GHC.Driver.Env++import GHC.Runtime.Interpreter+import GHC.ByteCode.Types import GHCi.RemoteTypes import GHCi.ResolvedBCO import GHCi.BreakArray import SizedSeq -import GHC.Runtime.Interpreter-import GHC.ByteCode.Types-import GHC.Driver.Types-import GHC.Types.Name-import GHC.Types.Name.Env import GHC.Builtin.PrimOps-import GHC.Unit++import GHC.Unit.Types+import GHC.Unit.Module.Name+ import GHC.Data.FastString+ import GHC.Utils.Panic import GHC.Utils.Outputable import GHC.Utils.Misc++import GHC.Types.Name+import GHC.Types.Name.Env -- Standard libraries import Data.Array.Unboxed
compiler/GHC/Cmm/CallConv.hs view
@@ -207,14 +207,14 @@ realArgRegsCover :: Platform -> [GlobalReg] realArgRegsCover platform | passFloatArgsInXmm platform- = map ($VGcPtr) (realVanillaRegs platform) +++ = map ($ VGcPtr) (realVanillaRegs platform) ++ realLongRegs platform ++ realDoubleRegs platform -- we only need to save the low Double part of XMM registers. -- Moreover, the NCG can't load/store full XMM -- registers for now... | otherwise- = map ($VGcPtr) (realVanillaRegs platform) +++ = map ($ VGcPtr) (realVanillaRegs platform) ++ realFloatRegs platform ++ realDoubleRegs platform ++ realLongRegs platform
compiler/GHC/Cmm/DebugBlock.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -520,18 +521,22 @@ deriving (Eq) instance OutputableP env CLabel => OutputableP env UnwindExpr where- pdocPrec _ _ (UwConst i) = ppr i- pdocPrec _ _ (UwReg g 0) = ppr g- pdocPrec p env (UwReg g x) = pdocPrec p env (UwPlus (UwReg g 0) (UwConst x))- pdocPrec _ env (UwDeref e) = char '*' <> pdocPrec 3 env e- pdocPrec _ env (UwLabel l) = pdocPrec 3 env l- pdocPrec p env (UwPlus e0 e1) | p <= 0- = pdocPrec 0 env e0 <> char '+' <> pdocPrec 0 env e1- pdocPrec p env (UwMinus e0 e1) | p <= 0- = pdocPrec 1 env e0 <> char '-' <> pdocPrec 1 env e1- pdocPrec p env (UwTimes e0 e1) | p <= 1- = pdocPrec 2 env e0 <> char '*' <> pdocPrec 2 env e1- pdocPrec _ env other = parens (pdocPrec 0 env other)+ pdoc = pprUnwindExpr 0++pprUnwindExpr :: OutputableP env CLabel => Rational -> env -> UnwindExpr -> SDoc+pprUnwindExpr p env = \case+ UwConst i -> ppr i+ UwReg g 0 -> ppr g+ UwReg g x -> pprUnwindExpr p env (UwPlus (UwReg g 0) (UwConst x))+ UwDeref e -> char '*' <> pprUnwindExpr 3 env e+ UwLabel l -> pdoc env l+ UwPlus e0 e1+ | p <= 0 -> pprUnwindExpr 0 env e0 <> char '+' <> pprUnwindExpr 0 env e1+ UwMinus e0 e1+ | p <= 0 -> pprUnwindExpr 1 env e0 <> char '-' <> pprUnwindExpr 1 env e1+ UwTimes e0 e1+ | p <= 1 -> pprUnwindExpr 2 env e0 <> char '*' <> pprUnwindExpr 2 env e1+ other -> parens (pprUnwindExpr 0 env other) -- | Conversion of Cmm expressions to unwind expressions. We check for -- unsupported operator usages and simplify the expression as far as
compiler/GHC/Cmm/Graph.hs view
@@ -250,10 +250,10 @@ -> UpdFrameOffset -> [CmmExpr] -> CmmAGraph-mkCallReturnsTo profile f callConv actuals ret_lbl ret_off updfr_off extra_stack = do+mkCallReturnsTo profile f callConv actuals ret_lbl ret_off updfr_off extra_stack = lastWithArgsAndExtraStack profile Call (Young ret_lbl) callConv actuals- updfr_off extra_stack $- toCall f (Just ret_lbl) updfr_off ret_off+ updfr_off extra_stack $+ toCall f (Just ret_lbl) updfr_off ret_off -- Like mkCallReturnsTo, but does not push the return address (it is assumed to be -- already on the stack).@@ -262,9 +262,9 @@ -> ByteOff -> UpdFrameOffset -> CmmAGraph-mkJumpReturnsTo profile f callConv actuals ret_lbl ret_off updfr_off = do+mkJumpReturnsTo profile f callConv actuals ret_lbl ret_off updfr_off = lastWithArgs profile JumpRet (Young ret_lbl) callConv actuals updfr_off $- toCall f (Just ret_lbl) updfr_off ret_off+ toCall f (Just ret_lbl) updfr_off ret_off mkUnsafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph mkUnsafeCall t fs as = mkMiddle $ CmmUnsafeForeignCall t fs as
compiler/GHC/Cmm/LayoutStack.hs view
@@ -451,26 +451,25 @@ handleLastNode dflags procpoints liveness cont_info stackmaps stack0@StackMap { sm_sp = sp0 } tscp middle last- = case last of- -- At each return / tail call,- -- adjust Sp to point to the last argument pushed, which- -- is cml_args, after popping any other junk from the stack.- CmmCall{ cml_cont = Nothing, .. } -> do- let sp_off = sp0 - cml_args- return ([], sp_off, last, [], mapEmpty)-- -- At each CmmCall with a continuation:- CmmCall{ cml_cont = Just cont_lbl, .. } ->- return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off+ = case last of+ -- At each return / tail call,+ -- adjust Sp to point to the last argument pushed, which+ -- is cml_args, after popping any other junk from the stack.+ CmmCall{ cml_cont = Nothing, .. } -> do+ let sp_off = sp0 - cml_args+ return ([], sp_off, last, [], mapEmpty) - CmmForeignCall{ succ = cont_lbl, .. } -> do- return $ lastCall cont_lbl (platformWordSizeInBytes platform) ret_args ret_off- -- one word of args: the return address+ -- At each CmmCall with a continuation:+ CmmCall{ cml_cont = Just cont_lbl, .. } ->+ return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off - CmmBranch {} -> handleBranches- CmmCondBranch {} -> handleBranches- CmmSwitch {} -> handleBranches+ CmmForeignCall{ succ = cont_lbl, .. } ->+ return $ lastCall cont_lbl (platformWordSizeInBytes platform) ret_args ret_off+ -- one word of args: the return address + CmmBranch {} -> handleBranches+ CmmCondBranch {} -> handleBranches+ CmmSwitch {} -> handleBranches where platform = targetPlatform dflags -- Calls and ForeignCalls are handled the same way:@@ -1051,7 +1050,7 @@ -> BlockId -> [CmmBlock] -> UniqSM [CmmBlock]-insertReloadsAsNeeded platform procpoints final_stackmaps entry blocks = do+insertReloadsAsNeeded platform procpoints final_stackmaps entry blocks = toBlockList . fst <$> rewriteCmmBwd liveLattice rewriteCC (ofBlockList entry blocks) mapEmpty where
compiler/GHC/Cmm/Lexer.x view
@@ -20,12 +20,13 @@ import GHC.Cmm.Expr import GHC.Parser.Lexer-import GHC.Cmm.Monad+import GHC.Cmm.Parser.Monad import GHC.Types.SrcLoc import GHC.Types.Unique.FM import GHC.Data.StringBuffer import GHC.Data.FastString import GHC.Parser.CharClass+import GHC.Parser.Errors import GHC.Utils.Misc --import TRACE @@ -325,7 +326,7 @@ AlexEOF -> do let span = mkPsSpan loc1 loc1 liftP (setLastToken span 0) return (L span CmmT_EOF)- AlexError (loc2,_) -> liftP $ failLocMsgP (psRealLoc loc1) (psRealLoc loc2) "lexical error"+ AlexError (loc2,_) -> liftP $ failLocMsgP (psRealLoc loc1) (psRealLoc loc2) (Error ErrCmmLexer []) AlexSkip inp2 _ -> do setInput inp2 lexToken
− compiler/GHC/Cmm/Monad.hs
@@ -1,73 +0,0 @@--------------------------------------------------------------------------------- A Parser monad with access to the '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',--- so 'PD' provides access to 'DynFlags' via a 'HasDynFlags' instance.-------------------------------------------------------------------------------module GHC.Cmm.Monad (- PD(..)- , liftP- , failMsgPD- , getProfile- , getPlatform- , getPtrOpts- ) where--import GHC.Prelude--import GHC.Platform-import GHC.Platform.Profile-import GHC.Cmm.Info--import Control.Monad--import GHC.Driver.Session-import GHC.Parser.Lexer--newtype PD a = PD { unPD :: DynFlags -> PState -> ParseResult a }--instance Functor PD where- fmap = liftM--instance Applicative PD where- pure = returnPD- (<*>) = ap--instance Monad PD where- (>>=) = thenPD--liftP :: P a -> PD a-liftP (P f) = PD $ \_ s -> f s--failMsgPD :: String -> PD a-failMsgPD = liftP . failMsgP--returnPD :: a -> PD a-returnPD = liftP . return--thenPD :: PD a -> (a -> PD b) -> PD b-(PD m) `thenPD` k = PD $ \d s ->- case m d s of- POk s1 a -> unPD (k a) d s1- PFailed s1 -> PFailed s1--instance HasDynFlags PD where- getDynFlags = PD $ \d s -> POk s d--getProfile :: PD Profile-getProfile = targetProfile <$> getDynFlags--getPlatform :: PD Platform-getPlatform = profilePlatform <$> getProfile--getPtrOpts :: PD PtrOpts-getPtrOpts = do- dflags <- getDynFlags- profile <- getProfile- pure $ PtrOpts- { po_profile = profile- , po_align_check = gopt Opt_AlignmentSanitisation dflags- }
compiler/GHC/Cmm/Parser.y view
@@ -234,11 +234,12 @@ import GHC.Cmm.BlockId import GHC.Cmm.Lexer import GHC.Cmm.CLabel-import GHC.Cmm.Monad hiding (getPlatform, getProfile, getPtrOpts)-import qualified GHC.Cmm.Monad as PD+import GHC.Cmm.Parser.Monad hiding (getPlatform, getProfile, getPtrOpts)+import qualified GHC.Cmm.Parser.Monad as PD import GHC.Cmm.CallConv import GHC.Runtime.Heap.Layout import GHC.Parser.Lexer+import GHC.Parser.Errors import GHC.Types.CostCentre import GHC.Types.ForeignCall@@ -257,7 +258,7 @@ import GHC.Settings.Constants import GHC.Utils.Outputable import GHC.Types.Basic-import GHC.Data.Bag ( emptyBag, unitBag )+import GHC.Data.Bag ( Bag, emptyBag, unitBag, isEmptyBag ) import GHC.Types.Var import Control.Monad@@ -384,9 +385,11 @@ | cmmdata { $1 } | decl { $1 } | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'- {% liftP . withHomeUnitId $ \pkg ->- do lits <- sequence $6;- staticClosure pkg $3 $5 (map getLit lits) }+ {% do+ home_unit_id <- getHomeUnitId+ liftP $ pure $ do+ lits <- sequence $6;+ staticClosure home_unit_id $3 $5 (map getLit lits) } -- The only static closures in the RTS are dummy closures like -- stg_END_TSO_QUEUE_closure and stg_dummy_ret. We don't need@@ -405,8 +408,10 @@ data_label :: { CmmParse CLabel } : NAME ':'- {% liftP . withHomeUnitId $ \pkg ->- return (mkCmmDataLabel pkg (NeedExternDecl False) $1) }+ {% do+ home_unit_id <- getHomeUnitId+ liftP $ pure $ do+ pure (mkCmmDataLabel home_unit_id (NeedExternDecl False) $1) } statics :: { [CmmParse [CmmStatic]] } : {- empty -} { [] }@@ -463,103 +468,117 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } : NAME- {% liftP . withHomeUnitId $ \pkg ->- do newFunctionName $1 pkg- return (mkCmmCodeLabel pkg $1, Nothing, []) }+ {% do+ home_unit_id <- getHomeUnitId+ liftP $ pure $ do+ newFunctionName $1 home_unit_id+ return (mkCmmCodeLabel home_unit_id $1, Nothing, []) } | 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' -- ptrs, nptrs, closure type, description, type- {% liftP . withHomeUnitId $ \pkg ->- do profile <- getProfile- let prof = profilingInfo profile $11 $13- rep = mkRTSRep (fromIntegral $9) $- mkHeapRep profile False (fromIntegral $5)- (fromIntegral $7) Thunk- -- not really Thunk, but that makes the info table- -- we want.- return (mkCmmEntryLabel pkg $3,- Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3- , cit_rep = rep- , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },- []) }+ {% do+ home_unit_id <- getHomeUnitId+ liftP $ pure $ do+ profile <- getProfile+ let prof = profilingInfo profile $11 $13+ rep = mkRTSRep (fromIntegral $9) $+ mkHeapRep profile False (fromIntegral $5)+ (fromIntegral $7) Thunk+ -- not really Thunk, but that makes the info table+ -- we want.+ return (mkCmmEntryLabel home_unit_id $3,+ Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id $3+ , cit_rep = rep+ , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },+ []) } | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')' -- ptrs, nptrs, closure type, description, type, fun type- {% liftP . withHomeUnitId $ \pkg ->- do profile <- getProfile- let prof = profilingInfo profile $11 $13- ty = Fun 0 (ArgSpec (fromIntegral $15))- -- Arity zero, arg_type $15- rep = mkRTSRep (fromIntegral $9) $- mkHeapRep profile False (fromIntegral $5)- (fromIntegral $7) ty- return (mkCmmEntryLabel pkg $3,- Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3- , cit_rep = rep- , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },- []) }+ {% do+ home_unit_id <- getHomeUnitId+ liftP $ pure $ do+ profile <- getProfile+ let prof = profilingInfo profile $11 $13+ ty = Fun 0 (ArgSpec (fromIntegral $15))+ -- Arity zero, arg_type $15+ rep = mkRTSRep (fromIntegral $9) $+ mkHeapRep profile False (fromIntegral $5)+ (fromIntegral $7) ty+ return (mkCmmEntryLabel home_unit_id $3,+ Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id $3+ , cit_rep = rep+ , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },+ []) } -- we leave most of the fields zero here. This is only used -- to generate the BCO info table in the RTS at the moment. | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' -- ptrs, nptrs, tag, closure type, description, type- {% liftP . withHomeUnitId $ \pkg ->- do profile <- getProfile- let prof = profilingInfo profile $13 $15- ty = Constr (fromIntegral $9) -- Tag- (BS8.pack $13)- rep = mkRTSRep (fromIntegral $11) $- mkHeapRep profile False (fromIntegral $5)- (fromIntegral $7) ty- return (mkCmmEntryLabel pkg $3,- Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3- , cit_rep = rep- , cit_prof = prof, cit_srt = Nothing,cit_clo = Nothing },- []) }+ {% do+ home_unit_id <- getHomeUnitId+ liftP $ pure $ do+ profile <- getProfile+ let prof = profilingInfo profile $13 $15+ ty = Constr (fromIntegral $9) -- Tag+ (BS8.pack $13)+ rep = mkRTSRep (fromIntegral $11) $+ mkHeapRep profile False (fromIntegral $5)+ (fromIntegral $7) ty+ return (mkCmmEntryLabel home_unit_id $3,+ Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id $3+ , cit_rep = rep+ , cit_prof = prof, cit_srt = Nothing,cit_clo = Nothing },+ []) } -- If profiling is on, this string gets duplicated, -- but that's the way the old code did it we can fix it some other time. | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')' -- selector, closure type, description, type- {% liftP . withHomeUnitId $ \pkg ->- do profile <- getProfile- let prof = profilingInfo profile $9 $11- ty = ThunkSelector (fromIntegral $5)- rep = mkRTSRep (fromIntegral $7) $- mkHeapRep profile False 0 0 ty- return (mkCmmEntryLabel pkg $3,- Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3- , cit_rep = rep- , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },- []) }+ {% do+ home_unit_id <- getHomeUnitId+ liftP $ pure $ do+ profile <- getProfile+ let prof = profilingInfo profile $9 $11+ ty = ThunkSelector (fromIntegral $5)+ rep = mkRTSRep (fromIntegral $7) $+ mkHeapRep profile False 0 0 ty+ return (mkCmmEntryLabel home_unit_id $3,+ Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id $3+ , cit_rep = rep+ , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },+ []) } | 'INFO_TABLE_RET' '(' NAME ',' INT ')' -- closure type (no live regs)- {% liftP . withHomeUnitId $ \pkg ->- do let prof = NoProfilingInfo- rep = mkRTSRep (fromIntegral $5) $ mkStackRep []- return (mkCmmRetLabel pkg $3,- Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3- , cit_rep = rep- , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },- []) }+ {% do+ home_unit_id <- getHomeUnitId+ liftP $ pure $ do+ let prof = NoProfilingInfo+ rep = mkRTSRep (fromIntegral $5) $ mkStackRep []+ return (mkCmmRetLabel home_unit_id $3,+ Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel home_unit_id $3+ , cit_rep = rep+ , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },+ []) } | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')' -- closure type, live regs- {% liftP . withHomeUnitId $ \pkg ->- do platform <- getPlatform- live <- sequence $7- let prof = NoProfilingInfo- -- drop one for the info pointer- bitmap = mkLiveness platform (drop 1 live)- rep = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap- return (mkCmmRetLabel pkg $3,- Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3- , cit_rep = rep- , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },- live) }+ {% do+ home_unit_id <- getHomeUnitId+ liftP $ pure $ do+ platform <- getPlatform+ live <- sequence $7+ let prof = NoProfilingInfo+ -- drop one for the info pointer+ bitmap = mkLiveness platform (drop 1 live)+ rep = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap+ return (mkCmmRetLabel home_unit_id $3,+ Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel home_unit_id $3+ , cit_rep = rep+ , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },+ live) } body :: { CmmParse () } : {- empty -} { return () }@@ -899,7 +918,7 @@ nameToMachOp :: FastString -> PD (Width -> MachOp) nameToMachOp name = case lookupUFM machOps name of- Nothing -> failMsgPD ("unknown primitive " ++ unpackFS name)+ Nothing -> failMsgPD $ Error (ErrCmmParser (CmmUnknownPrimitive name)) [] Just m -> return m exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr)@@ -1061,12 +1080,12 @@ parseSafety "safe" = return PlaySafe parseSafety "unsafe" = return PlayRisky parseSafety "interruptible" = return PlayInterruptible-parseSafety str = failMsgPD ("unrecognised safety: " ++ str)+parseSafety str = failMsgPD $ Error (ErrCmmParser (CmmUnrecognisedSafety str)) [] parseCmmHint :: String -> PD ForeignHint parseCmmHint "ptr" = return AddrHint parseCmmHint "signed" = return SignedHint-parseCmmHint str = failMsgPD ("unrecognised hint: " ++ str)+parseCmmHint str = failMsgPD $ Error (ErrCmmParser (CmmUnrecognisedHint str)) [] -- labels are always pointers, so we might as well infer the hint inferCmmHint :: CmmExpr -> ForeignHint@@ -1093,7 +1112,7 @@ stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ()) stmtMacro fun args_code = do case lookupUFM stmtMacros fun of- Nothing -> failMsgPD ("unknown macro: " ++ unpackFS fun)+ Nothing -> failMsgPD $ Error (ErrCmmParser (CmmUnknownMacro fun)) [] Just fcode -> return $ do args <- sequence args_code code (fcode args)@@ -1194,9 +1213,9 @@ -> PD (CmmParse ()) foreignCall conv_string results_code expr_code args_code safety ret = do conv <- case conv_string of- "C" -> return CCallConv+ "C" -> return CCallConv "stdcall" -> return StdCallConv- _ -> failMsgPD ("unknown calling convention: " ++ conv_string)+ _ -> failMsgPD $ Error (ErrCmmParser (CmmUnknownCConv conv_string)) [] return $ do platform <- getPlatform results <- sequence results_code@@ -1274,7 +1293,7 @@ = do platform <- PD.getPlatform case lookupUFM (callishMachOps platform) name of- Nothing -> failMsgPD ("unknown primitive " ++ unpackFS name)+ Nothing -> failMsgPD $ Error (ErrCmmParser (CmmUnknownPrimitive name)) [] Just f -> return $ do results <- sequence results_code args <- sequence args_code@@ -1428,8 +1447,8 @@ ] where platform = profilePlatform profile -parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)-parseCmmFile dflags filename = withTiming dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ do+parseCmmFile :: DynFlags -> FilePath -> IO (Bag Warning, Bag Error, Maybe CmmGroup)+parseCmmFile dflags filename = do buf <- hGetStringBuffer filename let init_loc = mkRealSrcLoc (mkFastString filename) 1 1@@ -1438,16 +1457,17 @@ -- reset the lex_state: the Lexer monad leaves some stuff -- in there we don't want. case unPD cmmParse dflags init_state of- PFailed pst ->- return (getMessages pst dflags, Nothing)+ PFailed pst -> do+ let (warnings,errors) = getMessages pst+ return (warnings, errors, Nothing) POk pst code -> do st <- initC let fcode = getCmm $ unEC code "global" (initEnv (targetProfile dflags)) [] >> return () (cmm,_) = runC dflags no_module st fcode- let ms = getMessages pst dflags- if (errorsFound dflags ms)- then return (ms, Nothing)- else return (ms, Just cmm)+ (warnings,errors) = getMessages pst+ if not (isEmptyBag errors)+ then return (warnings, errors, Nothing)+ else return (warnings, errors, Just cmm) where no_module = panic "parseCmmFile: no module" }
+ compiler/GHC/Cmm/Parser/Monad.hs view
@@ -0,0 +1,84 @@+-----------------------------------------------------------------------------+-- A Parser monad with access to the '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',+-- so 'PD' provides access to 'DynFlags' via a 'HasDynFlags' instance.+-----------------------------------------------------------------------------+module GHC.Cmm.Parser.Monad (+ PD(..)+ , liftP+ , failMsgPD+ , getProfile+ , getPlatform+ , getPtrOpts+ , getHomeUnitId+ ) where++import GHC.Prelude++import GHC.Platform+import GHC.Platform.Profile+import GHC.Cmm.Info++import Control.Monad++import GHC.Driver.Session+import GHC.Parser.Lexer+import GHC.Parser.Errors+import GHC.Types.SrcLoc+import GHC.Unit.Types+import GHC.Unit.Home++newtype PD a = PD { unPD :: DynFlags -> PState -> ParseResult a }++instance Functor PD where+ fmap = liftM++instance Applicative PD where+ pure = returnPD+ (<*>) = ap++instance Monad PD where+ (>>=) = thenPD++liftP :: P a -> PD a+liftP (P f) = PD $ \_ s -> f s++failMsgPD :: (SrcSpan -> Error) -> PD a+failMsgPD = liftP . failMsgP++returnPD :: a -> PD a+returnPD = liftP . return++thenPD :: PD a -> (a -> PD b) -> PD b+(PD m) `thenPD` k = PD $ \d s ->+ case m d s of+ POk s1 a -> unPD (k a) d s1+ PFailed s1 -> PFailed s1++instance HasDynFlags PD where+ getDynFlags = PD $ \d s -> POk s d++getProfile :: PD Profile+getProfile = targetProfile <$> getDynFlags++getPlatform :: PD Platform+getPlatform = profilePlatform <$> getProfile++getPtrOpts :: PD PtrOpts+getPtrOpts = do+ dflags <- getDynFlags+ profile <- getProfile+ pure $ PtrOpts+ { po_profile = profile+ , po_align_check = gopt Opt_AlignmentSanitisation dflags+ }++-- | Return the UnitId of the home-unit. This is used to create labels.+getHomeUnitId :: PD UnitId+getHomeUnitId = do+ dflags <- getDynFlags+ pure (homeUnitId (mkHomeUnitFromFlags dflags))
compiler/GHC/Cmm/Pipeline.hs view
@@ -1,6 +1,4 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE TupleSections #-} module GHC.Cmm.Pipeline ( -- | Converts C-- with an implicit stack and native C-- calls into@@ -26,7 +24,7 @@ import GHC.Driver.Session import GHC.Driver.Backend import GHC.Utils.Error-import GHC.Driver.Types+import GHC.Driver.Env import Control.Monad import GHC.Utils.Outputable import GHC.Platform@@ -64,95 +62,95 @@ cpsTop dflags p@(CmmData _ statics) = return (Right (cafAnalData (targetPlatform dflags) statics, p)) cpsTop dflags proc = do- ----------- Control-flow optimisations ----------------------------------+ ----------- Control-flow optimisations ---------------------------------- - -- The first round of control-flow optimisation speeds up the- -- later passes by removing lots of empty blocks, so we do it- -- even when optimisation isn't turned on.- --- CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-}- return $ cmmCfgOptsProc splitting_proc_points proc- dump Opt_D_dump_cmm_cfg "Post control-flow optimisations" g+ -- The first round of control-flow optimisation speeds up the+ -- later passes by removing lots of empty blocks, so we do it+ -- even when optimisation isn't turned on.+ --+ CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-}+ return $ cmmCfgOptsProc splitting_proc_points proc+ dump Opt_D_dump_cmm_cfg "Post control-flow optimisations" g - let !TopInfo {stack_info=StackInfo { arg_space = entry_off- , do_layout = do_layout }} = h+ let !TopInfo {stack_info=StackInfo { arg_space = entry_off+ , do_layout = do_layout }} = h - ----------- Eliminate common blocks -------------------------------------- g <- {-# SCC "elimCommonBlocks" #-}- condPass Opt_CmmElimCommonBlocks elimCommonBlocks g- Opt_D_dump_cmm_cbe "Post common block elimination"+ ----------- Eliminate common blocks -------------------------------------+ g <- {-# SCC "elimCommonBlocks" #-}+ condPass Opt_CmmElimCommonBlocks elimCommonBlocks g+ Opt_D_dump_cmm_cbe "Post common block elimination" - -- Any work storing block Labels must be performed _after_- -- elimCommonBlocks+ -- Any work storing block Labels must be performed _after_+ -- elimCommonBlocks - ----------- Implement switches ------------------------------------------- g <- {-# SCC "createSwitchPlans" #-}- runUniqSM $ cmmImplementSwitchPlans (backend dflags) platform g- dump Opt_D_dump_cmm_switch "Post switch plan" g+ ----------- Implement switches ------------------------------------------+ g <- {-# SCC "createSwitchPlans" #-}+ runUniqSM $ cmmImplementSwitchPlans (backend dflags) platform g+ dump Opt_D_dump_cmm_switch "Post switch plan" g - ----------- Proc points -------------------------------------------------- let- call_pps :: ProcPointSet -- LabelMap- call_pps = {-# SCC "callProcPoints" #-} callProcPoints g- proc_points <-- if splitting_proc_points- then do- pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $- minimalProcPointSet platform call_pps g- dumpWith dflags Opt_D_dump_cmm_proc "Proc points"- FormatCMM (pdoc platform l $$ ppr pp $$ pdoc platform g)- return pp- else- return call_pps+ ----------- Proc points -------------------------------------------------+ let+ call_pps :: ProcPointSet -- LabelMap+ call_pps = {-# SCC "callProcPoints" #-} callProcPoints g+ proc_points <-+ if splitting_proc_points+ then do+ pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $+ minimalProcPointSet platform call_pps g+ dumpWith dflags Opt_D_dump_cmm_proc "Proc points"+ FormatCMM (pdoc platform l $$ ppr pp $$ pdoc platform g)+ return pp+ else+ return call_pps - ----------- Layout the stack and manifest Sp ----------------------------- (g, stackmaps) <-- {-# SCC "layoutStack" #-}- if do_layout- then runUniqSM $ cmmLayoutStack dflags proc_points entry_off g- else return (g, mapEmpty)- dump Opt_D_dump_cmm_sp "Layout Stack" g+ ----------- Layout the stack and manifest Sp ----------------------------+ (g, stackmaps) <-+ {-# SCC "layoutStack" #-}+ if do_layout+ then runUniqSM $ cmmLayoutStack dflags proc_points entry_off g+ else return (g, mapEmpty)+ dump Opt_D_dump_cmm_sp "Layout Stack" g - ----------- Sink and inline assignments --------------------------------- g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout]- condPass Opt_CmmSink (cmmSink platform) g- Opt_D_dump_cmm_sink "Sink assignments"+ ----------- Sink and inline assignments --------------------------------+ g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout]+ condPass Opt_CmmSink (cmmSink platform) g+ Opt_D_dump_cmm_sink "Sink assignments" - ------------- CAF analysis ----------------------------------------------- let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform call_pps l g- dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" FormatText (pdoc platform cafEnv)+ ------------- CAF analysis ----------------------------------------------+ let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform call_pps l g+ dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" FormatText (pdoc platform cafEnv) - g <- if splitting_proc_points- then do- ------------- Split into separate procedures ------------------------ let pp_map = {-# SCC "procPointAnalysis" #-}- procPointAnalysis proc_points g- dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map"- FormatCMM (ppr pp_map)- g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $- splitAtProcPoints platform l call_pps proc_points pp_map- (CmmProc h l v g)- dumps Opt_D_dump_cmm_split "Post splitting" g- return g- else do- -- attach info tables to return points- return $ [attachContInfoTables call_pps (CmmProc h l v g)]+ g <- if splitting_proc_points+ then do+ ------------- Split into separate procedures -----------------------+ let pp_map = {-# SCC "procPointAnalysis" #-}+ procPointAnalysis proc_points g+ dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map"+ FormatCMM (ppr pp_map)+ g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $+ splitAtProcPoints platform l call_pps proc_points pp_map+ (CmmProc h l v g)+ dumps Opt_D_dump_cmm_split "Post splitting" g+ return g+ else+ -- attach info tables to return points+ return $ [attachContInfoTables call_pps (CmmProc h l v g)] - ------------- Populate info tables with stack info ------------------ g <- {-# SCC "setInfoTableStackMap" #-}- return $ map (setInfoTableStackMap platform stackmaps) g- dumps Opt_D_dump_cmm_info "after setInfoTableStackMap" g+ ------------- Populate info tables with stack info -----------------+ g <- {-# SCC "setInfoTableStackMap" #-}+ return $ map (setInfoTableStackMap platform stackmaps) g+ dumps Opt_D_dump_cmm_info "after setInfoTableStackMap" g - ----------- Control-flow optimisations ------------------------------ g <- {-# SCC "cmmCfgOpts(2)" #-}- return $ if optLevel dflags >= 1- then map (cmmCfgOptsProc splitting_proc_points) g- else g- g <- return (map removeUnreachableBlocksProc g)- -- See Note [unreachable blocks]- dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g+ ----------- Control-flow optimisations -----------------------------+ g <- {-# SCC "cmmCfgOpts(2)" #-}+ return $ if optLevel dflags >= 1+ then map (cmmCfgOptsProc splitting_proc_points) g+ else g+ g <- return (map removeUnreachableBlocksProc g)+ -- See Note [unreachable blocks]+ dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g - return (Left (cafEnv, g))+ return (Left (cafEnv, g)) where platform = targetPlatform dflags dump = dumpGraph dflags
compiler/GHC/Cmm/ProcPoint.hs view
@@ -1,4 +1,7 @@-{-# LANGUAGE GADTs, DisambiguateRecordFields, BangPatterns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE GADTs #-}+ {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Cmm.ProcPoint@@ -237,155 +240,152 @@ -- Input invariant: A block should only be reachable from a single ProcPoint. -- ToDo: use the _ret naming convention that the old code generator -- used. -- EZY-splitAtProcPoints :: Platform -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status ->- CmmDecl -> UniqSM [CmmDecl]-splitAtProcPoints platform entry_label callPPs procPoints procMap- (CmmProc (TopInfo {info_tbls = info_tbls})- top_l _ g@(CmmGraph {g_entry=entry})) =- do -- Build a map from procpoints to the blocks they reach- let add_block- :: LabelMap (LabelMap CmmBlock)- -> CmmBlock- -> LabelMap (LabelMap CmmBlock)- add_block graphEnv b =- case mapLookup bid procMap of- Just ProcPoint -> add graphEnv bid bid b- Just (ReachedBy set) ->- case setElems set of- [] -> graphEnv- [id] -> add graphEnv id bid b- _ -> panic "Each block should be reachable from only one ProcPoint"- Nothing -> graphEnv- where bid = entryLabel b- add graphEnv procId bid b = mapInsert procId graph' graphEnv- where graph = mapLookup procId graphEnv `orElse` mapEmpty- graph' = mapInsert bid b graph+splitAtProcPoints :: Platform -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status -> CmmDecl+ -> UniqSM [CmmDecl]+splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]+splitAtProcPoints platform entry_label callPPs procPoints procMap cmmProc = do+ -- Build a map from procpoints to the blocks they reach+ let (CmmProc (TopInfo {info_tbls = info_tbls}) top_l _ g@(CmmGraph {g_entry=entry})) = cmmProc - let liveness = cmmGlobalLiveness platform g- let ppLiveness pp = filter isArgReg $- regSetToList $- expectJust "ppLiveness" $ mapLookup pp liveness+ let add graphEnv procId bid b = mapInsert procId graph' graphEnv+ where+ graph' = mapInsert bid b graph+ graph = mapLookup procId graphEnv `orElse` mapEmpty - graphEnv <- return $ foldlGraphBlocks add_block mapEmpty g+ let add_block :: LabelMap (LabelMap CmmBlock) -> CmmBlock -> LabelMap (LabelMap CmmBlock)+ add_block graphEnv b =+ case mapLookup bid procMap of+ Just ProcPoint -> add graphEnv bid bid b+ Just (ReachedBy set) ->+ case setElems set of+ [] -> graphEnv+ [id] -> add graphEnv id bid b+ _ -> panic "Each block should be reachable from only one ProcPoint"+ Nothing -> graphEnv+ where+ bid = entryLabel b - -- Build a map from proc point BlockId to pairs of:- -- * Labels for their new procedures- -- * Labels for the info tables of their new procedures (only if- -- the proc point is a callPP)- -- Due to common blockification, we may overestimate the set of procpoints.- let add_label map pp = mapInsert pp lbls map- where lbls | pp == entry = (entry_label, fmap cit_lbl (mapLookup entry info_tbls))- | otherwise = (block_lbl, guard (setMember pp callPPs) >>- Just info_table_lbl)- where block_lbl = blockLbl pp- info_table_lbl = infoTblLbl pp - procLabels :: LabelMap (CLabel, Maybe CLabel)- procLabels = foldl' add_label mapEmpty- (filter (flip mapMember (toBlockMap g)) (setElems procPoints))+ let liveness = cmmGlobalLiveness platform g+ let ppLiveness pp = filter isArgReg $ regSetToList $+ expectJust "ppLiveness" $ mapLookup pp liveness+ graphEnv <- return $ foldlGraphBlocks add_block mapEmpty g - -- In each new graph, add blocks jumping off to the new procedures,- -- and replace branches to procpoints with branches to the jump-off blocks- let add_jump_block- :: (LabelMap Label, [CmmBlock])- -> (Label, CLabel)- -> UniqSM (LabelMap Label, [CmmBlock])- add_jump_block (env, bs) (pp, l) =- do bid <- liftM mkBlockId getUniqueM- let b = blockJoin (CmmEntry bid GlobalScope) emptyBlock jump- live = ppLiveness pp- jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0- return (mapInsert pp bid env, b : bs)+ -- Build a map from proc point BlockId to pairs of:+ -- * Labels for their new procedures+ -- * Labels for the info tables of their new procedures (only if+ -- the proc point is a callPP)+ -- Due to common blockification, we may overestimate the set of procpoints.+ let add_label map pp = mapInsert pp lbls map+ where lbls | pp == entry = (entry_label, fmap cit_lbl (mapLookup entry info_tbls))+ | otherwise = (block_lbl, guard (setMember pp callPPs) >>+ Just info_table_lbl)+ where block_lbl = blockLbl pp+ info_table_lbl = infoTblLbl pp - add_jumps- :: LabelMap CmmGraph- -> (Label, LabelMap CmmBlock)- -> UniqSM (LabelMap CmmGraph)- add_jumps newGraphEnv (ppId, blockEnv) =- do let needed_jumps = -- find which procpoints we currently branch to- mapFoldr add_if_branch_to_pp [] blockEnv- add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]- add_if_branch_to_pp block rst =- case lastNode block of- CmmBranch id -> add_if_pp id rst- CmmCondBranch _ ti fi _ -> add_if_pp ti (add_if_pp fi rst)- CmmSwitch _ ids -> foldr add_if_pp rst $ switchTargetsToList ids- _ -> rst+ procLabels :: LabelMap (CLabel, Maybe CLabel)+ procLabels = foldl' add_label mapEmpty+ (filter (flip mapMember (toBlockMap g)) (setElems procPoints)) - -- when jumping to a PP that has an info table, if- -- tablesNextToCode is off we must jump to the entry- -- label instead.- tablesNextToCode = platformTablesNextToCode platform- jump_label (Just info_lbl) _- | tablesNextToCode = info_lbl- | otherwise = toEntryLbl platform info_lbl- jump_label Nothing block_lbl = block_lbl+ -- In each new graph, add blocks jumping off to the new procedures,+ -- and replace branches to procpoints with branches to the jump-off blocks+ let add_jump_block :: (LabelMap Label, [CmmBlock])+ -> (Label, CLabel)+ -> UniqSM (LabelMap Label, [CmmBlock])+ add_jump_block (env, bs) (pp, l) = do+ bid <- liftM mkBlockId getUniqueM+ let b = blockJoin (CmmEntry bid GlobalScope) emptyBlock jump+ live = ppLiveness pp+ jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0+ return (mapInsert pp bid env, b : bs) - add_if_pp id rst = case mapLookup id procLabels of- Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst- Nothing -> rst- (jumpEnv, jumpBlocks) <-- foldM add_jump_block (mapEmpty, []) needed_jumps- -- update the entry block- let b = expectJust "block in env" $ mapLookup ppId blockEnv- blockEnv' = mapInsert ppId b blockEnv- -- replace branches to procpoints with branches to jumps- blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv'- -- add the jump blocks to the graph- blockEnv''' = foldl' (flip addBlock) blockEnv'' jumpBlocks- let g' = ofBlockMap ppId blockEnv'''- -- pprTrace "g' pre jumps" (ppr g') $ do- return (mapInsert ppId g' newGraphEnv)+ -- when jumping to a PP that has an info table, if+ -- tablesNextToCode is off we must jump to the entry+ -- label instead.+ let tablesNextToCode = platformTablesNextToCode platform - graphEnv <- foldM add_jumps mapEmpty $ mapToList graphEnv+ let jump_label (Just info_lbl) _+ | tablesNextToCode = info_lbl+ | otherwise = toEntryLbl platform info_lbl+ jump_label Nothing block_lbl = block_lbl - let to_proc (bid, g)- | bid == entry- = CmmProc (TopInfo {info_tbls = info_tbls,- stack_info = stack_info})- top_l live g'- | otherwise- = case expectJust "pp label" $ mapLookup bid procLabels of- (lbl, Just info_lbl)- -> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl)- , stack_info=stack_info})- lbl live g'- (lbl, Nothing)- -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info})- lbl live g'- where- g' = replacePPIds g- live = ppLiveness (g_entry g')- stack_info = StackInfo { arg_space = 0- , do_layout = True }- -- cannot use panic, this is printed by -ddump-cmm+ let add_if_pp id rst =+ case mapLookup id procLabels of+ Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst+ Nothing -> rst - -- References to procpoint IDs can now be replaced with the- -- infotable's label- replacePPIds g = {-# SCC "replacePPIds" #-}- mapGraphNodes (id, mapExp repl, mapExp repl) g- where repl e@(CmmLit (CmmBlock bid)) =- case mapLookup bid procLabels of- Just (_, Just info_lbl) -> CmmLit (CmmLabel info_lbl)- _ -> e- repl e = e+ let add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]+ add_if_branch_to_pp block rst =+ case lastNode block of+ CmmBranch id -> add_if_pp id rst+ CmmCondBranch _ ti fi _ -> add_if_pp ti (add_if_pp fi rst)+ CmmSwitch _ ids -> foldr add_if_pp rst $ switchTargetsToList ids+ _ -> rst - -- The C back end expects to see return continuations before the- -- call sites. Here, we sort them in reverse order -- it gets- -- reversed later.- let (_, block_order) =- foldl' add_block_num (0::Int, mapEmpty :: LabelMap Int)- (revPostorder g)- add_block_num (i, map) block =- (i + 1, mapInsert (entryLabel block) i map)- sort_fn (bid, _) (bid', _) =- compare (expectJust "block_order" $ mapLookup bid block_order)- (expectJust "block_order" $ mapLookup bid' block_order)- procs <- return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv- return -- pprTrace "procLabels" (ppr procLabels)- -- pprTrace "splitting graphs" (ppr procs)- procs-splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]+ let add_jumps :: LabelMap CmmGraph -> (Label, LabelMap CmmBlock) -> UniqSM (LabelMap CmmGraph)+ add_jumps newGraphEnv (ppId, blockEnv) = do+ -- find which procpoints we currently branch to+ let needed_jumps = mapFoldr add_if_branch_to_pp [] blockEnv++ (jumpEnv, jumpBlocks) <-+ foldM add_jump_block (mapEmpty, []) needed_jumps+ -- update the entry block+ let b = expectJust "block in env" $ mapLookup ppId blockEnv+ blockEnv' = mapInsert ppId b blockEnv+ -- replace branches to procpoints with branches to jumps+ blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv'+ -- add the jump blocks to the graph+ blockEnv''' = foldl' (flip addBlock) blockEnv'' jumpBlocks+ let g' = ofBlockMap ppId blockEnv'''+ -- pprTrace "g' pre jumps" (ppr g') $ do+ return (mapInsert ppId g' newGraphEnv)++ graphEnv <- foldM add_jumps mapEmpty $ mapToList graphEnv++ let to_proc (bid, g)+ | bid == entry+ = CmmProc (TopInfo {info_tbls = info_tbls,+ stack_info = stack_info})+ top_l live g'+ | otherwise+ = case expectJust "pp label" $ mapLookup bid procLabels of+ (lbl, Just info_lbl)+ -> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl)+ , stack_info=stack_info})+ lbl live g'+ (lbl, Nothing)+ -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info})+ lbl live g'+ where+ g' = replacePPIds g+ live = ppLiveness (g_entry g')+ stack_info = StackInfo { arg_space = 0+ , do_layout = True }+ -- cannot use panic, this is printed by -ddump-cmm++ -- References to procpoint IDs can now be replaced with the+ -- infotable's label+ replacePPIds g = {-# SCC "replacePPIds" #-}+ mapGraphNodes (id, mapExp repl, mapExp repl) g+ where repl e@(CmmLit (CmmBlock bid)) =+ case mapLookup bid procLabels of+ Just (_, Just info_lbl) -> CmmLit (CmmLabel info_lbl)+ _ -> e+ repl e = e++ -- The C back end expects to see return continuations before the+ -- call sites. Here, we sort them in reverse order -- it gets+ -- reversed later.+ let add_block_num (i, map) block =+ (i + 1, mapInsert (entryLabel block) i map)+ let (_, block_order) =+ foldl' add_block_num (0::Int, mapEmpty :: LabelMap Int)+ (revPostorder g)+ let sort_fn (bid, _) (bid', _) =+ compare (expectJust "block_order" $ mapLookup bid block_order)+ (expectJust "block_order" $ mapLookup bid' block_order)++ return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv -- Only called from GHC.Cmm.ProcPoint.splitAtProcPoints. NB. does a -- recursive lookup, see comment below.
compiler/GHC/CmmToAsm.hs view
@@ -1101,30 +1101,28 @@ arch = platformArch platform case expr of CmmLoad addr rep- -> do addr' <- cmmExprNative DataReference addr- return $ CmmLoad addr' rep+ -> do addr' <- cmmExprNative DataReference addr+ return $ CmmLoad addr' rep CmmMachOp mop args- -> do args' <- mapM (cmmExprNative DataReference) args- return $ CmmMachOp mop args'+ -> do args' <- mapM (cmmExprNative DataReference) args+ return $ CmmMachOp mop args' CmmLit (CmmBlock id)- -> cmmExprNative referenceKind (CmmLit (CmmLabel (infoTblLbl id)))- -- we must convert block Ids to CLabels here, because we- -- might have to do the PIC transformation. Hence we must- -- not modify BlockIds beyond this point.+ -> cmmExprNative referenceKind (CmmLit (CmmLabel (infoTblLbl id)))+ -- we must convert block Ids to CLabels here, because we+ -- might have to do the PIC transformation. Hence we must+ -- not modify BlockIds beyond this point. CmmLit (CmmLabel lbl)- -> do- cmmMakeDynamicReference config referenceKind lbl+ -> cmmMakeDynamicReference config referenceKind lbl CmmLit (CmmLabelOff lbl off)- -> do- dynRef <- cmmMakeDynamicReference config referenceKind lbl- -- need to optimize here, since it's late- return $ cmmMachOpFold platform (MO_Add (wordWidth platform)) [- dynRef,- (CmmLit $ CmmInt (fromIntegral off) (wordWidth platform))- ]+ -> do dynRef <- cmmMakeDynamicReference config referenceKind lbl+ -- need to optimize here, since it's late+ return $ cmmMachOpFold platform (MO_Add (wordWidth platform)) [+ dynRef,+ (CmmLit $ CmmInt (fromIntegral off) (wordWidth platform))+ ] -- On powerpc (non-PIC), it's easier to jump directly to a label than -- to use the register table, so we replace these registers@@ -1174,7 +1172,7 @@ ArchX86 -> bmiVersion dflags _ -> Nothing - -- We Assume SSE1 and SSE2 operations are available on both+ -- We assume SSE1 and SSE2 operations are available on both -- x86 and x86_64. Historically we didn't default to SSE2 and -- SSE1 on x86, which results in defacto nondeterminism for how -- rounding behaves in the associated x87 floating point instructions
compiler/GHC/CmmToAsm/BlockLayout.hs view
@@ -1,15 +1,14 @@------ Copyright (c) 2018 Andreas Klebinger---- {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-} +--+-- Copyright (c) 2018 Andreas Klebinger+--+ module GHC.CmmToAsm.BlockLayout ( sequenceTop, backendMaintainsCfg) where@@ -476,7 +475,6 @@ applyEdges edges newEnds newFronts (Set.insert (from,to) combined) | otherwise = applyEdges edges chainEnds chainFronts combined- where getFronts chain = takeL neighbourOverlapp chain getEnds chain = takeR neighbourOverlapp chain@@ -589,19 +587,14 @@ , Just predChain <- mapLookup from chainEnds , Just succChain <- mapLookup to chainStarts , predChain /= succChain -- Otherwise we try to create a cycle.- = do- -- pprTraceM "Fusing edge" (ppr edge)- fuseChain predChain succChain+ = fuseChain predChain succChain | (alreadyPlaced from) && (alreadyPlaced to)- = --pprTraceM "Skipping:" (ppr edge) >>- buildNext placed chainStarts chainEnds todo linked+ = buildNext placed chainStarts chainEnds todo linked | otherwise- = do -- pprTraceM "Finding chain for:" (ppr edge $$- -- text "placed" <+> ppr placed)- findChain+ = findChain where from = edgeFrom edge to = edgeTo edge
compiler/GHC/CmmToAsm/CFG.hs view
@@ -1,14 +1,12 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-} -- -- Copyright (c) 2018 Andreas Klebinger ----{-# LANGUAGE TypeFamilies, ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DataKinds #-} module GHC.CmmToAsm.CFG ( CFG, CfgEdge(..), EdgeInfo(..), EdgeWeight(..)
compiler/GHC/CmmToAsm/CFG/Dominators.hs view
@@ -1,4 +1,7 @@-{-# LANGUAGE RankNTypes, BangPatterns, FlexibleContexts, Strict #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Strict #-} {- | Module : GHC.CmmToAsm.CFG.Dominators@@ -250,7 +253,7 @@ zw <- sizeM w store labelE s lw store sizeE v . (+zw) =<< sizeM v- let follow s = do+ let follow s = when (s /= n0) (do store ancestorE s v follow =<< childM s)
compiler/GHC/CmmToAsm/PPC/CodeGen.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE CPP, GADTs #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- --@@ -117,7 +118,7 @@ return (CmmProc info lab live (ListGraph (b':blocks)) : statics) fixup_entry _ = panic "cmmTopCodegen: Broken CmmProc" -cmmTopCodeGen (CmmData sec dat) = do+cmmTopCodeGen (CmmData sec dat) = return [CmmData sec dat] -- no translation, we just use CmmStatic basicBlockCodeGen@@ -787,7 +788,7 @@ (reg, code) <- getSomeReg x (reg', off', code') <- if i `mod` 4 == 0- then do return (reg, off, code)+ then return (reg, off, code) else do tmp <- getNewRegNat II64 return (tmp, ImmInt 0,@@ -800,7 +801,7 @@ (reg, code) <- getSomeReg x (reg', off', code') <- if i `mod` 4 == 0- then do return (reg, off, code)+ then return (reg, off, code) else do tmp <- getNewRegNat II64 return (tmp, ImmInt 0,@@ -882,8 +883,7 @@ -- extend small integers to 32 bit or 64 bit first getCondCode (CmmMachOp mop [x, y])- = do- case mop of+ = case mop of MO_F_Eq W32 -> condFltCode EQQ x y MO_F_Ne W32 -> condFltCode NE x y MO_F_Gt W32 -> condFltCode GTT x y@@ -1670,7 +1670,7 @@ codeAfter = move_sp_up finalStack `appOL` moveResult reduceToFF32 case labelOrExpr of- Left lbl -> do -- the linker does all the work for us+ Left lbl -> -- the linker does all the work for us return ( codeBefore `snocOL` BL lbl usedRegs `appOL` maybeNOP -- some ABI require a NOP after BL@@ -1716,7 +1716,7 @@ where platform = ncgPlatform config - uses_pic_base_implicitly = do+ uses_pic_base_implicitly = -- See Note [implicit register in PPC PIC code] -- on why we claim to use PIC register here when (ncgPIC config && target32Bit platform) $ do
compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs view
@@ -1,4 +1,3 @@- -- | When there aren't enough registers to hold all the vregs we have to spill -- some of those vregs to slots on the stack. This module is used modify the -- code to use those slots.@@ -7,6 +6,7 @@ SpillStats(..), accSpillSL ) where+ import GHC.Prelude import GHC.CmmToAsm.Reg.Liveness@@ -182,46 +182,41 @@ -> UniqFM Reg Int -- ^ map of vregs to slots they're being spilled to. -> LiveInstr instr -> SpillM [LiveInstr instr]--regSpill_instr _ _ li@(LiveInstr _ Nothing)- = do return [li]--regSpill_instr platform regSlotMap- (LiveInstr instr (Just _))- = do- -- work out which regs are read and written in this instr- let RU rlRead rlWritten = regUsageOfInstr platform instr+regSpill_instr _ _ li@(LiveInstr _ Nothing) = return [li]+regSpill_instr platform regSlotMap (LiveInstr instr (Just _)) = do+ -- work out which regs are read and written in this instr+ let RU rlRead rlWritten = regUsageOfInstr platform instr - -- sometimes a register is listed as being read more than once,- -- nub this so we don't end up inserting two lots of spill code.- let rsRead_ = nub rlRead- let rsWritten_ = nub rlWritten+ -- sometimes a register is listed as being read more than once,+ -- nub this so we don't end up inserting two lots of spill code.+ let rsRead_ = nub rlRead+ let rsWritten_ = nub rlWritten - -- if a reg is modified, it appears in both lists, want to undo this..- let rsRead = rsRead_ \\ rsWritten_- let rsWritten = rsWritten_ \\ rsRead_- let rsModify = intersect rsRead_ rsWritten_+ -- if a reg is modified, it appears in both lists, want to undo this..+ let rsRead = rsRead_ \\ rsWritten_+ let rsWritten = rsWritten_ \\ rsRead_+ let rsModify = intersect rsRead_ rsWritten_ - -- work out if any of the regs being used are currently being spilled.- let rsSpillRead = filter (\r -> elemUFM r regSlotMap) rsRead- let rsSpillWritten = filter (\r -> elemUFM r regSlotMap) rsWritten- let rsSpillModify = filter (\r -> elemUFM r regSlotMap) rsModify+ -- work out if any of the regs being used are currently being spilled.+ let rsSpillRead = filter (\r -> elemUFM r regSlotMap) rsRead+ let rsSpillWritten = filter (\r -> elemUFM r regSlotMap) rsWritten+ let rsSpillModify = filter (\r -> elemUFM r regSlotMap) rsModify - -- rewrite the instr and work out spill code.- (instr1, prepost1) <- mapAccumLM (spillRead regSlotMap) instr rsSpillRead- (instr2, prepost2) <- mapAccumLM (spillWrite regSlotMap) instr1 rsSpillWritten- (instr3, prepost3) <- mapAccumLM (spillModify regSlotMap) instr2 rsSpillModify+ -- rewrite the instr and work out spill code.+ (instr1, prepost1) <- mapAccumLM (spillRead regSlotMap) instr rsSpillRead+ (instr2, prepost2) <- mapAccumLM (spillWrite regSlotMap) instr1 rsSpillWritten+ (instr3, prepost3) <- mapAccumLM (spillModify regSlotMap) instr2 rsSpillModify - let (mPrefixes, mPostfixes) = unzip (prepost1 ++ prepost2 ++ prepost3)- let prefixes = concat mPrefixes- let postfixes = concat mPostfixes+ let (mPrefixes, mPostfixes) = unzip (prepost1 ++ prepost2 ++ prepost3)+ let prefixes = concat mPrefixes+ let postfixes = concat mPostfixes - -- final code- let instrs' = prefixes- ++ [LiveInstr instr3 Nothing]- ++ postfixes+ -- final code+ let instrs' = prefixes+ ++ [LiveInstr instr3 Nothing]+ ++ postfixes - return $ instrs'+ return instrs' -- | Add a RELOAD met a instruction to load a value for an instruction that
compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE ScopedTypeVariables, GADTs, BangPatterns #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+ module GHC.CmmToAsm.Reg.Graph.SpillCost ( SpillCostRecord, plusSpillCostRecord,
compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}- -- | Free regs map for PowerPC module GHC.CmmToAsm.Reg.Linear.PPC where
compiler/GHC/CmmToAsm/Reg/Linear/SPARC.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Free regs map for SPARC module GHC.CmmToAsm.Reg.Linear.SPARC where
compiler/GHC/CmmToAsm/SPARC/CodeGen.hs view
@@ -73,7 +73,7 @@ return tops -cmmTopCodeGen (CmmData sec dat) = do+cmmTopCodeGen (CmmData sec dat) = return [CmmData sec dat] -- no translation, we just use CmmStatic @@ -430,8 +430,8 @@ PrimTarget mop -> do res <- outOfLineMachOp mop- lblOrMopExpr <- case res of- Left lbl -> do+ case res of+ Left lbl -> return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) Right mopExpr -> do@@ -440,8 +440,6 @@ [dyn_r'] -> dyn_r' _ -> panic "SPARC.CodeGen.genCCall: arg_to_int" return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)-- return lblOrMopExpr let argcode = concatOL argcodes
compiler/GHC/CmmToAsm/X86/CodeGen.hs view
@@ -1,6 +1,8 @@-{-# LANGUAGE CPP, GADTs, NondecreasingIndentation #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE TupleSections #-} #if __GLASGOW_HASKELL__ <= 808 -- GHC 8.10 deprecates this flag, but GHC 8.8 needs it@@ -68,7 +70,7 @@ -- Our intermediate code: import GHC.Types.Basic import GHC.Cmm.BlockId-import GHC.Unit ( primUnitId )+import GHC.Unit.Types ( primUnitId ) import GHC.Cmm.Utils import GHC.Cmm.Switch import GHC.Cmm@@ -131,7 +133,7 @@ Just picBase -> initializePicBase_x86 ArchX86 os picBase tops Nothing -> return tops -cmmTopCodeGen (CmmData sec dat) = do+cmmTopCodeGen (CmmData sec dat) = return [CmmData sec (mkAlignment 1, dat)] -- no translation, we just use CmmStatic {- Note [Verifying basic blocks]@@ -750,11 +752,11 @@ getRegister' _ is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), CmmLit displacement])- | not is32Bit = do+ | not is32Bit = return $ Any II64 (\dst -> unitOL $ LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst)) -getRegister' platform is32Bit (CmmMachOp mop [x]) = do -- unary MachOps+getRegister' platform is32Bit (CmmMachOp mop [x]) = -- unary MachOps case mop of MO_F_Neg w -> sse2NegCode w x @@ -886,7 +888,7 @@ return (swizzleRegisterRep e_code new_format) -getRegister' _ is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps+getRegister' _ is32Bit (CmmMachOp mop [x, y]) = -- dyadic MachOps case mop of MO_F_Eq _ -> condFltReg is32Bit EQQ x y MO_F_Ne _ -> condFltReg is32Bit NE x y@@ -1371,17 +1373,16 @@ -- (see trivialCode where this function is used for an example). getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock)-getNonClobberedOperand (CmmLit lit) = do+getNonClobberedOperand (CmmLit lit) = if isSuitableFloatingPointLit lit- then do- let CmmFloat _ w = lit- Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit- return (OpAddr addr, code)- else do-- is32Bit <- is32BitPlatform- platform <- getPlatform- if is32BitLit is32Bit lit && not (isFloatType (cmmLitType platform lit))+ then do+ let CmmFloat _ w = lit+ Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit+ return (OpAddr addr, code)+ else do+ is32Bit <- is32BitPlatform+ platform <- getPlatform+ if is32BitLit is32Bit lit && not (isFloatType (cmmLitType platform lit)) then return (OpImm (litToImm lit), nilOL) else getNonClobberedOperand_generic (CmmLit lit) @@ -1407,7 +1408,7 @@ else return (src, nilOL) return (OpAddr src', mem_code `appOL` save_code)- else do+ else -- if its a word or gcptr on 32bit? getNonClobberedOperand_generic (CmmLoad mem pk) @@ -1415,8 +1416,8 @@ getNonClobberedOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock) getNonClobberedOperand_generic e = do- (reg, code) <- getNonClobberedReg e- return (OpReg reg, code)+ (reg, code) <- getNonClobberedReg e+ return (OpReg reg, code) amodeCouldBeClobbered :: Platform -> AddrMode -> Bool amodeCouldBeClobbered platform amode = any (regClobbered platform) (addrModeRegs amode)@@ -1795,7 +1796,7 @@ Amode target code <- getAmode mem return (code `snocOL` JMP (OpAddr target) regs) -genJump (CmmLit lit) regs = do+genJump (CmmLit lit) regs = return (unitOL (JMP (OpImm (litToImm lit)) regs)) genJump expr regs = do@@ -2561,6 +2562,8 @@ -- Copy the value into the target register, perform the exchange. let code = toOL [ MOV format (OpReg newval) (OpReg dst_r)+ -- On X86 xchg implies a lock prefix if we use a memory argument.+ -- so this is atomic. , XCHG format (OpAddr amode) dst_r ] return $ addr_code `appOL` newval_code `appOL` code
compiler/GHC/CmmToAsm/X86/Instr.hs view
@@ -832,13 +832,14 @@ -- In essence each allocation larger than a page size needs to be chunked and -- a probe emitted after each page allocation. You have to hit the guard -- page so the kernel can map in the next page, otherwise you'll segfault.+-- See Note [Windows stack allocations]. -- needs_probe_call :: Platform -> Int -> Bool needs_probe_call platform amount = case platformOS platform of OSMinGW32 -> case platformArch platform of ArchX86 -> amount > (4 * 1024)- ArchX86_64 -> amount > (8 * 1024)+ ArchX86_64 -> amount > (4 * 1024) _ -> False _ -> False @@ -862,7 +863,7 @@ -- -- We emit a call because the stack probes are quite involved and -- would bloat code size a lot. GHC doesn't really have an -Os.- -- __chkstk is guaranteed to leave all nonvolatile registers and AX+ -- ___chkstk is guaranteed to leave all nonvolatile registers and AX -- untouched. It's part of the standard prologue code for any Windows -- function dropping the stack more than a page. -- See Note [Windows stack layout]
compiler/GHC/CmmToC.hs view
@@ -1,5 +1,7 @@-{-# LANGUAGE CPP, DeriveFunctor, GADTs, PatternSynonyms #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- --
compiler/GHC/CmmToLlvm/CodeGen.hs view
@@ -188,18 +188,18 @@ else barrier -- | Foreign Calls-genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual]- -> LlvmM StmtData+genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> LlvmM StmtData -- Barriers need to be handled specially as they are implemented as LLVM -- intrinsic functions. genCall (PrimTarget MO_ReadBarrier) _ _ = barrierUnless [ArchX86, ArchX86_64, ArchSPARC]-genCall (PrimTarget MO_WriteBarrier) _ _ = do++genCall (PrimTarget MO_WriteBarrier) _ _ = barrierUnless [ArchX86, ArchX86_64, ArchSPARC] -genCall (PrimTarget MO_Touch) _ _- = return (nilOL, [])+genCall (PrimTarget MO_Touch) _ _ =+ return (nilOL, []) genCall (PrimTarget (MO_UF_Conv w)) [dst] [e] = runStmtsDecls $ do dstV <- getCmmRegW (CmmLocal dst)@@ -514,9 +514,8 @@ -- make the actual call case retTy of- LMVoid -> do+ LMVoid -> statement $ Expr $ Call ccTy fptr argVars fnAttrs- _ -> do v1 <- doExprW retTy $ Call ccTy fptr argVars fnAttrs -- get the return register@@ -1559,9 +1558,8 @@ vx <- exprToVarW x vy <- exprToVarW y if getVarType vx == getVarType vy- then do+ then doExprW (ty vx) $ binOp vx vy- else do -- Error. Continue anyway so we can debug the generated ll file. dflags <- getDynFlags@@ -1717,19 +1715,19 @@ runExprData $ do iptr <- exprToVarW e case getVarType iptr of- LMPointer _ -> do+ LMPointer _ -> doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr iptr) - i@(LMInt _) | i == llvmWord platform -> do+ i@(LMInt _) | i == llvmWord platform -> do let pty = LMPointer $ cmmToLlvmType ty ptr <- doExprW pty $ Cast LM_Inttoptr iptr pty doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr ptr) - other -> do pprPanic "exprToVar: CmmLoad expression is not right type!"- (PprCmm.pprExpr platform e <+> text (- "Size of Ptr: " ++ show (llvmPtrBits platform) ++- ", Size of var: " ++ show (llvmWidthInBits platform other) ++- ", Var: " ++ showSDoc dflags (ppVar opts iptr)))+ other -> pprPanic "exprToVar: CmmLoad expression is not right type!"+ (PprCmm.pprExpr platform e <+> text (+ "Size of Ptr: " ++ show (llvmPtrBits platform) +++ ", Size of var: " ++ show (llvmWidthInBits platform other) +++ ", Var: " ++ showSDoc dflags (ppVar opts iptr))) where loadInstr ptr | atomic = ALoad SyncSeqCst False ptr | otherwise = Load ptr
compiler/GHC/CmmToLlvm/Regs.hs view
@@ -50,12 +50,12 @@ VanillaReg 9 _ -> wordGlobal $ "R9" ++ suf VanillaReg 10 _ -> wordGlobal $ "R10" ++ suf SpLim -> wordGlobal $ "SpLim" ++ suf- FloatReg 1 -> floatGlobal $"F1" ++ suf- FloatReg 2 -> floatGlobal $"F2" ++ suf- FloatReg 3 -> floatGlobal $"F3" ++ suf- FloatReg 4 -> floatGlobal $"F4" ++ suf- FloatReg 5 -> floatGlobal $"F5" ++ suf- FloatReg 6 -> floatGlobal $"F6" ++ suf+ FloatReg 1 -> floatGlobal $ "F1" ++ suf+ FloatReg 2 -> floatGlobal $ "F2" ++ suf+ FloatReg 3 -> floatGlobal $ "F3" ++ suf+ FloatReg 4 -> floatGlobal $ "F4" ++ suf+ FloatReg 5 -> floatGlobal $ "F5" ++ suf+ FloatReg 6 -> floatGlobal $ "F6" ++ suf DoubleReg 1 -> doubleGlobal $ "D1" ++ suf DoubleReg 2 -> doubleGlobal $ "D2" ++ suf DoubleReg 3 -> doubleGlobal $ "D3" ++ suf
compiler/GHC/Core/Opt/CprAnal.hs view
@@ -118,9 +118,9 @@ -> CoreBind -> (AnalEnv, CoreBind) cprAnalTopBind env (NonRec id rhs)- = (extendAnalEnv env id' (idCprInfo id'), NonRec id' rhs')+ = (env', NonRec id' rhs') where- (id', rhs') = cprAnalBind TopLevel env id rhs+ (id', rhs', env') = cprAnalBind TopLevel env id rhs cprAnalTopBind env (Rec pairs) = (env', Rec pairs')@@ -178,7 +178,7 @@ | otherwise = (lam_ty, Lam var body') where- env' = extendAnalEnvForDemand env var (idDemandInfo var)+ env' = extendSigEnvForDemand env var (idDemandInfo var) (body_ty, body') = cprAnal env' body lam_ty = abstractCprTy body_ty @@ -194,9 +194,8 @@ cprAnal' env (Let (NonRec id rhs) body) = (body_ty, Let (NonRec id' rhs') body') where- (id', rhs') = cprAnalBind NotTopLevel env id rhs- env' = extendAnalEnv env id' (idCprInfo id')- (body_ty, body') = cprAnal env' body+ (id', rhs', env') = cprAnalBind NotTopLevel env id rhs+ (body_ty, body') = cprAnal env' body cprAnal' env (Let (Rec pairs) body) = body_ty `seq` (body_ty, Let (Rec pairs') body')@@ -233,15 +232,15 @@ sig where sig- -- See Note [CPR for expandable unfoldings]- | Just rhs <- cprExpandUnfolding_maybe id+ -- Top-level binding, local let-binding or case binder+ | Just sig <- lookupSigEnv env id+ = getCprSig sig+ -- See Note [CPR for data structures]+ | Just rhs <- cprDataStructureUnfolding_maybe id = fst $ cprAnal env rhs -- Imported function or data con worker | isGlobalId id = getCprSig (idCprInfo id)- -- Local let-bound- | Just sig <- lookupSigEnv env id- = getCprSig sig | otherwise = topCprType @@ -251,46 +250,43 @@ -- Recursive bindings cprFix :: TopLevelFlag- -> AnalEnv -- Does not include bindings for this binding+ -> AnalEnv -- Does not include bindings for this binding -> [(Id,CoreExpr)]- -> (AnalEnv, [(Id,CoreExpr)]) -- Binders annotated with stricness info--cprFix top_lvl env orig_pairs- = loop 1 initial_pairs+ -> (AnalEnv, [(Id,CoreExpr)]) -- Binders annotated with CPR info+cprFix top_lvl orig_env orig_pairs+ = loop 1 init_env init_pairs where- bot_sig = mkCprSig 0 botCpr+ init_sig id rhs+ -- See Note [CPR for data structures]+ | isDataStructure id rhs = topCprSig+ | otherwise = mkCprSig 0 botCpr -- See Note [Initialising strictness] in GHC.Core.Opt.DmdAnal- initial_pairs | ae_virgin env = [(setIdCprInfo id bot_sig, rhs) | (id, rhs) <- orig_pairs ]- | otherwise = orig_pairs-- -- The fixed-point varies the idCprInfo field of the binders, and terminates if that- -- annotation does not change any more.- loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, [(Id,CoreExpr)])- loop n pairs- | found_fixpoint = (final_anal_env, pairs')- | otherwise = loop (n+1) pairs'- where- found_fixpoint = map (idCprInfo . fst) pairs' == map (idCprInfo . fst) pairs- first_round = n == 1- pairs' = step first_round pairs- final_anal_env = extendAnalEnvs env (map fst pairs')+ orig_virgin = ae_virgin orig_env+ init_pairs | orig_virgin = [(setIdCprInfo id (init_sig id rhs), rhs) | (id, rhs) <- orig_pairs ]+ | otherwise = orig_pairs+ init_env = extendSigEnvList orig_env (map fst init_pairs) - step :: Bool -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]- step first_round pairs = pairs'+ -- The fixed-point varies the idCprInfo field of the binders and and their+ -- entries in the AnalEnv, and terminates if that annotation does not change+ -- any more.+ loop :: Int -> AnalEnv -> [(Id,CoreExpr)] -> (AnalEnv, [(Id,CoreExpr)])+ loop n env pairs+ | found_fixpoint = (reset_env', pairs')+ | otherwise = loop (n+1) env' pairs' where -- In all but the first iteration, delete the virgin flag- start_env | first_round = env- | otherwise = nonVirgin env-- start = extendAnalEnvs start_env (map fst pairs)-- (_, pairs') = mapAccumL my_downRhs start pairs+ -- See Note [Initialising strictness] in GHC.Core.Opt.DmdAnal+ (env', pairs') = step (applyWhen (n/=1) nonVirgin env) pairs+ -- Make sure we reset the virgin flag to what it was when we are stable+ reset_env' = env'{ ae_virgin = orig_virgin }+ found_fixpoint = map (idCprInfo . fst) pairs' == map (idCprInfo . fst) pairs - my_downRhs env (id,rhs)- = (env', (id', rhs'))+ step :: AnalEnv -> [(Id, CoreExpr)] -> (AnalEnv, [(Id, CoreExpr)])+ step env pairs = mapAccumL go env pairs+ where+ go env (id, rhs) = (env', (id', rhs')) where- (id', rhs') = cprAnalBind top_lvl env id rhs- env' = extendAnalEnv env id (idCprInfo id')+ (id', rhs', env') = cprAnalBind top_lvl env id rhs -- | Process the RHS of the binding for a sensible arity, add the CPR signature -- to the Id, and augment the environment with the signature as well.@@ -299,9 +295,13 @@ -> AnalEnv -> Id -> CoreExpr- -> (Id, CoreExpr)+ -> (Id, CoreExpr, AnalEnv) cprAnalBind top_lvl env id rhs- = (id', rhs')+ -- See Note [CPR for data structures]+ | isDataStructure id rhs+ = (id, rhs, env) -- Data structure => no code => need to analyse rhs+ | otherwise+ = (id', rhs', env') where (rhs_ty, rhs') = cprAnal env rhs -- possibly trim thunk CPR info@@ -310,12 +310,11 @@ | stays_thunk = trimCprTy rhs_ty -- See Note [CPR for sum types] | returns_sum = trimCprTy rhs_ty- -- See Note [CPR for expandable unfoldings]- | will_expand = topCprType | otherwise = rhs_ty -- See Note [Arity trimming for CPR signatures]- sig = mkCprSigForArity (idArity id) rhs_ty'- id' = setIdCprInfo id sig+ sig = mkCprSigForArity (idArity id) rhs_ty'+ id' = setIdCprInfo id sig+ env' = extendSigEnv env id sig -- See Note [CPR for thunks] stays_thunk = is_thunk && not_strict@@ -325,15 +324,22 @@ (_, ret_ty) = splitPiTys (idType id) not_a_prod = isNothing (deepSplitProductType_maybe (ae_fam_envs env) ret_ty) returns_sum = not (isTopLevel top_lvl) && not_a_prod- -- See Note [CPR for expandable unfoldings]- will_expand = isJust (cprExpandUnfolding_maybe id) -cprExpandUnfolding_maybe :: Id -> Maybe CoreExpr-cprExpandUnfolding_maybe id = do- guard (idArity id == 0)+isDataStructure :: Id -> CoreExpr -> Bool+-- See Note [CPR for data structures]+isDataStructure id rhs =+ idArity id == 0 && exprIsHNF rhs++-- | Returns an expandable unfolding+-- (See Note [exprIsExpandable] in "GHC.Core.Utils") that has+-- So effectively is a constructor application.+cprDataStructureUnfolding_maybe :: Id -> Maybe CoreExpr+cprDataStructureUnfolding_maybe id = do -- There are only FinalPhase Simplifier runs after CPR analysis guard (activeInFinalPhase (idInlineActivation id))- expandUnfolding_maybe (idUnfolding id)+ unf <- expandUnfolding_maybe (idUnfolding id)+ guard (isDataStructure id unf)+ return unf {- Note [Arity trimming for CPR signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -394,15 +400,15 @@ , ae_fam_envs = fam_envs } --- | Extend an environment with the strictness IDs attached to the id-extendAnalEnvs :: AnalEnv -> [Id] -> AnalEnv-extendAnalEnvs env ids+-- | Extend an environment with the CPR sigs attached to the id+extendSigEnvList :: AnalEnv -> [Id] -> AnalEnv+extendSigEnvList env ids = env { ae_sigs = sigs' } where sigs' = extendVarEnvList (ae_sigs env) [ (id, idCprInfo id) | id <- ids ] -extendAnalEnv :: AnalEnv -> Id -> CprSig -> AnalEnv-extendAnalEnv env id sig+extendSigEnv :: AnalEnv -> Id -> CprSig -> AnalEnv+extendSigEnv env id sig = env { ae_sigs = extendVarEnv (ae_sigs env) id sig } lookupSigEnv :: AnalEnv -> Id -> Maybe CprSig@@ -411,17 +417,17 @@ nonVirgin :: AnalEnv -> AnalEnv nonVirgin env = env { ae_virgin = False } --- | A version of 'extendAnalEnv' for a binder of which we don't see the RHS+-- | A version of 'extendSigEnv' for a binder of which we don't see the RHS -- needed to compute a 'CprSig' (e.g. lambdas and DataAlt field binders). -- In this case, we can still look at their demand to attach CPR signatures -- anticipating the unboxing done by worker/wrapper. -- See Note [CPR for binders that will be unboxed].-extendAnalEnvForDemand :: AnalEnv -> Id -> Demand -> AnalEnv-extendAnalEnvForDemand env id dmd+extendSigEnvForDemand :: AnalEnv -> Id -> Demand -> AnalEnv+extendSigEnvForDemand env id dmd | isId id , Just (_, DataConAppContext { dcac_dc = dc }) <- wantToUnbox (ae_fam_envs env) has_inlineable_prag (idType id) dmd- = extendAnalEnv env id (CprSig (conCprType (dataConTag dc)))+ = extendSigEnv env id (CprSig (conCprType (dataConTag dc))) | otherwise = env where@@ -436,7 +442,7 @@ extendEnvForDataAlt env scrut case_bndr dc bndrs = foldl' do_con_arg env' ids_w_strs where- env' = extendAnalEnv env case_bndr (CprSig case_bndr_ty)+ env' = extendSigEnv env case_bndr (CprSig case_bndr_ty) ids_w_strs = filter isId bndrs `zip` dataConRepStrictness dc @@ -460,7 +466,7 @@ | is_var scrut -- See Note [Add demands for strict constructors] in GHC.Core.Opt.WorkWrap.Utils , let dmd = applyWhen (isMarkedStrict str) strictifyDmd (idDemandInfo id)- = extendAnalEnvForDemand env id dmd+ = extendSigEnvForDemand env id dmd | otherwise = env @@ -645,46 +651,72 @@ so WW doesn't hurt. Should we also trim CPR on DataCon application bindings?-See Note [CPR for expandable unfoldings]!+See Note [CPR for data structures]! -Note [CPR for expandable unfoldings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [CPR for data structures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Long static data structures (whether top-level or not) like xs = x1 : xs1 xs1 = x2 : xs2 xs2 = x3 : xs3 -should not get CPR signatures, because they+should not get CPR signatures (#18154), because they * Never get WW'd, so their CPR signature should be irrelevant after analysis (in fact the signature might even be harmful for that reason) * Would need to be inlined/expanded to see their constructed product * Recording CPR on them blows up interface file sizes and is redundant with their unfolding. In case of Nested CPR, this blow-up can be quadratic!+ Reason: the CPR info for xs1 contains the CPR info for xs; the CPR info+ for xs2 contains that for xs1. And so on. -But we can't just stop giving DataCon application bindings the CPR property,+Hence we don't analyse or annotate data structures in 'cprAnalBind'. To+implement this, the isDataStructure guard is triggered for bindings that satisfy++ (1) idArity id == 0 (otherwise it's a function)+ (2) exprIsHNF rhs (otherwise it's a thunk, Note [CPR for thunks] applies)++But we can't just stop giving DataCon application bindings the CPR *property*, for example - fac 0 = 1+ fac 0 = I# 1# fac n = n * fac (n-1) fac certainly has the CPR property and should be WW'd! But FloatOut will transform the first clause to - lvl = 1+ lvl = I# 1# fac 0 = lvl -If lvl doesn't have the CPR property, fac won't either. But lvl doesn't have a-CPR signature to extrapolate into a CPR transformer ('cprTransform'). So-instead we keep on cprAnal'ing through *expandable* unfoldings for these arity-0 bindings via 'cprExpandUnfolding_maybe'.+If lvl doesn't have the CPR property, fac won't either. But lvl is a data+structure, and hence (see above) will not have a CPR signature. So instead, when+'cprAnal' meets a variable lacking a CPR signature to extrapolate into a CPR+transformer, 'cprTransform' instead tries to get its unfolding (via+'cprDataStructureUnfolding_maybe'), and analyses that instead. In practice, GHC generates a lot of (nested) TyCon and KindRep bindings, one-for each data declaration. It's wasteful to attach CPR signatures to each of-them (and intractable in case of Nested CPR).+for each data declaration. They should not have CPR signatures (blow up!). -Tracked by #18154.+There is a perhaps surprising special case: KindRep bindings satisfy+'isDataStructure' (so no CPR signature), but are marked NOINLINE at the same+time (see the noinline wrinkle in Note [Grand plan for Typeable]). So there is+no unfolding for 'cprDataStructureUnfolding_maybe' to look through and we'll+return topCprType. And that is fine! We should refrain to look through NOINLINE+data structures in general, as a constructed product could never be exposed+after WW.++It's also worth pointing out how ad-hoc this is: If we instead had++ f1 x = x:[]+ f2 x = x : f1 x+ f3 x = x : f2 x+ ...++we still give every function an every deepening CPR signature. But it's very+uncommon to find code like this, whereas the long static data structures from+the beginning of this Note are very common because of GHC's strategy of ANF'ing+data structure RHSs. Note [CPR examples] ~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Core/Opt/DmdAnal.hs view
@@ -9,18 +9,20 @@ {-# LANGUAGE CPP #-} -module GHC.Core.Opt.DmdAnal ( dmdAnalProgram ) where+module GHC.Core.Opt.DmdAnal+ ( DmdAnalOpts(..)+ , dmdAnalProgram+ )+where #include "GhclibHsVersions.h" import GHC.Prelude -import GHC.Driver.Session 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 import GHC.Types.Var.Set@@ -29,7 +31,6 @@ import GHC.Core.DataCon import GHC.Types.ForeignCall ( isSafeForeignCall ) import GHC.Types.Id-import GHC.Types.Id.Info import GHC.Core.Utils import GHC.Core.TyCon import GHC.Core.Type@@ -41,7 +42,6 @@ import GHC.Data.Maybe ( isJust ) import GHC.Builtin.PrimOps import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )-import GHC.Utils.Error ( dumpIfSet_dyn, DumpFormat (..) ) import GHC.Types.Unique.Set {-@@ -52,15 +52,22 @@ ************************************************************************ -} -dmdAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram-dmdAnalProgram dflags fam_envs binds = do- let env = emptyAnalEnv dflags fam_envs- let binds_plus_dmds = snd $ mapAccumL dmdAnalTopBind env binds- dumpIfSet_dyn dflags Opt_D_dump_str_signatures "Strictness signatures" FormatText $- dumpIdInfoOfProgram (pprIfaceStrictSig . strictnessInfo) binds_plus_dmds- -- See Note [Stamp out space leaks in demand analysis]- seqBinds binds_plus_dmds `seq` return binds_plus_dmds+-- | Options for the demand analysis+data DmdAnalOpts = DmdAnalOpts+ { dmd_strict_dicts :: !Bool -- ^ Use strict dictionaries+ } +-- | Outputs a new copy of the Core program in which binders have been annotated+-- with demand and strictness information.+--+-- Note: use `seqBinds` on the result to avoid leaks due to lazyness (cf Note+-- [Stamp out space leaks in demand analysis])+dmdAnalProgram :: DmdAnalOpts -> FamInstEnvs -> CoreProgram -> CoreProgram+dmdAnalProgram opts fam_envs binds = binds_plus_dmds+ where+ env = emptyAnalEnv opts fam_envs+ binds_plus_dmds = snd $ mapAccumL dmdAnalTopBind env binds+ -- Analyse a (group of) top-level binding(s) dmdAnalTopBind :: AnalEnv -> CoreBind@@ -567,8 +574,7 @@ rhs_fv2 = rhs_fv1 `keepAliveDmdEnv` extra_fvs -- See Note [Lazy and unleashable free variables]- (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv2- is_thunk = not (exprIsHNF rhs) && not (isJoinId id)+ (lazy_fv, sig_fv) = partitionVarEnv isWeakDmd rhs_fv2 -- Find the RHS free vars of the unfoldings and RULES -- See Note [Absence analysis for stable unfoldings and RULES]@@ -588,8 +594,9 @@ mkRhsDmd :: AnalEnv -> Arity -> CoreExpr -> CleanDemand mkRhsDmd _env rhs_arity _rhs = mkCallDmds rhs_arity cleanEvalDmd --- | If given the let-bound 'Id', 'useLetUp' determines whether we should--- process the binding up (body before rhs) or down (rhs before body).+-- | If given the (local, non-recursive) let-bound 'Id', 'useLetUp' determines+-- whether we should process the binding up (body before rhs) or down (rhs+-- before body). -- -- We use LetDown if there is a chance to get a useful strictness signature to -- unleash at call sites. LetDown is generally more precise than LetUp if we can@@ -1235,31 +1242,13 @@ notArgOfDfun :: DFunFlag notArgOfDfun = False -{- Note [dmdAnalEnv performance]- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--It's tempting to think that removing the dynflags from AnalEnv would improve-performance. After all when analysing recursive groups we end up allocating-a lot of environments. However this is not the case.--We do get some performance by making AnalEnv smaller. However very often we-defer computation which means we have to capture the dynflags in the thunks-we allocate. Doing this naively in practice causes more allocation than the-removal of DynFlags saves us.--In theory it should be possible to make this better if we are stricter in-the analysis and therefore allocate fewer thunks. But I couldn't get there-in a few hours and overall the impact on GHC here is small, and there are-bigger fish to fry. So for new the env will keep a reference to the flags.--}--data AnalEnv- = AE { ae_dflags :: DynFlags -- See Note [dmdAnalEnv performance]- , ae_sigs :: SigEnv- , ae_virgin :: Bool -- True on first iteration only+data AnalEnv = AE+ { ae_strict_dicts :: !Bool -- ^ Enable strict dict+ , ae_sigs :: !SigEnv+ , ae_virgin :: !Bool -- ^ True on first iteration only -- See Note [Initialising strictness]- , ae_fam_envs :: FamInstEnvs- }+ , ae_fam_envs :: !FamInstEnvs+ } -- We use the se_env to tell us whether to -- record info about a variable in the DmdEnv@@ -1271,17 +1260,18 @@ type SigEnv = VarEnv (StrictSig, TopLevelFlag) instance Outputable AnalEnv where- ppr (AE { ae_sigs = env, ae_virgin = virgin })- = text "AE" <+> braces (vcat- [ text "ae_virgin =" <+> ppr virgin- , text "ae_sigs =" <+> ppr env ])+ ppr env = text "AE" <+> braces (vcat+ [ text "ae_virgin =" <+> ppr (ae_virgin env)+ , text "ae_strict_dicts =" <+> ppr (ae_strict_dicts env)+ , text "ae_sigs =" <+> ppr (ae_sigs env)+ ]) -emptyAnalEnv :: DynFlags -> FamInstEnvs -> AnalEnv-emptyAnalEnv dflags fam_envs- = AE { ae_dflags = dflags- , ae_sigs = emptySigEnv- , ae_virgin = True- , ae_fam_envs = fam_envs+emptyAnalEnv :: DmdAnalOpts -> FamInstEnvs -> AnalEnv+emptyAnalEnv opts fam_envs+ = AE { ae_strict_dicts = dmd_strict_dicts opts+ , ae_sigs = emptySigEnv+ , ae_virgin = True+ , ae_fam_envs = fam_envs } emptySigEnv :: SigEnv@@ -1334,7 +1324,7 @@ id_ty = idType id strictify dmd- | gopt Opt_DictsStrict (ae_dflags env)+ | ae_strict_dicts env -- We never want to strictify a recursive let. At the moment -- annotateBndr is only call for non-recursive lets; if that -- changes, we need a RecFlag parameter and another guard here.
compiler/GHC/Core/Opt/Exitify.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE PatternSynonyms #-}- module GHC.Core.Opt.Exitify ( exitifyProgram ) where {-@@ -118,7 +116,7 @@ -- Which are the recursive calls? recursive_calls = mkVarSet $ map fst pairs - (pairs',exits) = (`runState` []) $ do+ (pairs',exits) = (`runState` []) $ forM ann_pairs $ \(x,rhs) -> do -- go past the lambdas of the join point let (args, body) = collectNAnnBndrs (idJoinArity x) rhs
compiler/GHC/Core/Opt/FloatIn.hs view
@@ -23,20 +23,24 @@ import GHC.Prelude import GHC.Platform +import GHC.Driver.Session+ import GHC.Core import GHC.Core.Make hiding ( wrapFloats )-import GHC.Driver.Types ( ModGuts(..) ) import GHC.Core.Utils import GHC.Core.FVs-import GHC.Core.Opt.Monad ( CoreM )+import GHC.Core.Opt.Monad ( CoreM )+import GHC.Core.Type++import GHC.Types.Basic ( RecFlag(..), isRec ) import GHC.Types.Id ( isOneShotBndr, idType, isJoinId, isJoinId_maybe ) import GHC.Types.Var-import GHC.Core.Type import GHC.Types.Var.Set++import GHC.Unit.Module.ModGuts+ import GHC.Utils.Misc-import GHC.Driver.Session import GHC.Utils.Panic-import GHC.Types.Basic ( RecFlag(..), isRec ) {- Top-level interface function, @floatInwards@. Note that we do not
compiler/GHC/Core/Opt/Pipeline.hs view
@@ -14,17 +14,18 @@ import GHC.Driver.Session import GHC.Driver.Ppr+import GHC.Driver.Plugins ( withPlugins, installCoreToDos )+import GHC.Driver.Env+ import GHC.Core-import GHC.Driver.Types import GHC.Core.Opt.CSE ( cseProgram ) import GHC.Core.Rules ( mkRuleBase, unionRuleBase, extendRuleBaseList, ruleCheckProgram, addRuleInfo, getRules, initRuleOpts ) import GHC.Core.Ppr ( pprCoreBindings, pprCoreExpr ) import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr )-import GHC.Types.Id.Info import GHC.Core.Stats ( coreBindsSize, coreBindsStats, exprSize )-import GHC.Core.Utils ( mkTicks, stripTicksTop )+import GHC.Core.Utils ( mkTicks, stripTicksTop, dumpIdInfoOfProgram ) import GHC.Core.Lint ( endPass, lintPassResult, dumpPassResult, lintAnnots ) import GHC.Core.Opt.Simplify ( simplTopBinds, simplExpr, simplRules )@@ -32,34 +33,45 @@ import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Simplify.Monad import GHC.Core.Opt.Monad-import qualified GHC.Utils.Error as Err-import GHC.Core.Opt.FloatIn ( floatInwards )-import GHC.Core.Opt.FloatOut ( floatOutwards )-import GHC.Core.FamInstEnv-import GHC.Types.Id-import GHC.Utils.Error ( withTiming, withTimingD, DumpFormat (..) )-import GHC.Types.Basic-import GHC.Types.Var.Set-import GHC.Types.Var.Env+import GHC.Core.Opt.FloatIn ( floatInwards )+import GHC.Core.Opt.FloatOut ( floatOutwards ) import GHC.Core.Opt.LiberateCase ( liberateCase ) import GHC.Core.Opt.StaticArgs ( doStaticArgs ) import GHC.Core.Opt.Specialise ( specProgram) import GHC.Core.Opt.SpecConstr ( specConstrProgram)-import GHC.Core.Opt.DmdAnal ( dmdAnalProgram )+import GHC.Core.Opt.DmdAnal import GHC.Core.Opt.CprAnal ( cprAnalProgram ) import GHC.Core.Opt.CallArity ( callArityAnalProgram ) import GHC.Core.Opt.Exitify ( exitifyProgram ) import GHC.Core.Opt.WorkWrap ( wwTopBinds )-import GHC.Types.SrcLoc+import GHC.Core.Seq (seqBinds)+import GHC.Core.FamInstEnv++import qualified GHC.Utils.Error as Err+import GHC.Utils.Error ( withTiming, withTimingD, DumpFormat (..) ) import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic++import GHC.Unit.External import GHC.Unit.Module.Env-import GHC.Driver.Plugins ( withPlugins, installCoreToDos )+import GHC.Unit.Module.ModGuts+import GHC.Unit.Module.Deps+ import GHC.Runtime.Loader -- ( initializePlugins )+import GHC.Runtime.Context +import GHC.Types.SrcLoc+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Basic+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Demand import GHC.Types.Unique.Supply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) import GHC.Types.Unique.FM-import GHC.Utils.Outputable-import GHC.Utils.Panic+import GHC.Types.Name.Ppr+ import Control.Monad import qualified GHC.LanguageExtensions as LangExt {-@@ -103,7 +115,7 @@ hpt_rule_base = mkRuleBase home_pkg_rules print_unqual = mkPrintUnqualified (unitState dflags)- (mkHomeUnitFromFlags dflags)+ (hsc_home_unit hsc_env) rdr_env -- mod: get the module out of the current HscEnv so we can retrieve it from the monad. -- This is very convienent for the users of the monad (e.g. plugins do not have to@@ -449,7 +461,7 @@ where do_pass guts CoreDoNothing = return guts do_pass guts (CoreDoPasses ps) = runCorePasses ps guts- do_pass guts pass = do+ do_pass guts pass = withTimingD (ppr pass <+> brackets (ppr mod)) (const ()) $ do { guts' <- lintAnnots (ppr pass) (doCorePass pass) guts@@ -484,7 +496,7 @@ doPass exitifyProgram doCorePass CoreDoDemand = {-# SCC "DmdAnal" #-}- doPassDFM dmdAnalProgram+ doPassDFM dmdAnal doCorePass CoreDoCpr = {-# SCC "CprAnal" #-} doPassDFM cprAnalProgram@@ -696,7 +708,7 @@ } where dflags = hsc_dflags hsc_env- print_unqual = mkPrintUnqualified (unitState dflags) (mkHomeUnitFromFlags dflags) rdr_env+ print_unqual = mkPrintUnqualified (unitState dflags) (hsc_home_unit hsc_env) rdr_env simpl_env = mkSimplEnv mode active_rule = activeRule mode active_unf = activeUnfolding mode@@ -883,7 +895,7 @@ of iterateList in the first place But in principle the user *might* want rules that only apply to the Id-he says. And inline pragmas are similar+they say. And inline pragmas are similar {-# NOINLINE f #-} f = local local = <stuff>@@ -1074,3 +1086,16 @@ (ruleInfo local_info) -- Remember to set the function-name field of the -- rules as we transfer them from one function to another++++dmdAnal :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram+dmdAnal dflags fam_envs binds = do+ let opts = DmdAnalOpts+ { dmd_strict_dicts = gopt Opt_DictsStrict dflags+ }+ binds_plus_dmds = dmdAnalProgram opts fam_envs binds+ Err.dumpIfSet_dyn dflags Opt_D_dump_str_signatures "Strictness signatures" FormatText $+ dumpIdInfoOfProgram (pprIfaceStrictSig . strictnessInfo) binds_plus_dmds+ -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal+ seqBinds binds_plus_dmds `seq` return binds_plus_dmds
compiler/GHC/Core/Opt/SetLevels.hs view
@@ -1,3 +1,8 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE PatternSynonyms #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -60,9 +65,6 @@ identity. -} -{-# LANGUAGE CPP, MultiWayIf, PatternSynonyms #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module GHC.Core.Opt.SetLevels ( setLevels, @@ -882,9 +884,8 @@ and replace the original (f x) with case (case y of I# r -> r) of r -> blah -Being able to float unboxed expressions is sometimes important; see-#12603. I'm not sure how /often/ it is important, but it's-not hard to achieve.+Being able to float unboxed expressions is sometimes important; see #12603.+I'm not sure how /often/ it is important, but it's not hard to achieve. We only do it for a fixed collection of types for which we have a convenient boxing constructor (see boxingDataCon_maybe). In
compiler/GHC/Core/Opt/Simplify.hs view
@@ -17,14 +17,13 @@ import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Driver.Config-import GHC.Core.SimpleOpt ( exprIsConApp_maybe ) import GHC.Core.Opt.Simplify.Monad import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst ) import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Simplify.Utils import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )-import GHC.Core.FamInstEnv ( FamInstEnv ) import GHC.Types.Literal ( litIsLifted ) --, mkLitInt ) -- temporalily commented out. See #8326+import GHC.Types.SourceText import GHC.Types.Id import GHC.Types.Id.Make ( seqId ) import GHC.Core.Make ( FloatBind, mkImpossibleExpr, castBottomExpr )@@ -33,7 +32,7 @@ import GHC.Types.Name ( mkSystemVarName, isExternalName, getOccFS ) import GHC.Core.Coercion hiding ( substCo, substCoVar ) import GHC.Core.Coercion.Opt ( optCoercion )-import GHC.Core.FamInstEnv ( topNormaliseType_maybe )+import GHC.Core.FamInstEnv ( FamInstEnv, topNormaliseType_maybe ) import GHC.Core.DataCon ( DataCon, dataConWorkId, dataConRepStrictness , dataConRepArgTys, isUnboxedTupleDataCon@@ -53,7 +52,7 @@ import GHC.Core.Opt.Arity ( ArityType(..), arityTypeArity, isBotArityType , pushCoTyArg, pushCoValArg , idArityType, etaExpandAT )-import GHC.Core.SimpleOpt ( joinPointBinding_maybe, joinPointBindings_maybe )+import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe ) import GHC.Core.FVs ( mkRuleInfo ) import GHC.Core.Rules ( lookupRule, getRules, initRuleOpts ) import GHC.Types.Basic@@ -549,7 +548,7 @@ -- 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_inline = NoUserInlinePrag -- 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@@ -2196,21 +2195,21 @@ nodump | dopt Opt_D_dump_rule_rewrites dflags- = liftIO $ do- touchDumpFile dflags (dumpOptionsFromFlag Opt_D_dump_rule_rewrites)+ = liftIO $+ touchDumpFile dflags (dumpOptionsFromFlag Opt_D_dump_rule_rewrites) | dopt Opt_D_dump_rule_firings dflags- = liftIO $ do- touchDumpFile dflags (dumpOptionsFromFlag Opt_D_dump_rule_firings)+ = liftIO $+ touchDumpFile dflags (dumpOptionsFromFlag Opt_D_dump_rule_firings) | otherwise = return () log_rule dflags flag hdr details = liftIO $ do- let sty = mkDumpStyle alwaysQualify- dumpAction dflags sty (dumpOptionsFromFlag flag) "" FormatText $- sep [text hdr, nest 4 details]+ let sty = mkDumpStyle alwaysQualify+ dumpAction dflags sty (dumpOptionsFromFlag flag) "" FormatText $+ sep [text hdr, nest 4 details] trySeqRules :: SimplEnv -> OutExpr -> InExpr -- Scrutinee and RHS
compiler/GHC/Core/Opt/Simplify/Env.hs view
@@ -809,7 +809,7 @@ = ASSERT2( not (isCoVar old_id), ppr old_id ) (env { seInScope = in_scope `extendInScopeSet` new_id, seIdSubst = new_subst }, new_id)- -- It's important that both seInScope and seIdSubt are updated with+ -- It's important that both seInScope and seIdSubst are updated with -- the new_id, /after/ applying adjust_type. That's why adjust_type -- is done here. If we did adjust_type in simplJoinBndr (the only -- place that gives a non-identity adjust_type) we'd have to fiddle
compiler/GHC/Core/Opt/Simplify/Utils.hs view
@@ -1190,7 +1190,7 @@ inactive in the initial stages. See Note [Gentle mode]. Note [Stable unfoldings and preInlineUnconditionally]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Surprisingly, do not pre-inline-unconditionally Ids with INLINE pragmas! Example @@ -1207,15 +1207,22 @@ it might make fInt look big, and we'll lose the opportunity to inline f at each of fInt's call sites. The INLINE pragma will only inline when the application is saturated for exactly this reason; and we don't-want PreInlineUnconditionally to second-guess it. A live example is-#3736.+want PreInlineUnconditionally to second-guess it. A live example is #3736. c.f. Note [Stable unfoldings and postInlineUnconditionally] -NB: if the pragma is INLINEABLE, then we don't want to behave in-this special way -- an INLINEABLE pragma just says to GHC "inline this-if you like". But if there is a unique occurrence, we want to inline-the stable unfolding, not the RHS.+NB: this only applies for INLINE things. Do /not/ switch off+preInlineUnconditionally for +* INLINABLE. It just says to GHC "inline this if you like". If there+ is a unique occurrence, we want to inline the stable unfolding, not+ the RHS.++* NONLINE[n] just switches off inlining until phase n. We should+ respect that, but after phase n, just behave as usual.++* NoUserInlinePrag. There is no pragma at all. This ends up on wrappers.+ (See #18815.)+ Note [Top-level bottoming Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Don't inline top-level Ids that are bottoming, even if they are used just@@ -1248,7 +1255,7 @@ | not (isStableUnfolding unf) = Just (extend_subst_with rhs) -- Note [Stable unfoldings and preInlineUnconditionally]- | isInlinablePragma inline_prag+ | not (isInlinePragma inline_prag) , Just inl <- maybeUnfoldingTemplate unf = Just (extend_subst_with inl) | otherwise = Nothing where
compiler/GHC/Core/Opt/SpecConstr.hs view
@@ -25,13 +25,13 @@ import GHC.Core.FVs ( exprsFreeVarsList ) import GHC.Core.Opt.Monad import GHC.Types.Literal ( litIsLifted )-import GHC.Driver.Types ( ModGuts(..) )+import GHC.Unit.Module.ModGuts import GHC.Core.Opt.WorkWrap.Utils ( isWorkerSmallEnough, mkWorkerArgs ) import GHC.Core.DataCon import GHC.Core.Coercion hiding( substCo ) import GHC.Core.Rules import GHC.Core.Type hiding ( substTy )-import GHC.Core.TyCon ( tyConName )+import GHC.Core.TyCon ( tyConUnique ) import GHC.Core.Multiplicity import GHC.Types.Id import GHC.Core.Ppr ( pprParendExpr )@@ -56,7 +56,7 @@ import GHC.Utils.Monad import Control.Monad ( zipWithM ) import Data.List-import GHC.Builtin.Names ( specTyConName )+import GHC.Builtin.Names ( specTyConKey ) import GHC.Unit.Module import Data.Ord( comparing ) @@ -983,7 +983,7 @@ forceSpecArgTy env ty | Just (tycon, tys) <- splitTyConApp_maybe ty , tycon /= funTyCon- = tyConName tycon == specTyConName+ = tyConUnique tycon == specTyConKey || any (forceSpecArgTy env) tys forceSpecArgTy _ _ = False@@ -1066,14 +1066,6 @@ combineCalls :: CallEnv -> CallEnv -> CallEnv combineCalls = plusVarEnv_C (++)- where--- plus cs ds | length res > 1--- = pprTrace "combineCalls" (vcat [ text "cs:" <+> ppr cs--- , text "ds:" <+> ppr ds])--- res--- | otherwise = res--- where--- res = cs ++ ds combineUsage :: ScUsage -> ScUsage -> ScUsage combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),@@ -1744,8 +1736,8 @@ In calls to 'specialise', the returned ScUsage must include the rhs_usg in the passed-in SpecInfo, unless there are no calls at all to the function. -The caller can, indeed must, assume this. He should not combine in rhs_usg-himself, or he'll get rhs_usg twice -- and that can lead to an exponential+The caller can, indeed must, assume this. They should not combine in rhs_usg+themselves, or they'll get rhs_usg twice -- and that can lead to an exponential blowup of duplicates in the CallEnv. This is what gave rise to the massive performance loss in #8852.
compiler/GHC/Core/Opt/Specialise.hs view
@@ -1,60 +1,67 @@+{-# LANGUAGE CPP #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 \section[Specialise]{Stamping out overloading, and (optionally) polymorphism} -} -{-# LANGUAGE CPP #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module GHC.Core.Opt.Specialise ( specProgram, specUnfolding ) where #include "GhclibHsVersions.h" import GHC.Prelude -import GHC.Types.Id+import GHC.Driver.Session+import GHC.Driver.Ppr+import GHC.Driver.Config+import GHC.Driver.Env+ 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 ) import GHC.Core.Coercion( Coercion ) import GHC.Core.Opt.Monad import qualified GHC.Core.Subst as Core import GHC.Core.Unfold.Make-import GHC.Types.Var ( isLocalVar )-import GHC.Types.Var.Set-import GHC.Types.Var.Env import GHC.Core import GHC.Core.Rules import GHC.Core.Utils ( exprIsTrivial, getIdFromTrivialExpr_maybe , mkCast, exprType ) import GHC.Core.FVs+import GHC.Core.TyCo.Rep (TyCoBinder (..)) import GHC.Core.Opt.Arity ( collectBindersPushingCo , etaExpandToJoinPointRule )++import GHC.Builtin.Types ( unboxedUnitTy )++import GHC.Data.Maybe ( mapMaybe, maybeToList, isJust )+import GHC.Data.Bag+import GHC.Data.FastString++import GHC.Types.Basic import GHC.Types.Unique.Supply+import GHC.Types.Unique.DFM import GHC.Types.Name import GHC.Types.Id.Make ( voidArgId, voidPrimId )-import GHC.Builtin.Types ( unboxedUnitTy )-import GHC.Data.Maybe ( mapMaybe, maybeToList, isJust )+import GHC.Types.Var ( isLocalVar )+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Id+ import GHC.Utils.Monad ( foldlM )-import GHC.Types.Basic-import GHC.Driver.Types-import GHC.Data.Bag-import GHC.Driver.Session-import GHC.Driver.Ppr-import GHC.Driver.Config import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Data.FastString-import GHC.Types.Unique.DFM-import GHC.Core.TyCo.Rep (TyCoBinder (..)) +import GHC.Unit.Module( Module )+import GHC.Unit.Module.ModGuts+import GHC.Unit.External+ {- ************************************************************************ * *@@ -717,8 +724,7 @@ -- call to the original function | null good_calls- = do { -- debugTraceMsg (text "specImport:no valid calls")- ; return ([], []) }+ = return ([], []) | Just rhs <- canSpecImport dflags fn = do { -- Get rules from the external package state@@ -731,9 +737,8 @@ rules_for_fn = getRules (RuleEnv full_rb vis_orphs) fn ; (rules1, spec_pairs, MkUD { ud_binds = dict_binds1, ud_calls = new_calls })- <- do { -- debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls, ppr rhs])- ; runSpecM $- specCalls True top_env rules_for_fn good_calls fn rhs }+ <- -- debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls, ppr rhs]) >>+ (runSpecM $ specCalls True top_env rules_for_fn good_calls fn rhs) ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs] -- After the rules kick in we may get recursion, but -- we rely on a global GlomBinds to sort that out later@@ -946,7 +951,7 @@ Note [specImport call stack] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When specialising an imports function 'f', we may get new calls-of an imported fuction 'g', which we want to specialise in turn,+of an imported function 'g', which we want to specialise in turn, and similarly specialising 'g' might expose a new call to 'h'. We track the stack of enclosing functions. So when specialising 'h' we@@ -1526,7 +1531,7 @@ -- See Note [Specialising imported functions] in "GHC.Core.Opt.OccurAnal" | InlinePragma { inl_inline = Inlinable } <- inl_prag- = (inl_prag { inl_inline = NoUserInline }, noUnfolding)+ = (inl_prag { inl_inline = NoUserInlinePrag }, noUnfolding) | otherwise = (inl_prag, specUnfolding simpl_opts spec_bndrs (`mkApps` spec_args)
compiler/GHC/Core/Opt/StaticArgs.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -48,7 +50,6 @@ essential to make this work well! -} -{-# LANGUAGE CPP, PatternSynonyms #-} module GHC.Core.Opt.StaticArgs ( doStaticArgs ) where import GHC.Prelude@@ -188,7 +189,7 @@ else Nothing return (var, emptyIdSATInfo, app_info) -satExpr lit@(Lit _) _ = do+satExpr lit@(Lit _) _ = return (lit, emptyIdSATInfo, Nothing) satExpr (Lam binders body) interesting_ids = do@@ -237,10 +238,10 @@ (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids return (Tick tickish expr', sat_info_expr, expr_app) -satExpr ty@(Type _) _ = do+satExpr ty@(Type _) _ = return (ty, emptyIdSATInfo, Nothing) -satExpr co@(Coercion _) _ = do+satExpr co@(Coercion _) _ = return (co, emptyIdSATInfo, Nothing) satExpr (Cast expr coercion) interesting_ids = do
compiler/GHC/Core/Opt/WorkWrap.hs view
@@ -26,6 +26,7 @@ import GHC.Driver.Config import GHC.Types.Demand import GHC.Types.Cpr+import GHC.Types.SourceText import GHC.Core.Opt.WorkWrap.Utils import GHC.Utils.Misc import GHC.Utils.Outputable@@ -446,13 +447,19 @@ - Otherwise inline wrapper in phase 2. That allows the 'gentle' simplification pass to apply specialisation rules --Note [Wrapper NoUserInline]+Note [Wrapper NoUserInlinePrag] ~~~~~~~~~~~~~~~~~~~~~~~~~~~-The use an inl_inline of NoUserInline on the wrapper distinguishes-this pragma from one that was given by the user. In particular, CSE-will not happen if there is a user-specified pragma, but should happen-for w/w’ed things (#14186).+We use NoUserInlinePrag on the wrapper, to say that there is no+user-specified inline pragma. (The worker inherits that; see Note+[Worker-wrapper for INLINABLE functions].) The wrapper has no pragma+given by the user.++(Historical note: we used to give the wrapper an INLINE pragma, but+CSE will not happen if there is a user-specified pragma, but should+happen for w/w’ed things (#14186). We don't need a pragma, because+everything we needs is expressed by (a) the stable unfolding and (b)+the inl_act activation.)+ -} tryWW :: DynFlags@@ -678,7 +685,7 @@ 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_inline = NoUserInlinePrag -- See Note [Wrapper NoUserInline] , inl_sat = Nothing , inl_act = wrap_act , inl_rule = rule_info } -- RuleMatchInfo is (and must be) unaffected
compiler/GHC/Core/Opt/WorkWrap/Utils.hs view
@@ -40,6 +40,7 @@ import GHC.Core.FamInstEnv import GHC.Types.Basic ( Boxity(..) ) import GHC.Core.TyCon+import GHC.Core.TyCon.RecWalk import GHC.Types.Unique.Supply import GHC.Types.Unique import GHC.Data.Maybe@@ -923,15 +924,13 @@ BUT if f is strict in the Ord dictionary, we might unpack it, to get fw :: (a->a->Bool) -> [a] -> Int# -> a-and the type-class specialiser can't specialise that. An example is-#6056.+and the type-class specialiser can't specialise that. An example is #6056. But in any other situation a dictionary is just an ordinary value, and can be unpacked. So we track the INLINABLE pragma, and switch off the unpacking in mkWWstr_one (see the isClassPred test). -Historical note: #14955 describes how I got this fix wrong-the first time.+Historical note: #14955 describes how I got this fix wrong the first time. -} -- | Context for a 'DataCon' application with a hole for every field, including
− compiler/GHC/Core/Ppr/TyThing.hs
@@ -1,207 +0,0 @@------------------------------------------------------------------------------------ Pretty-printing TyThings------ (c) The GHC Team 2005-----------------------------------------------------------------------------------{-# LANGUAGE CPP #-}-module GHC.Core.Ppr.TyThing (- pprTyThing,- pprTyThingInContext,- pprTyThingLoc,- pprTyThingInContextLoc,- pprTyThingHdr,- pprTypeForUser,- pprFamInst- ) where--#include "GhclibHsVersions.h"--import GHC.Prelude--import GHC.Core.Type ( Type, ArgFlag(..), TyThing(..), mkTyVarBinders, tidyOpenType )-import GHC.Iface.Syntax ( ShowSub(..), ShowHowMuch(..), AltPpr(..)- , showToHeader, pprIfaceDecl )-import GHC.Core.Coercion.Axiom ( coAxiomTyCon )-import GHC.Driver.Types( tyThingParent_maybe )-import GHC.Driver.Ppr-import GHC.Iface.Make ( tyThingToIfaceDecl )-import GHC.Core.FamInstEnv( FamInst(..), FamFlavor(..) )-import GHC.Core.TyCo.Ppr ( pprUserForAll, pprTypeApp, pprSigmaType )-import GHC.Types.Name-import GHC.Types.Var.Env( emptyTidyEnv )-import GHC.Utils.Outputable---- -------------------------------------------------------------------------------- Pretty-printing entities that we get from the GHC API--{- Note [Pretty printing via Iface syntax]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Our general plan for pretty-printing- - Types- - TyCons- - Classes- - Pattern synonyms- ...etc...--is to convert them to Iface syntax, and pretty-print that. For example- - pprType converts a Type to an IfaceType, and pretty prints that.- - pprTyThing converts the TyThing to an IfaceDecl,- and pretty prints that.--So Iface syntax plays a dual role:- - it's the internal version of an interface files- - it's used for pretty-printing--Why do this?--* A significant reason is that we need to be able- to pretty-print Iface syntax (to display Foo.hi), and it was a- pain to duplicate masses of pretty-printing goop, esp for- Type and IfaceType.--* When pretty-printing (a type, say), we want to tidy (with- tidyType) to avoids having (forall a a. blah) where the two- a's have different uniques.-- Alas, for type constructors, TyCon, tidying does not work well,- because a TyCon includes DataCons which include Types, which mention- TyCons. And tidying can't tidy a mutually recursive data structure- graph, only trees.--* Interface files contains fast-strings, not uniques, so the very same- tidying must take place when we convert to IfaceDecl. E.g.- GHC.Iface.Make.tyThingToIfaceDecl which converts a TyThing (i.e. TyCon,- Class etc) to an IfaceDecl.-- Bottom line: IfaceDecls are already 'tidy', so it's straightforward- to print them.--* An alternative I once explored was to ensure that TyCons get type- variables with distinct print-names. That's ok for type variables- but less easy for kind variables. Processing data type declarations- is already so complicated that I don't think it's sensible to add- the extra requirement that it generates only "pretty" types and- kinds.--Consequences:--- Iface syntax (and IfaceType) must contain enough information to- print nicely. Hence, for example, the IfaceAppArgs type, which- allows us to suppress invisible kind arguments in types- (see Note [Suppressing invisible arguments] in GHC.Iface.Type)--- In a few places we have info that is used only for pretty-printing,- and is totally ignored when turning Iface syntax back into Core- (in GHC.IfaceToCore). For example, IfaceClosedSynFamilyTyCon- stores a [IfaceAxBranch] that is used only for pretty-printing.--- See Note [Free tyvars in IfaceType] in GHC.Iface.Type--See #7730, #8776 for details -}------------------------- | Pretty-prints a 'FamInst' (type/data family instance) with its defining location.-pprFamInst :: FamInst -> SDoc--- * For data instances we go via pprTyThing of the representational TyCon,--- because there is already much cleverness associated with printing--- data type declarations that I don't want to duplicate--- * For type instances we print directly here; there is no TyCon--- to give to pprTyThing------ FamInstEnv.pprFamInst does a more quick-and-dirty job for internal purposes--pprFamInst (FamInst { fi_flavor = DataFamilyInst rep_tc })- = pprTyThingInContextLoc (ATyCon rep_tc)--pprFamInst (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom- , fi_tvs = tvs, fi_tys = lhs_tys, fi_rhs = rhs })- = showWithLoc (pprDefinedAt (getName axiom)) $- hang (text "type instance"- <+> pprUserForAll (mkTyVarBinders Specified tvs)- -- See Note [Printing foralls in type family instances]- -- in GHC.Iface.Type- <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys)- 2 (equals <+> ppr rhs)--------------------------------- | Pretty-prints a 'TyThing' with its defining location.-pprTyThingLoc :: TyThing -> SDoc-pprTyThingLoc tyThing- = showWithLoc (pprDefinedAt (getName tyThing))- (pprTyThing showToHeader tyThing)---- | Pretty-prints the 'TyThing' header. For functions and data constructors--- the function is equivalent to 'pprTyThing' but for type constructors--- and classes it prints only the header part of the declaration.-pprTyThingHdr :: TyThing -> SDoc-pprTyThingHdr = pprTyThing showToHeader---- | Pretty-prints a 'TyThing' in context: that is, if the entity--- is a data constructor, record selector, or class method, then--- the entity's parent declaration is pretty-printed with irrelevant--- parts omitted.-pprTyThingInContext :: ShowSub -> TyThing -> SDoc-pprTyThingInContext show_sub thing- = go [] thing- where- go ss thing- = case tyThingParent_maybe thing of- Just parent ->- go (getOccName thing : ss) parent- Nothing ->- pprTyThing- (show_sub { ss_how_much = ShowSome ss (AltPpr Nothing) })- thing---- | Like 'pprTyThingInContext', but adds the defining location.-pprTyThingInContextLoc :: TyThing -> SDoc-pprTyThingInContextLoc tyThing- = showWithLoc (pprDefinedAt (getName tyThing))- (pprTyThingInContext showToHeader tyThing)---- | Pretty-prints a 'TyThing'.-pprTyThing :: ShowSub -> TyThing -> SDoc--- We pretty-print 'TyThing' via 'IfaceDecl'--- See Note [Pretty-printing TyThings]-pprTyThing ss ty_thing- = sdocOption sdocLinearTypes $ \show_linear_types ->- pprIfaceDecl ss' (tyThingToIfaceDecl show_linear_types ty_thing)- where- ss' = case ss_how_much ss of- ShowHeader (AltPpr Nothing) -> ss { ss_how_much = ShowHeader ppr' }- ShowSome xs (AltPpr Nothing) -> ss { ss_how_much = ShowSome xs ppr' }- _ -> ss-- ppr' = AltPpr $ ppr_bndr $ getName ty_thing-- ppr_bndr :: Name -> Maybe (OccName -> SDoc)- ppr_bndr name- | isBuiltInSyntax name- = Nothing- | otherwise- = case nameModule_maybe name of- Just mod -> Just $ \occ -> getPprStyle $ \sty ->- pprModulePrefix sty mod occ <> ppr occ- Nothing -> WARN( True, ppr name ) Nothing- -- Nothing is unexpected here; TyThings have External names--pprTypeForUser :: Type -> SDoc--- The type is tidied-pprTypeForUser ty- = pprSigmaType tidy_ty- where- (_, tidy_ty) = tidyOpenType emptyTidyEnv ty- -- Often the types/kinds we print in ghci are fully generalised- -- and have no free variables, but it turns out that we sometimes- -- print un-generalised kinds (eg when doing :k T), so it's- -- better to use tidyOpenType here--showWithLoc :: SDoc -> SDoc -> SDoc-showWithLoc loc doc- = hang doc 2 (char '\t' <> comment <+> loc)- -- The tab tries to make them line up a bit- where- comment = text "--"
+ compiler/GHC/Core/TyCon/Set.hs view
@@ -0,0 +1,73 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++-}++{-# LANGUAGE CPP #-}++module GHC.Core.TyCon.Set (+ -- * TyCons set type+ TyConSet,++ -- ** Manipulating these sets+ emptyTyConSet, unitTyConSet, mkTyConSet, unionTyConSet, unionTyConSets,+ minusTyConSet, elemTyConSet, extendTyConSet, extendTyConSetList,+ delFromTyConSet, delListFromTyConSet, isEmptyTyConSet, filterTyConSet,+ intersectsTyConSet, disjointTyConSet, intersectTyConSet,+ nameSetAny, nameSetAll+ ) where++#include "GhclibHsVersions.h"++import GHC.Prelude++import GHC.Types.Unique.Set+import GHC.Core.TyCon (TyCon)++type TyConSet = UniqSet TyCon++emptyTyConSet :: TyConSet+unitTyConSet :: TyCon -> TyConSet+extendTyConSetList :: TyConSet -> [TyCon] -> TyConSet+extendTyConSet :: TyConSet -> TyCon -> TyConSet+mkTyConSet :: [TyCon] -> TyConSet+unionTyConSet :: TyConSet -> TyConSet -> TyConSet+unionTyConSets :: [TyConSet] -> TyConSet+minusTyConSet :: TyConSet -> TyConSet -> TyConSet+elemTyConSet :: TyCon -> TyConSet -> Bool+isEmptyTyConSet :: TyConSet -> Bool+delFromTyConSet :: TyConSet -> TyCon -> TyConSet+delListFromTyConSet :: TyConSet -> [TyCon] -> TyConSet+filterTyConSet :: (TyCon -> Bool) -> TyConSet -> TyConSet+intersectTyConSet :: TyConSet -> TyConSet -> TyConSet+intersectsTyConSet :: TyConSet -> TyConSet -> Bool+-- ^ True if there is a non-empty intersection.+-- @s1 `intersectsTyConSet` s2@ doesn't compute @s2@ if @s1@ is empty+disjointTyConSet :: TyConSet -> TyConSet -> Bool++isEmptyTyConSet = isEmptyUniqSet+emptyTyConSet = emptyUniqSet+unitTyConSet = unitUniqSet+mkTyConSet = mkUniqSet+extendTyConSetList = addListToUniqSet+extendTyConSet = addOneToUniqSet+unionTyConSet = unionUniqSets+unionTyConSets = unionManyUniqSets+minusTyConSet = minusUniqSet+elemTyConSet = elementOfUniqSet+delFromTyConSet = delOneFromUniqSet+filterTyConSet = filterUniqSet+intersectTyConSet = intersectUniqSets+disjointTyConSet = disjointUniqSets+++delListFromTyConSet set ns = foldl' delFromTyConSet set ns++intersectsTyConSet s1 s2 = not (isEmptyTyConSet (s1 `intersectTyConSet` s2))++nameSetAny :: (TyCon -> Bool) -> TyConSet -> Bool+nameSetAny = uniqSetAny++nameSetAll :: (TyCon -> Bool) -> TyConSet -> Bool+nameSetAll = uniqSetAll
compiler/GHC/CoreToByteCode.hs view
@@ -1,9 +1,11 @@-{-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-}-{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-}+ {-# OPTIONS_GHC -fprof-auto-top #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ -- -- (c) The University of Glasgow 2002-2006 --@@ -15,6 +17,9 @@ import GHC.Prelude +import GHC.Driver.Session+import GHC.Driver.Env+ import GHC.ByteCode.Instr import GHC.ByteCode.Asm import GHC.ByteCode.Types@@ -26,13 +31,11 @@ import GHCi.FFI import GHCi.RemoteTypes import GHC.Types.Basic-import GHC.Driver.Session import GHC.Utils.Outputable import GHC.Types.Name import GHC.Types.Id.Make import GHC.Types.Id import GHC.Types.ForeignCall-import GHC.Driver.Types import GHC.Core.Utils import GHC.Core import GHC.Core.Ppr@@ -72,6 +75,7 @@ import Control.Exception import Data.Array+import Data.Coerce (coerce) import Data.ByteString (ByteString) import Data.Map (Map) import Data.IntMap (IntMap)@@ -625,7 +629,7 @@ -- match = /\(r::RuntimeRep) /\(a::TYPE r). -- \(k :: Int -> a) \(v::T). -- case v of MkV n -> k n- -- Here (k n) :: a :: Type r, so we don't know if it's lifted+ -- 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 (mkVisFunTyMany realWorldStatePrimTy ty)@@ -1965,7 +1969,7 @@ { bcm_hsc_env :: HscEnv , uniqSupply :: UniqSupply -- for generating fresh variable names , thisModule :: Module -- current module (for breakpoints)- , nextlabel :: Word16 -- for generating local labels+ , nextlabel :: Word32 -- for generating local labels , ffis :: [FFIInfo] -- ffi info blocks, to free later -- Should be free()d when it is GCd , modBreaks :: Maybe ModBreaks -- info about breakpoints@@ -2030,17 +2034,17 @@ recordFFIBc a = BcM $ \st -> return (st{ffis = FFIInfo a : ffis st}, ()) -getLabelBc :: BcM Word16+getLabelBc :: BcM LocalLabel getLabelBc = BcM $ \st -> do let nl = nextlabel st when (nl == maxBound) $ panic "getLabelBc: Ran out of labels"- return (st{nextlabel = nl + 1}, nl)+ return (st{nextlabel = nl + 1}, LocalLabel nl) -getLabelsBc :: Word16 -> BcM [Word16]+getLabelsBc :: Word32 -> BcM [LocalLabel] getLabelsBc n = BcM $ \st -> let ctr = nextlabel st- in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])+ in return (st{nextlabel = ctr+n}, coerce [ctr .. ctr+n-1]) getCCArray :: BcM (Array BreakIndex (RemotePtr CostCentre)) getCCArray = BcM $ \st ->
compiler/GHC/CoreToStg.hs view
@@ -51,9 +51,10 @@ import GHC.Types.SrcLoc ( mkGeneralSrcSpan ) import GHC.Builtin.Names ( unsafeEqualityProofName ) -import Data.List.NonEmpty (nonEmpty, toList)-import Data.Maybe (fromMaybe) import Control.Monad (ap)+import Data.List.NonEmpty (nonEmpty, toList)+import Data.Maybe (fromMaybe)+import Data.Tuple (swap) import qualified Data.Set as Set -- Note [Live vs free]@@ -309,14 +310,10 @@ -- generate StgTopBindings and CAF cost centres created for CAFs (ccs', stg_rhss)- = initCts dflags env' $ do- mapAccumLM (\ccs rhs -> do- (rhs', ccs') <-- coreToTopStgRhs dflags ccs this_mod rhs- return (ccs', rhs'))- ccs- pairs-+ = initCts dflags env' $+ mapAccumLM (\ccs rhs -> swap <$> coreToTopStgRhs dflags ccs this_mod rhs)+ ccs+ pairs bind = StgTopLifted $ StgRec (zip binders stg_rhss) in (env', ccs', bind)@@ -467,10 +464,8 @@ rhs2 <- coreToStgExpr rhs return (con, binders', rhs2) -coreToStgExpr (Let bind body) = do- coreToStgLet bind body--coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e)+coreToStgExpr (Let bind body) = coreToStgLet bind body+coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e) mkStgAltType :: Id -> [CoreAlt] -> AltType mkStgAltType bndr alts
compiler/GHC/CoreToStg/Prep.hs view
@@ -1,3 +1,8 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- (c) The University of Glasgow, 1994-2006 @@ -5,10 +10,6 @@ Core pass to saturate constructors and PrimOps -} -{-# LANGUAGE BangPatterns, CPP, MultiWayIf #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- module GHC.CoreToStg.Prep ( corePrepPgm , corePrepExpr@@ -19,14 +20,20 @@ #include "GhclibHsVersions.h" import GHC.Prelude-import GHC.Platform -import GHC.Core.Opt.OccurAnal+import GHC.Platform+import GHC.Platform.Ways -import GHC.Driver.Types+import GHC.Driver.Session+import GHC.Driver.Env import GHC.Driver.Ppr++import GHC.Tc.Utils.Env+import GHC.Unit+ import GHC.Builtin.Names-import GHC.Types.Id.Make ( realWorldPrimId )+import GHC.Builtin.Types+ import GHC.Core.Utils import GHC.Core.Opt.Arity import GHC.Core.FVs@@ -35,37 +42,39 @@ import GHC.Core import GHC.Core.Make hiding( FloatBind(..) ) -- We use our own FloatBind here import GHC.Core.Type-import GHC.Types.Literal import GHC.Core.Coercion-import GHC.Tc.Utils.Env import GHC.Core.TyCon-import GHC.Types.Demand-import GHC.Types.Var-import GHC.Types.Var.Set-import GHC.Types.Var.Env-import GHC.Types.Id-import GHC.Types.Id.Info-import GHC.Builtin.Types import GHC.Core.DataCon-import GHC.Types.Basic-import GHC.Unit-import GHC.Types.Unique.Supply+import GHC.Core.Opt.OccurAnal+ import GHC.Data.Maybe import GHC.Data.OrdList+import GHC.Data.FastString+ import GHC.Utils.Error-import GHC.Driver.Session-import GHC.Platform.Ways import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Outputable-import GHC.Data.FastString+import GHC.Utils.Monad ( mapAccumLM )++import GHC.Types.Demand+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Id.Make ( realWorldPrimId )+import GHC.Types.Basic import GHC.Types.Name ( NamedThing(..), nameSrcSpan, isInternalName ) import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )+import GHC.Types.Literal+import GHC.Types.TyThing+import GHC.Types.CostCentre ( CostCentre, ccFromThisModule )+import GHC.Types.Unique.Supply+ import Data.Bits-import GHC.Utils.Monad ( mapAccumLM ) import Data.List ( unfoldr ) import Control.Monad-import GHC.Types.CostCentre ( CostCentre, ccFromThisModule ) import qualified Data.Set as S {-@@ -1556,7 +1565,7 @@ let dflags = hsc_dflags hsc_env platform = targetPlatform dflags- home_unit = mkHomeUnitFromFlags dflags+ home_unit = hsc_home_unit hsc_env guardBignum act | isHomeUnitInstanceOf home_unit primUnitId = return $ panic "Bignum literals are not supported in ghc-prim"
compiler/GHC/Driver/Backpack.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE OverloadedStrings #-} + -- | This is the driver for the 'ghc --backpack' mode, which -- is a reimplementation of the "package manager" bits of -- Backpack directly in GHC. The basic method of operation@@ -22,41 +23,54 @@ -- In a separate module because it hooks into the parser. import GHC.Driver.Backpack.Syntax--import GHC.Parser.Annotation-import GHC hiding (Failed, Succeeded)-import GHC.Parser-import GHC.Parser.Lexer import GHC.Driver.Config import GHC.Driver.Monad import GHC.Driver.Session import GHC.Driver.Ppr+import GHC.Driver.Main+import GHC.Driver.Make+import GHC.Driver.Env++import GHC.Parser+import GHC.Parser.Header+import GHC.Parser.Lexer+import GHC.Parser.Annotation+import GHC.Parser.Errors.Ppr++import GHC hiding (Failed, Succeeded) import GHC.Tc.Utils.Monad-import GHC.Tc.Module-import GHC.Unit-import GHC.Unit.State-import GHC.Driver.Types-import GHC.Data.StringBuffer-import GHC.Data.FastString-import GHC.Utils.Error+import GHC.Iface.Recomp+import GHC.Builtin.Names+ import GHC.Types.SrcLoc-import GHC.Driver.Main+import GHC.Types.SourceError+import GHC.Types.SourceText+import GHC.Types.SourceFile import GHC.Types.Unique.FM import GHC.Types.Unique.DFM-import GHC.Utils.Outputable-import GHC.Data.Maybe-import GHC.Parser.Header-import GHC.Iface.Recomp-import GHC.Driver.Make import GHC.Types.Unique.DSet-import GHC.Builtin.Names-import GHC.Types.Basic hiding (SuccessFlag(..))-import GHC.Driver.Finder++import GHC.Utils.Outputable import GHC.Utils.Misc+import GHC.Utils.Panic+import GHC.Utils.Error +import GHC.Unit+import GHC.Unit.External+import GHC.Unit.State+import GHC.Unit.Finder+import GHC.Unit.Module.ModSummary (showModMsg)+import GHC.Unit.Home.ModInfo++import GHC.Runtime.Linker.Types+ import qualified GHC.LanguageExtensions as LangExt -import GHC.Utils.Panic+import GHC.Data.Maybe+import GHC.Data.StringBuffer+import GHC.Data.FastString+import qualified GHC.Data.ShortText as ST+ import Data.List ( partition ) import System.Exit import Control.Monad@@ -85,7 +99,7 @@ buf <- liftIO $ hGetStringBuffer src_filename let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great case unP parseBackpack (initParserState (initParserOpts dflags) buf loc) of- PFailed pst -> throwErrors (getErrorMessages pst dflags)+ PFailed pst -> throwErrors (fmap pprError (getErrorMessages pst)) POk _ pkgname_bkp -> do -- OK, so we have an LHsUnit PackageName, but we want an -- LHsUnit HsComponentId. So let's rename it.@@ -210,7 +224,7 @@ do_this withBkpExeSession :: [(Unit, ModRenaming)] -> BkpM a -> BkpM a-withBkpExeSession deps do_this = do+withBkpExeSession deps do_this = withBkpSession (Indefinite (UnitId (fsLit "main"))) [] deps ExeSession do_this getSource :: IndefUnitId -> BkpM (LHsUnit HsComponentId)@@ -287,7 +301,7 @@ conf <- withBkpSession cid insts deps_w_rns session $ do dflags <- getDynFlags- mod_graph <- hsunitModuleGraph dflags (unLoc lunit)+ mod_graph <- hsunitModuleGraph (unLoc lunit) msg <- mkBackpackMsg ok <- load' LoadAllTargets (Just msg) mod_graph@@ -311,7 +325,7 @@ let compat_fs = unitIdFS (indefUnit cid) compat_pn = PackageName compat_fs- unit_id = homeUnitId (mkHomeUnitFromFlags (hsc_dflags hsc_env))+ unit_id = homeUnitId (hsc_home_unit hsc_env) return GenericUnitInfo { -- Stub data@@ -340,8 +354,8 @@ unitAbiDepends = [], unitLinkerOptions = case session of TcSession -> []- _ -> obj_files,- unitImportDirs = [ hi_dir ],+ _ -> map ST.pack $ obj_files,+ unitImportDirs = [ ST.pack $ hi_dir ], unitIsExposed = False, unitIsIndefinite = case session of TcSession -> True@@ -377,8 +391,7 @@ forM_ (zip [1..] deps) $ \(i, dep) -> compileInclude (length deps) (i, dep) withBkpExeSession deps_w_rns $ do- dflags <- getDynFlags- mod_graph <- hsunitModuleGraph dflags (unLoc lunit)+ mod_graph <- hsunitModuleGraph (unLoc lunit) msg <- mkBackpackMsg ok <- load' LoadAllTargets (Just msg) mod_graph when (failed ok) (liftIO $ exitWith (ExitFailure 1))@@ -459,7 +472,7 @@ -- | Run a 'BkpM' computation, with the nesting level bumped one. innerBkpM :: BkpM a -> BkpM a-innerBkpM do_this = do+innerBkpM do_this = -- NB: withTempSession mutates, so we don't have to worry -- about bkp_session being stale. updEnv (\env -> env { bkp_level = bkp_level env + 1 }) do_this@@ -478,14 +491,14 @@ -- | Run 'BkpM' in 'Ghc'. initBkpM :: FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a-initBkpM file bkp m = do- reifyGhc $ \session -> do+initBkpM file bkp m =+ reifyGhc $ \session -> do let env = BkpEnv {- bkp_session = session,- bkp_table = Map.fromList [(hsComponentId (unLoc (hsunitName (unLoc u))), u) | u <- bkp],- bkp_filename = file,- bkp_level = 0- }+ bkp_session = session,+ bkp_table = Map.fromList [(hsComponentId (unLoc (hsunitName (unLoc u))), u) | u <- bkp],+ bkp_filename = file,+ bkp_level = 0+ } runIOEnv env m -- ----------------------------------------------------------------------------@@ -644,15 +657,16 @@ -- -- We don't bother trying to support GHC.Driver.Make for now, it's more trouble -- than it's worth for inline modules.-hsunitModuleGraph :: DynFlags -> HsUnit HsComponentId -> BkpM ModuleGraph-hsunitModuleGraph dflags unit = do+hsunitModuleGraph :: HsUnit HsComponentId -> BkpM ModuleGraph+hsunitModuleGraph unit = do+ hsc_env <- getSession let decls = hsunitBody unit pn = hsPackageName (unLoc (hsunitName unit))- home_unit = mkHomeUnitFromFlags dflags+ home_unit = hsc_home_unit hsc_env -- 1. Create a HsSrcFile/HsigFile summary for every -- explicitly mentioned module/signature.- let get_decl (L _ (DeclD hsc_src lmodname mb_hsmod)) = do+ let get_decl (L _ (DeclD hsc_src lmodname mb_hsmod)) = Just `fmap` summariseDecl pn hsc_src lmodname mb_hsmod get_decl _ = return Nothing nodes <- catMaybes `fmap` mapM get_decl decls
compiler/GHC/Driver/CodeOutput.hs view
@@ -17,32 +17,38 @@ import GHC.Prelude import GHC.Platform+import GHC.ForeignSrcLang import GHC.CmmToAsm ( nativeCodeGen ) import GHC.CmmToLlvm ( llvmCodeGen ) -import GHC.Types.Unique.Supply ( mkSplitUniqSupply )--import GHC.Driver.Finder ( mkStubPaths )-import GHC.Driver.Backend import GHC.CmmToC ( cmmToC ) import GHC.Cmm.Lint ( cmmLint ) import GHC.Cmm ( RawCmmGroup ) import GHC.Cmm.CLabel-import GHC.Driver.Types+ import GHC.Driver.Session import GHC.Driver.Ppr+import GHC.Driver.Backend++import qualified GHC.Data.ShortText as ST import GHC.Data.Stream ( Stream ) import qualified GHC.Data.Stream as Stream+ import GHC.SysTools.FileCleanup import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Panic+ import GHC.Unit import GHC.Unit.State+import GHC.Unit.Finder ( mkStubPaths )+ import GHC.Types.SrcLoc import GHC.Types.CostCentre+import GHC.Types.ForeignStubs+import GHC.Types.Unique.Supply ( mkSplitUniqSupply ) import Control.Exception import System.Directory@@ -125,17 +131,15 @@ -> Stream IO RawCmmGroup a -> [UnitId] -> IO a--outputC dflags filenm cmm_stream packages- = do- withTiming dflags (text "C codegen") (\a -> seq a () {- FIXME -}) $ do- let pkg_names = map unitIdString packages- doOutput filenm $ \ h -> do- hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")- hPutStr h "#include \"Stg.h\"\n"- let platform = targetPlatform dflags- writeC = printForC dflags h . cmmToC platform- Stream.consume cmm_stream writeC+outputC dflags filenm cmm_stream packages =+ withTiming dflags (text "C codegen") (\a -> seq a () {- FIXME -}) $ do+ let pkg_names = map unitIdString packages+ doOutput filenm $ \ h -> do+ hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")+ hPutStr h "#include \"Stg.h\"\n"+ let platform = targetPlatform dflags+ writeC = printForC dflags h . cmmToC platform+ Stream.consume cmm_stream writeC {- ************************************************************************@@ -145,17 +149,18 @@ ************************************************************************ -} -outputAsm :: DynFlags -> Module -> ModLocation -> FilePath+outputAsm :: DynFlags+ -> Module+ -> ModLocation+ -> FilePath -> Stream IO RawCmmGroup a -> IO a-outputAsm dflags this_mod location filenm cmm_stream- = do ncg_uniqs <- mkSplitUniqSupply 'n'-- debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm)-- {-# SCC "OutputAsm" #-} doOutput filenm $- \h -> {-# SCC "NativeCodeGen" #-}- nativeCodeGen dflags this_mod location h ncg_uniqs cmm_stream+outputAsm dflags this_mod location filenm cmm_stream = do+ ncg_uniqs <- mkSplitUniqSupply 'n'+ debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm)+ {-# SCC "OutputAsm" #-} doOutput filenm $+ \h -> {-# SCC "NativeCodeGen" #-}+ nativeCodeGen dflags this_mod location h ncg_uniqs cmm_stream {- ************************************************************************@@ -166,10 +171,10 @@ -} outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a-outputLlvm dflags filenm cmm_stream- = do {-# SCC "llvm_output" #-} doOutput filenm $- \f -> {-# SCC "llvm_CodeGen" #-}- llvmCodeGen dflags f cmm_stream+outputLlvm dflags filenm cmm_stream =+ {-# SCC "llvm_output" #-} doOutput filenm $+ \f -> {-# SCC "llvm_CodeGen" #-}+ llvmCodeGen dflags f cmm_stream {- ************************************************************************@@ -211,7 +216,7 @@ let rts_includes = let rts_pkg = unsafeLookupUnitId (unitState dflags) rtsUnitId in concatMap mk_include (unitIncludes rts_pkg)- mk_include i = "#include \"" ++ i ++ "\"\n"+ mk_include i = "#include \"" ++ ST.unpack i ++ "\"\n" -- wrapper code mentions the ffi_arg type, which comes from ffi.h ffi_includes
− compiler/GHC/Driver/Finder.hs
@@ -1,855 +0,0 @@-{--(c) The University of Glasgow, 2000-2006--\section[Finder]{Module Finder}--}--{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}--module GHC.Driver.Finder (- flushFinderCaches,- FindResult(..),- findImportedModule,- findPluginModule,- findExactModule,- findHomeModule,- findExposedPackageModule,- mkHomeModLocation,- mkHomeModLocation2,- mkHiOnlyModLocation,- mkHiPath,- mkObjPath,- addHomeModuleToFinder,- uncacheModule,- mkStubPaths,-- findObjectLinkableMaybe,- findObjectLinkable,-- cannotFindModule,- cannotFindInterface,-- ) where--#include "GhclibHsVersions.h"--import GHC.Prelude--import GHC.Unit-import GHC.Unit.State-import GHC.Driver.Types-import GHC.Data.FastString-import GHC.Utils.Misc-import GHC.Builtin.Names ( gHC_PRIM )-import GHC.Driver.Session-import GHC.Platform.Ways-import GHC.Utils.Outputable as Outputable-import GHC.Utils.Panic-import GHC.Data.Maybe ( expectJust )--import Data.IORef ( IORef, readIORef, atomicModifyIORef' )-import System.Directory-import System.FilePath-import Control.Monad-import Data.Time---type FileExt = String -- Filename extension-type BaseName = String -- Basename of file---- -------------------------------------------------------------------------------- The Finder---- The Finder provides a thin filesystem abstraction to the rest of--- the compiler. For a given module, it can tell you where the--- source, interface, and object files for that module live.---- It does *not* know which particular package a module lives in. Use--- Packages.lookupModuleInAllUnits for that.---- -------------------------------------------------------------------------------- The finder's cache---- remove all the home modules from the cache; package modules are--- assumed to not move around during a session.-flushFinderCaches :: HscEnv -> IO ()-flushFinderCaches hsc_env =- atomicModifyIORef' fc_ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ())- where- fc_ref = hsc_FC hsc_env- home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)- is_ext mod _ = not (isHomeInstalledModule home_unit mod)--addToFinderCache :: IORef FinderCache -> InstalledModule -> InstalledFindResult -> IO ()-addToFinderCache ref key val =- atomicModifyIORef' ref $ \c -> (extendInstalledModuleEnv c key val, ())--removeFromFinderCache :: IORef FinderCache -> InstalledModule -> IO ()-removeFromFinderCache ref key =- atomicModifyIORef' ref $ \c -> (delInstalledModuleEnv c key, ())--lookupFinderCache :: IORef FinderCache -> InstalledModule -> IO (Maybe InstalledFindResult)-lookupFinderCache ref key = do- c <- readIORef ref- return $! lookupInstalledModuleEnv c key---- -------------------------------------------------------------------------------- The three external entry points---- | Locate a module that was imported by the user. We have the--- module's name, and possibly a package name. Without a package--- name, this function will use the search path and the known exposed--- packages to find the module, if a package is specified then only--- that package is searched for the module.--findImportedModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult-findImportedModule hsc_env mod_name mb_pkg =- case mb_pkg of- Nothing -> unqual_import- Just pkg | pkg == fsLit "this" -> home_import -- "this" is special- | otherwise -> pkg_import- where- home_import = findHomeModule hsc_env mod_name-- pkg_import = findExposedPackageModule hsc_env mod_name mb_pkg-- unqual_import = home_import- `orIfNotFound`- findExposedPackageModule hsc_env mod_name Nothing---- | Locate a plugin module requested by the user, for a compiler--- plugin. This consults the same set of exposed packages as--- 'findImportedModule', unless @-hide-all-plugin-packages@ or--- @-plugin-package@ are specified.-findPluginModule :: HscEnv -> ModuleName -> IO FindResult-findPluginModule hsc_env mod_name =- findHomeModule hsc_env mod_name- `orIfNotFound`- findExposedPluginPackageModule hsc_env mod_name---- | Locate a specific 'Module'. The purpose of this function is to--- create a 'ModLocation' for a given 'Module', that is to find out--- where the files associated with this module live. It is used when--- reading the interface for a module mentioned by another interface,--- for example (a "system import").--findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult-findExactModule hsc_env mod =- let home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)- in if isHomeInstalledModule home_unit mod- then findInstalledHomeModule hsc_env (moduleName mod)- else findPackageModule hsc_env mod---- -------------------------------------------------------------------------------- Helpers---- | Given a monadic actions @this@ and @or_this@, first execute--- @this@. If the returned 'FindResult' is successful, return--- it; otherwise, execute @or_this@. If both failed, this function--- also combines their failure messages in a reasonable way.-orIfNotFound :: Monad m => m FindResult -> m FindResult -> m FindResult-orIfNotFound this or_this = do- res <- this- case res of- NotFound { fr_paths = paths1, fr_mods_hidden = mh1- , fr_pkgs_hidden = ph1, fr_unusables = u1, fr_suggestions = s1 }- -> do res2 <- or_this- case res2 of- NotFound { fr_paths = paths2, fr_pkg = mb_pkg2, fr_mods_hidden = mh2- , fr_pkgs_hidden = ph2, fr_unusables = u2- , fr_suggestions = s2 }- -> return (NotFound { fr_paths = paths1 ++ paths2- , fr_pkg = mb_pkg2 -- snd arg is the package search- , fr_mods_hidden = mh1 ++ mh2- , fr_pkgs_hidden = ph1 ++ ph2- , fr_unusables = u1 ++ u2- , fr_suggestions = s1 ++ s2 })- _other -> return res2- _other -> return res---- | Helper function for 'findHomeModule': this function wraps an IO action--- which would look up @mod_name@ in the file system (the home package),--- and first consults the 'hsc_FC' cache to see if the lookup has already--- been done. Otherwise, do the lookup (with the IO action) and save--- the result in the finder cache and the module location cache (if it--- was successful.)-homeSearchCache :: HscEnv -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult-homeSearchCache hsc_env mod_name do_this = do- let home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)- mod = mkHomeInstalledModule home_unit mod_name- modLocationCache hsc_env mod do_this--findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString- -> IO FindResult-findExposedPackageModule hsc_env mod_name mb_pkg- = findLookupResult hsc_env- $ lookupModuleWithSuggestions- (unitState (hsc_dflags hsc_env)) mod_name mb_pkg--findExposedPluginPackageModule :: HscEnv -> ModuleName- -> IO FindResult-findExposedPluginPackageModule hsc_env mod_name- = findLookupResult hsc_env- $ lookupPluginModuleWithSuggestions- (unitState (hsc_dflags hsc_env)) mod_name Nothing--findLookupResult :: HscEnv -> LookupResult -> IO FindResult-findLookupResult hsc_env r = case r of- LookupFound m pkg_conf -> do- let im = fst (getModuleInstantiation m)- r' <- findPackageModule_ hsc_env im pkg_conf- case r' of- -- TODO: ghc -M is unlikely to do the right thing- -- with just the location of the thing that was- -- instantiated; you probably also need all of the- -- implicit locations from the instances- InstalledFound loc _ -> return (Found loc m)- InstalledNoPackage _ -> return (NoPackage (moduleUnit m))- InstalledNotFound fp _ -> return (NotFound{ fr_paths = fp, fr_pkg = Just (moduleUnit m)- , fr_pkgs_hidden = []- , fr_mods_hidden = []- , fr_unusables = []- , fr_suggestions = []})- LookupMultiple rs ->- return (FoundMultiple rs)- LookupHidden pkg_hiddens mod_hiddens ->- return (NotFound{ fr_paths = [], fr_pkg = Nothing- , fr_pkgs_hidden = map (moduleUnit.fst) pkg_hiddens- , fr_mods_hidden = map (moduleUnit.fst) mod_hiddens- , fr_unusables = []- , fr_suggestions = [] })- LookupUnusable unusable ->- let unusables' = map get_unusable unusable- get_unusable (m, ModUnusable r) = (moduleUnit m, r)- get_unusable (_, r) =- pprPanic "findLookupResult: unexpected origin" (ppr r)- in return (NotFound{ fr_paths = [], fr_pkg = Nothing- , fr_pkgs_hidden = []- , fr_mods_hidden = []- , fr_unusables = unusables'- , fr_suggestions = [] })- 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' })--modLocationCache :: HscEnv -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult-modLocationCache hsc_env mod do_this = do- m <- lookupFinderCache (hsc_FC hsc_env) mod- case m of- Just result -> return result- Nothing -> do- result <- do_this- addToFinderCache (hsc_FC hsc_env) mod result- return result---- This returns a module because it's more convenient for users-addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module-addHomeModuleToFinder hsc_env mod_name loc = do- let home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)- mod = mkHomeInstalledModule home_unit mod_name- addToFinderCache (hsc_FC hsc_env) mod (InstalledFound loc mod)- return (mkHomeModule home_unit mod_name)--uncacheModule :: HscEnv -> ModuleName -> IO ()-uncacheModule hsc_env mod_name = do- let home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)- mod = mkHomeInstalledModule home_unit mod_name- removeFromFinderCache (hsc_FC hsc_env) mod---- -------------------------------------------------------------------------------- The internal workers--findHomeModule :: HscEnv -> ModuleName -> IO FindResult-findHomeModule hsc_env mod_name = do- r <- findInstalledHomeModule hsc_env mod_name- return $ case r of- InstalledFound loc _ -> Found loc (mkHomeModule home_unit mod_name)- InstalledNoPackage _ -> NoPackage uid -- impossible- InstalledNotFound fps _ -> NotFound {- fr_paths = fps,- fr_pkg = Just uid,- fr_mods_hidden = [],- fr_pkgs_hidden = [],- fr_unusables = [],- fr_suggestions = []- }- where- dflags = hsc_dflags hsc_env- home_unit = mkHomeUnitFromFlags dflags- uid = homeUnitAsUnit (mkHomeUnitFromFlags 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--- as a building block for the following operations:------ 1. When you do a normal package lookup, we first check if the module--- is available in the home module, before looking it up in the package--- database.------ 2. When you have a package qualified import with package name "this",--- we shortcut to the home module.------ 3. When we look up an exact 'Module', if the unit id associated with--- the module is the current home module do a look up in the home module.------ 4. Some special-case code in GHCi (ToDo: Figure out why that needs to--- call this.)-findInstalledHomeModule :: HscEnv -> ModuleName -> IO InstalledFindResult-findInstalledHomeModule hsc_env mod_name =- homeSearchCache hsc_env mod_name $- let- dflags = hsc_dflags hsc_env- home_unit = mkHomeUnitFromFlags dflags- home_path = importPaths dflags- hisuf = hiSuf dflags- mod = mkHomeInstalledModule home_unit mod_name-- source_exts =- [ ("hs", mkHomeModLocationSearched dflags mod_name "hs")- , ("lhs", mkHomeModLocationSearched dflags mod_name "lhs")- , ("hsig", mkHomeModLocationSearched dflags mod_name "hsig")- , ("lhsig", mkHomeModLocationSearched dflags mod_name "lhsig")- ]-- -- we use mkHomeModHiOnlyLocation instead of mkHiOnlyModLocation so that- -- when hiDir field is set in dflags, we know to look there (see #16500)- hi_exts = [ (hisuf, mkHomeModHiOnlyLocation dflags mod_name)- , (addBootSuffix hisuf, mkHomeModHiOnlyLocation dflags mod_name)- ]-- -- In compilation manager modes, we look for source files in the home- -- package because we can compile these automatically. In one-shot- -- compilation mode we look for .hi and .hi-boot files only.- exts | isOneShot (ghcMode dflags) = hi_exts- | otherwise = source_exts- in-- -- special case for GHC.Prim; we won't find it in the filesystem.- -- This is important only when compiling the base package (where GHC.Prim- -- is a home module).- if mod `installedModuleEq` gHC_PRIM- then return (InstalledFound (error "GHC.Prim ModLocation") mod)- else searchPathExts home_path mod exts----- | Search for a module in external packages only.-findPackageModule :: HscEnv -> InstalledModule -> IO InstalledFindResult-findPackageModule hsc_env mod = do- let- dflags = hsc_dflags hsc_env- pkg_id = moduleUnit mod- pkgstate = unitState dflags- --- 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 "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.-findPackageModule_ :: HscEnv -> InstalledModule -> UnitInfo -> IO InstalledFindResult-findPackageModule_ hsc_env mod pkg_conf =- ASSERT2( moduleUnit mod == unitId pkg_conf, ppr (moduleUnit mod) <+> ppr (unitId pkg_conf) )- modLocationCache hsc_env mod $-- -- special case for GHC.Prim; we won't find it in the filesystem.- if mod `installedModuleEq` gHC_PRIM- then return (InstalledFound (error "GHC.Prim ModLocation") mod)- else-- let- dflags = hsc_dflags hsc_env- tag = waysBuildTag (ways dflags)-- -- hi-suffix for packages depends on the build tag.- package_hisuf | null tag = "hi"- | otherwise = tag ++ "_hi"-- mk_hi_loc = mkHiOnlyModLocation dflags package_hisuf-- import_dirs = unitImportDirs pkg_conf- -- we never look for a .hi-boot file in an external package;- -- .hi-boot files only make sense for the home package.- in- case import_dirs of- [one] | MkDepend <- ghcMode dflags -> do- -- there's only one place that this .hi file can be, so- -- don't bother looking for it.- let basename = moduleNameSlashes (moduleName mod)- loc <- mk_hi_loc one basename- return (InstalledFound loc mod)- _otherwise ->- searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)]---- -------------------------------------------------------------------------------- General path searching--searchPathExts- :: [FilePath] -- paths to search- -> InstalledModule -- module name- -> [ (- FileExt, -- suffix- FilePath -> BaseName -> IO ModLocation -- action- )- ]- -> IO InstalledFindResult--searchPathExts paths mod exts- = do result <- search to_search-{-- hPutStrLn stderr (showSDoc $- vcat [text "Search" <+> ppr mod <+> sep (map (text. fst) exts)- , nest 2 (vcat (map text paths))- , case result of- Succeeded (loc, p) -> text "Found" <+> ppr loc- Failed fs -> text "not found"])--}- return result-- where- basename = moduleNameSlashes (moduleName mod)-- to_search :: [(FilePath, IO ModLocation)]- to_search = [ (file, fn path basename)- | path <- paths,- (ext,fn) <- exts,- let base | path == "." = basename- | otherwise = path </> basename- file = base <.> ext- ]-- search [] = return (InstalledNotFound (map fst to_search) (Just (moduleUnit mod)))-- search ((file, mk_result) : rest) = do- b <- doesFileExist file- if b- then do { loc <- mk_result; return (InstalledFound loc mod) }- else search rest--mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt- -> FilePath -> BaseName -> IO ModLocation-mkHomeModLocationSearched dflags mod suff path basename = do- mkHomeModLocation2 dflags mod (path </> basename) suff---- -------------------------------------------------------------------------------- Constructing a home module location---- This is where we construct the ModLocation for a module in the home--- package, for which we have a source file. It is called from three--- places:------ (a) Here in the finder, when we are searching for a module to import,--- using the search path (-i option).------ (b) The compilation manager, when constructing the ModLocation for--- a "root" module (a source file named explicitly on the command line--- or in a :load command in GHCi).------ (c) The driver in one-shot mode, when we need to construct a--- ModLocation for a source file named on the command-line.------ Parameters are:------ mod--- The name of the module------ path--- (a): The search path component where the source file was found.--- (b) and (c): "."------ src_basename--- (a): (moduleNameSlashes mod)--- (b) and (c): The filename of the source file, minus its extension------ ext--- The filename extension of the source file (usually "hs" or "lhs").--mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO ModLocation-mkHomeModLocation dflags mod src_filename = do- let (basename,extension) = splitExtension src_filename- mkHomeModLocation2 dflags mod basename extension--mkHomeModLocation2 :: DynFlags- -> ModuleName- -> FilePath -- Of source module, without suffix- -> String -- Suffix- -> IO ModLocation-mkHomeModLocation2 dflags mod src_basename ext = do- let mod_basename = moduleNameSlashes mod-- obj_fn = mkObjPath dflags src_basename mod_basename- hi_fn = mkHiPath dflags src_basename mod_basename- hie_fn = mkHiePath dflags src_basename mod_basename-- return (ModLocation{ ml_hs_file = Just (src_basename <.> ext),- ml_hi_file = hi_fn,- ml_obj_file = obj_fn,- ml_hie_file = hie_fn })--mkHomeModHiOnlyLocation :: DynFlags- -> ModuleName- -> FilePath- -> BaseName- -> IO ModLocation-mkHomeModHiOnlyLocation dflags mod path basename = do- loc <- mkHomeModLocation2 dflags mod (path </> basename) ""- return loc { ml_hs_file = Nothing }--mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String- -> IO ModLocation-mkHiOnlyModLocation dflags hisuf path basename- = do let full_basename = path </> basename- obj_fn = mkObjPath dflags full_basename basename- hie_fn = mkHiePath dflags full_basename basename- return ModLocation{ ml_hs_file = Nothing,- ml_hi_file = full_basename <.> hisuf,- -- Remove the .hi-boot suffix from- -- hi_file, if it had one. We always- -- want the name of the real .hi file- -- in the ml_hi_file field.- ml_obj_file = obj_fn,- ml_hie_file = hie_fn- }---- | Constructs the filename of a .o file for a given source file.--- Does /not/ check whether the .o file exists-mkObjPath- :: DynFlags- -> FilePath -- the filename of the source file, minus the extension- -> String -- the module name with dots replaced by slashes- -> FilePath-mkObjPath dflags basename mod_basename = obj_basename <.> osuf- where- odir = objectDir dflags- osuf = objectSuf dflags-- obj_basename | Just dir <- odir = dir </> mod_basename- | otherwise = basename----- | Constructs the filename of a .hi file for a given source file.--- Does /not/ check whether the .hi file exists-mkHiPath- :: DynFlags- -> FilePath -- the filename of the source file, minus the extension- -> String -- the module name with dots replaced by slashes- -> FilePath-mkHiPath dflags basename mod_basename = hi_basename <.> hisuf- where- hidir = hiDir dflags- hisuf = hiSuf dflags-- hi_basename | Just dir <- hidir = dir </> mod_basename- | otherwise = basename---- | Constructs the filename of a .hie file for a given source file.--- Does /not/ check whether the .hie file exists-mkHiePath- :: DynFlags- -> FilePath -- the filename of the source file, minus the extension- -> String -- the module name with dots replaced by slashes- -> FilePath-mkHiePath dflags basename mod_basename = hie_basename <.> hiesuf- where- hiedir = hieDir dflags- hiesuf = hieSuf dflags-- hie_basename | Just dir <- hiedir = dir </> mod_basename- | otherwise = basename------ -------------------------------------------------------------------------------- Filenames of the stub files---- We don't have to store these in ModLocations, because they can be derived--- from other available information, and they're only rarely needed.--mkStubPaths- :: DynFlags- -> ModuleName- -> ModLocation- -> FilePath--mkStubPaths dflags mod location- = let- stubdir = stubDir dflags-- mod_basename = moduleNameSlashes mod- src_basename = dropExtension $ expectJust "mkStubPaths"- (ml_hs_file location)-- stub_basename0- | Just dir <- stubdir = dir </> mod_basename- | otherwise = src_basename-- stub_basename = stub_basename0 ++ "_stub"- in- stub_basename <.> "h"---- -------------------------------------------------------------------------------- findLinkable isn't related to the other stuff in here,--- but there's no other obvious place for it--findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable)-findObjectLinkableMaybe mod locn- = do let obj_fn = ml_obj_file locn- maybe_obj_time <- modificationTimeIfExists obj_fn- case maybe_obj_time of- Nothing -> return Nothing- Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time)---- Make an object linkable when we know the object file exists, and we know--- its modification time.-findObjectLinkable :: Module -> FilePath -> UTCTime -> IO Linkable-findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn])- -- We used to look for _stub.o files here, but that was a bug (#706)- -- Now GHC merges the stub.o into the main .o (#3687)---- -------------------------------------------------------------------------------- Error messages--cannotFindModule :: DynFlags -> ModuleName -> FindResult -> SDoc-cannotFindModule dflags mod res = pprWithUnitState unit_state $- cantFindErr (sLit cannotFindMsg)- (sLit "Ambiguous module name")- dflags mod res- where- unit_state = unitState dflags- cannotFindMsg =- case res of- NotFound { fr_mods_hidden = hidden_mods- , fr_pkgs_hidden = hidden_pkgs- , fr_unusables = unusables }- | not (null hidden_mods && null hidden_pkgs && null unusables)- -> "Could not load module"- _ -> "Could not find module"--cannotFindInterface :: DynFlags -> ModuleName -> InstalledFindResult -> SDoc-cannotFindInterface = cantFindInstalledErr (sLit "Failed to load interface for")- (sLit "Ambiguous interface for")--cantFindErr :: PtrString -> PtrString -> DynFlags -> ModuleName -> FindResult- -> SDoc-cantFindErr _ multiple_found _ mod_name (FoundMultiple mods)- | Just pkgs <- unambiguousPackages- = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 (- sep [text "it was found in multiple packages:",- hsep (map ppr pkgs) ]- )- | otherwise- = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 (- vcat (map pprMod mods)- )- where- unambiguousPackages = foldl' unambiguousPackage (Just []) mods- unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _)- = Just (moduleUnit m : xs)- unambiguousPackage _ _ = Nothing-- pprMod (m, o) = text "it is bound as" <+> ppr m <+>- text "by" <+> pprOrigin m o- pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden"- pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable"- pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma (- if e == Just True- then [text "package" <+> ppr (moduleUnit m)]- else [] ++- map ((text "a reexport in package" <+>)- .ppr.mkUnit) res ++- if f then [text "a package flag"] else []- )--cantFindErr cannot_find _ dflags mod_name find_result- = ptext cannot_find <+> quotes (ppr mod_name)- $$ more_info- where- pkgs = unitState dflags- home_unit = mkHomeUnitFromFlags dflags- more_info- = case find_result of- NoPackage pkg- -> text "no unit id matching" <+> quotes (ppr pkg) <+>- text "was found"-- 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, not (isHomeUnit home_unit pkg)- -> not_found_in_package pkg files-- | not (null suggest)- -> pp_suggestions suggest $$ tried_these files dflags-- | null files && null mod_hiddens &&- null pkg_hiddens && null unusables- -> text "It is not a module in the current program, or in any known package."-- | otherwise- -> vcat (map pkg_hidden pkg_hiddens) $$- vcat (map mod_hidden mod_hiddens) $$- vcat (map unusable unusables) $$- tried_these files dflags-- _ -> panic "cantFindErr"-- build_tag = waysBuildTag (ways dflags)-- not_found_in_package pkg files- | build_tag /= ""- = let- build = if build_tag == "p" then "profiling"- else "\"" ++ build_tag ++ "\""- in- text "Perhaps you haven't installed the " <> text build <>- text " libraries for package " <> quotes (ppr pkg) <> char '?' $$- tried_these files dflags-- | otherwise- = text "There are files missing in the " <> quotes (ppr pkg) <>- text " package," $$- text "try running 'ghc-pkg check'." $$- tried_these files dflags-- pkg_hidden :: Unit -> SDoc- pkg_hidden uid =- text "It is a member of the hidden package"- <+> quotes (ppr uid)- --FIXME: we don't really want to show the unit id here we should- -- show the source package id or installed package id if it's ambiguous- <> dot $$ pkg_hidden_hint uid- pkg_hidden_hint uid- | gopt Opt_BuildingCabalPackage dflags- = 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 pkgs uid- = text "You can run" <+>- quotes (text ":set -package " <> ppr (unitPackageName pkg)) <+>- text "to expose it." $$- text "(Note: this unloads all the modules in the current scope.)"- | otherwise = Outputable.empty-- mod_hidden pkg =- text "it is a hidden module in the package" <+> quotes (ppr pkg)-- unusable (pkg, reason)- = text "It is a member of the package"- <+> quotes (ppr pkg)- $$ pprReason (text "which is") reason-- pp_suggestions :: [ModuleSuggestion] -> SDoc- pp_suggestions sugs- | null sugs = Outputable.empty- | otherwise = hang (text "Perhaps you meant")- 2 (vcat (map pp_sugg sugs))-- -- NB: Prefer the *original* location, and then reexports, and then- -- package flags when making suggestions. ToDo: if the original package- -- also has a reexport, prefer that one- pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o- where provenance ModHidden = Outputable.empty- provenance (ModUnusable _) = Outputable.empty- provenance (ModOrigin{ fromOrigUnit = e,- fromExposedReexport = res,- fromPackageFlag = f })- | Just True <- e- = parens (text "from" <+> ppr (moduleUnit mod))- | f && moduleName mod == m- = parens (text "from" <+> ppr (moduleUnit mod))- | (pkg:_) <- res- = parens (text "from" <+> ppr (mkUnit pkg)- <> comma <+> text "reexporting" <+> ppr mod)- | f- = parens (text "defined via package flags to be"- <+> ppr mod)- | otherwise = Outputable.empty- pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o- where provenance ModHidden = Outputable.empty- provenance (ModUnusable _) = Outputable.empty- provenance (ModOrigin{ fromOrigUnit = e,- fromHiddenReexport = rhs })- | Just False <- e- = parens (text "needs flag -package-id"- <+> ppr (moduleUnit mod))- | (pkg:_) <- rhs- = parens (text "needs flag -package-id"- <+> ppr (mkUnit pkg))- | otherwise = Outputable.empty--cantFindInstalledErr :: PtrString -> PtrString -> DynFlags -> ModuleName- -> InstalledFindResult -> SDoc-cantFindInstalledErr cannot_find _ dflags mod_name find_result- = ptext cannot_find <+> quotes (ppr mod_name)- $$ more_info- where- home_unit = mkHomeUnitFromFlags dflags- unit_state = unitState dflags- build_tag = waysBuildTag (ways dflags)-- more_info- = case find_result of- InstalledNoPackage pkg- -> text "no unit id matching" <+> quotes (ppr pkg) <+>- text "was found" $$ looks_like_srcpkgid pkg-- InstalledNotFound files mb_pkg- | Just pkg <- mb_pkg, not (isHomeUnitId home_unit pkg)- -> not_found_in_package pkg files-- | null files- -> text "It is not a module in the current program, or in any known package."-- | otherwise- -> tried_these files dflags-- _ -> panic "cantFindInstalledErr"-- looks_like_srcpkgid :: UnitId -> SDoc- looks_like_srcpkgid pk- -- Unsafely coerce a unit id (i.e. an installed package component- -- identifier) into a PackageId and see if it means anything.- | (pkg:pkgs) <- searchPackageId unit_state (PackageId (unitIdFS pk))- = parens (text "This unit ID looks like the source package ID;" $$- text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$- (if null pkgs then Outputable.empty- else text "and" <+> int (length pkgs) <+> text "other candidates"))- -- Todo: also check if it looks like a package name!- | otherwise = Outputable.empty-- not_found_in_package pkg files- | build_tag /= ""- = let- build = if build_tag == "p" then "profiling"- else "\"" ++ build_tag ++ "\""- in- text "Perhaps you haven't installed the " <> text build <>- text " libraries for package " <> quotes (ppr pkg) <> char '?' $$- tried_these files dflags-- | otherwise- = text "There are files missing in the " <> quotes (ppr pkg) <>- text " package," $$- text "try running 'ghc-pkg check'." $$- tried_these files dflags--tried_these :: [FilePath] -> DynFlags -> SDoc-tried_these files dflags- | null files = Outputable.empty- | verbosity dflags < 3 =- text "Use -v (or `:set -v` in ghci) " <>- text "to see a list of the files searched for."- | otherwise =- hang (text "Locations searched:") 2 $ vcat (map text files)
compiler/GHC/Driver/Main.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE BangPatterns, CPP, MagicHash, NondecreasingIndentation #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NondecreasingIndentation #-} {-# OPTIONS_GHC -fprof-auto-top #-} -------------------------------------------------------------------------------@@ -86,86 +88,127 @@ import GHC.Prelude -import Data.Data hiding (Fixity, TyCon)-import Data.Maybe ( fromJust )-import GHC.Types.Id+import GHC.Driver.Plugins+import GHC.Driver.Session+import GHC.Driver.Backend+import GHC.Driver.Env+import GHC.Driver.CodeOutput+import GHC.Driver.Config+import GHC.Driver.Hooks++import GHC.Runtime.Context+import GHC.Runtime.Linker+import GHC.Runtime.Linker.Types import GHC.Runtime.Interpreter ( addSptEntry )+import GHC.Runtime.Loader ( initializePlugins ) import GHCi.RemoteTypes ( ForeignHValue )+import GHC.ByteCode.Types++import GHC.Hs+import GHC.Hs.Dump+import GHC.Hs.Stats ( ppSourceStats )++import GHC.HsToCore+ import GHC.CoreToByteCode ( byteCodeGen, coreExprToBCOs )-import GHC.Runtime.Linker++import GHC.IfaceToCore ( typecheckIface )++import GHC.Iface.Load ( ifaceStats, initExternalPackageState, writeIface )+import GHC.Iface.Make+import GHC.Iface.Recomp+import GHC.Iface.Tidy+import GHC.Iface.Ext.Ast ( mkHieFile )+import GHC.Iface.Ext.Types ( getAsts, hie_asts, hie_module )+import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result, NameCacheUpdater(..))+import GHC.Iface.Ext.Debug ( diffFile, validateScopes )+import GHC.Iface.Env ( updNameCache )++import GHC.Core import GHC.Core.Tidy ( tidyExpr ) import GHC.Core.Type ( Type, Kind ) import GHC.Core.Lint ( lintInteractiveExpr )-import GHC.Types.Var.Env ( emptyTidyEnv )-import GHC.Utils.Panic import GHC.Core.ConLike+import GHC.Core.Opt.Pipeline+import GHC.Core.TyCon+import GHC.Core.InstEnv+import GHC.Core.FamInstEnv +import GHC.CoreToStg.Prep+import GHC.CoreToStg ( coreToStg )+ import GHC.Parser.Annotation-import GHC.Unit-import GHC.Unit.State-import GHC.Types.Name.Reader-import GHC.Hs-import GHC.Hs.Dump-import GHC.Core-import GHC.Data.StringBuffer+import GHC.Parser.Errors+import GHC.Parser.Errors.Ppr import GHC.Parser import GHC.Parser.Lexer as Lexer-import GHC.Types.SrcLoc+ import GHC.Tc.Module-import GHC.IfaceToCore ( typecheckIface ) import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Zonk ( ZonkFlexi (DefaultFlexi) )-import GHC.Types.Name.Cache ( initNameCache )-import GHC.Builtin.Utils-import GHC.Core.Opt.Pipeline-import GHC.HsToCore-import GHC.Iface.Load ( ifaceStats, initExternalPackageState, writeIface )-import GHC.Iface.Make-import GHC.Iface.Recomp-import GHC.Iface.Tidy-import GHC.CoreToStg.Prep-import GHC.CoreToStg ( coreToStg )+ import GHC.Stg.Syntax import GHC.Stg.FVs ( annTopBindingsFreeVars ) import GHC.Stg.Pipeline ( stg2stg )++import GHC.Builtin.Utils+import GHC.Builtin.Names+ import qualified GHC.StgToCmm as StgToCmm ( codeGen )-import GHC.Types.CostCentre-import GHC.Core.TyCon-import GHC.Types.Name+import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos)+ import GHC.Cmm import GHC.Cmm.Parser ( parseCmmFile ) import GHC.Cmm.Info.Build import GHC.Cmm.Pipeline import GHC.Cmm.Info-import GHC.Driver.CodeOutput-import GHC.Driver.Config-import GHC.Core.InstEnv-import GHC.Core.FamInstEnv-import GHC.Utils.Fingerprint ( Fingerprint )-import GHC.Driver.Hooks-import GHC.Tc.Utils.Env-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.Driver.Backend-import GHC.Utils.Error+import GHC.Unit+import GHC.Unit.External+import GHC.Unit.State+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.ModGuts+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.Graph+import GHC.Unit.Module.Imported+import GHC.Unit.Module.Deps+import GHC.Unit.Module.Status+import GHC.Unit.Home.ModInfo -import GHC.Utils.Outputable+import GHC.Types.Id+import GHC.Types.SourceError+import GHC.Types.SafeHaskell+import GHC.Types.ForeignStubs+import GHC.Types.Var.Env ( emptyTidyEnv )+import GHC.Types.Fixity.Env+import GHC.Types.CostCentre+import GHC.Types.Unique.Supply+import GHC.Types.SourceFile+import GHC.Types.SrcLoc+import GHC.Types.Name import GHC.Types.Name.Env-import GHC.Hs.Stats ( ppSourceStats )-import GHC.Driver.Types+import GHC.Types.Name.Cache ( initNameCache )+import GHC.Types.Name.Reader+import GHC.Types.Name.Ppr+import GHC.Types.TyThing+import GHC.Types.HpcInfo++import GHC.Utils.Fingerprint ( Fingerprint )+import GHC.Utils.Panic+import GHC.Utils.Error+import GHC.Utils.Outputable+import GHC.Utils.Exception+import GHC.Utils.Misc+ import GHC.Data.FastString-import GHC.Types.Unique.Supply import GHC.Data.Bag-import GHC.Utils.Exception+import GHC.Data.StringBuffer import qualified GHC.Data.Stream as Stream import GHC.Data.Stream (Stream) -import GHC.Utils.Misc-+import Data.Data hiding (Fixity, TyCon)+import Data.Maybe ( fromJust ) import Data.List ( nub, isPrefixOf, partition ) import Control.Monad import Data.IORef@@ -177,12 +220,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 )-import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result, NameCacheUpdater(..))-import GHC.Iface.Ext.Debug ( diffFile, validateScopes )+import Data.Bifunctor (first, bimap) #include "GhclibHsVersions.h" @@ -212,6 +250,7 @@ , hsc_type_env_var = Nothing , hsc_interp = Nothing , hsc_dynLinker = emptyDynLinker+ , hsc_home_unit = home_unit } -- -----------------------------------------------------------------------------@@ -237,15 +276,19 @@ -- | log warning in the monad, and if there are errors then -- throw a SourceError exception.-logWarningsReportErrors :: Messages -> Hsc ()-logWarningsReportErrors (warns,errs) = do+logWarningsReportErrors :: (Bag Warning, Bag Error) -> Hsc ()+logWarningsReportErrors (warnings,errors) = do+ let warns = fmap pprWarning warnings+ errs = fmap pprError errors logWarnings warns when (not $ isEmptyBag errs) $ throwErrors errs -- | Log warnings and throw errors, assuming the messages -- contain at least one error (e.g. coming from PFailed)-handleWarningsThrowErrors :: Messages -> Hsc a-handleWarningsThrowErrors (warns, errs) = do+handleWarningsThrowErrors :: (Bag Warning, Bag Error) -> Hsc a+handleWarningsThrowErrors (warnings, errors) = do+ let warns = fmap pprWarning warnings+ errs = fmap pprError errors logWarnings warns dflags <- getDynFlags (wWarns, wErrs) <- warningsToMessages dflags <$> getWarnings@@ -356,9 +399,9 @@ case unP parseMod (initParserState (initParserOpts dflags) buf loc) of PFailed pst ->- handleWarningsThrowErrors (getMessages pst dflags)+ handleWarningsThrowErrors (getMessages pst) POk pst rdr_module -> do- let (warns, errs) = getMessages pst dflags+ let (warns, errs) = bimap (fmap pprWarning) (fmap pprError) (getMessages pst) logWarnings warns liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" FormatHaskell (ppr rdr_module)@@ -471,7 +514,7 @@ hsc_env <- getHscEnv let hsc_src = ms_hsc_src mod_summary dflags = hsc_dflags hsc_env- home_unit = mkHomeUnitFromFlags dflags+ home_unit = hsc_home_unit hsc_env outer_mod = ms_mod mod_summary mod_name = moduleName outer_mod outer_mod' = mkHomeModule home_unit mod_name@@ -532,7 +575,7 @@ else do tcg_res' <- hscCheckSafeImports tcg_res safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res')- when safe $ do+ when safe $ case wopt Opt_WarnSafe dflags of True | safeHaskell dflags == Sf_Safe -> return ()@@ -758,8 +801,7 @@ -- in one-shot mode, since we're not going to do -- any further typechecking. It's much more useful -- in make mode, since this HMI will go into the HPT.- details <- genModDetails hsc_env' iface- return details+ genModDetails hsc_env' iface return (HscUpToDate iface details, dflags) -- We finished type checking. (mb_old_hash is the hash of -- the interface that existed on disk; it's possible we had@@ -969,7 +1011,7 @@ checkRULES dflags tcg_env' where- checkRULES dflags tcg_env' = do+ checkRULES dflags tcg_env' = case safeLanguageOn dflags of True -> do -- XSafe: we nuke user written RULES@@ -1117,9 +1159,9 @@ hscCheckSafe' :: Module -> SrcSpan -> Hsc (Maybe UnitId, Set UnitId) hscCheckSafe' m l = do- dflags <- getDynFlags- let home_unit = mkHomeUnitFromFlags dflags- (tw, pkgs) <- isModSafe m l+ hsc_env <- getHscEnv+ let home_unit = hsc_home_unit hsc_env+ (tw, pkgs) <- isModSafe home_unit m l case tw of False -> return (Nothing, pkgs) True | isHomeModule home_unit m -> return (Nothing, pkgs)@@ -1127,8 +1169,8 @@ -- Not necessary if that is reflected in dependencies | otherwise -> return (Just $ toUnitId (moduleUnit m), pkgs) where- isModSafe :: Module -> SrcSpan -> Hsc (Bool, Set UnitId)- isModSafe m l = do+ isModSafe :: HomeUnit -> Module -> SrcSpan -> Hsc (Bool, Set UnitId)+ isModSafe home_unit m l = do dflags <- getDynFlags iface <- lookup' m case iface of@@ -1144,7 +1186,7 @@ -- check module is trusted safeM = trust `elem` [Sf_Safe, Sf_SafeInferred, Sf_Trustworthy] -- check package is trusted- safeP = packageTrusted dflags trust trust_own_pkg m+ safeP = packageTrusted dflags home_unit trust trust_own_pkg m -- pkg trust reqs pkgRs = S.fromList . map fst $ filter snd $ dep_pkgs $ mi_deps iface' -- warn if Safe module imports Safe-Inferred module.@@ -1189,16 +1231,16 @@ -- modules are trusted without requiring that their package is trusted. For -- trustworthy modules, modules in the home package are trusted but -- otherwise we check the package trust flag.- packageTrusted :: DynFlags -> SafeHaskellMode -> Bool -> Module -> Bool- packageTrusted _ Sf_None _ _ = False -- shouldn't hit these cases- packageTrusted _ Sf_Ignore _ _ = False -- shouldn't hit these cases- packageTrusted _ Sf_Unsafe _ _ = False -- prefer for completeness.- packageTrusted dflags _ _ _+ packageTrusted :: DynFlags -> HomeUnit -> SafeHaskellMode -> Bool -> Module -> Bool+ packageTrusted _ _ Sf_None _ _ = False -- shouldn't hit these cases+ packageTrusted _ _ Sf_Ignore _ _ = False -- shouldn't hit these cases+ packageTrusted _ _ Sf_Unsafe _ _ = False -- prefer for completeness.+ packageTrusted dflags _ _ _ _ | not (packageTrustOn dflags) = True- packageTrusted _ Sf_Safe False _ = True- packageTrusted _ Sf_SafeInferred False _ = True- packageTrusted dflags _ _ m- | isHomeModule (mkHomeUnitFromFlags dflags) m = True+ packageTrusted _ _ Sf_Safe False _ = True+ packageTrusted _ _ Sf_SafeInferred False _ = True+ packageTrusted dflags home_unit _ _ m+ | isHomeModule home_unit m = True | otherwise = unitIsTrusted $ unsafeLookupUnit (unitState dflags) (moduleUnit m) lookup' :: Module -> Hsc (Maybe ModIface)@@ -1211,10 +1253,9 @@ -- the 'lookupIfaceByModule' method will always fail when calling from GHCi -- as the compiler hasn't filled in the various module tables -- so we need to call 'getModuleInterface' to load from disk- iface' <- case iface of+ case iface of Just _ -> return iface Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m)- return iface' -- | Check the list of packages are trusted.@@ -1494,9 +1535,13 @@ hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO () hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do let dflags = hsc_dflags hsc_env- home_unit = mkHomeUnitFromFlags dflags+ home_unit = hsc_home_unit hsc_env platform = targetPlatform dflags- cmm <- ioMsgMaybe $ parseCmmFile dflags filename+ cmm <- ioMsgMaybe+ $ do+ (warns,errs,cmm) <- withTiming dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ())+ $ parseCmmFile dflags filename+ return ((fmap pprWarning warns, fmap pprError errs), cmm) liftIO $ do dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm) let -- Make up a module name to give the NCG. We can't pass bottom here@@ -1626,7 +1671,7 @@ of names; add them to the ClosureEnv. A naked expression returns a singleton Name [it]. The stmt is lifted into the-IO monad as explained in Note [Interactively-bound Ids in GHCi] in GHC.Driver.Types+IO monad as explained in Note [Interactively-bound Ids in GHCi] in GHC.Runtime.Context -} -- | Compile a stmt all the way to an HValue, but don't run it@@ -1768,7 +1813,7 @@ -- We only need to keep around the external bindings -- (as decided by GHC.Iface.Tidy), since those are the only ones -- that might later be looked up by name. But we can exclude- -- - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in GHC.Driver.Types+ -- - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in GHC.Runtime.Context -- - Implicit Ids, which are implicit in tcs -- c.f. GHC.Tc.Module.runTcInteractive, which reconstructs the TypeEnv @@ -1877,11 +1922,10 @@ loc = mkRealSrcLoc (fsLit source) linenumber 1 case unP parser (initParserState (initParserOpts dflags) buf loc) of- PFailed pst -> do- handleWarningsThrowErrors (getMessages pst dflags)-+ PFailed pst ->+ handleWarningsThrowErrors (getMessages pst) POk pst thing -> do- logWarningsReportErrors (getMessages pst dflags)+ logWarningsReportErrors (getMessages pst) liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" FormatHaskell (ppr thing) liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST"@@ -1918,9 +1962,7 @@ (icInteractiveModule (hsc_IC hsc_env)) prepd_expr {- link it -}- ; hval <- linkExpr hsc_env srcspan bcos-- ; return hval }+ ; linkExpr hsc_env srcspan bcos } {- **********************************************************************
compiler/GHC/Driver/Make.hs view
@@ -35,44 +35,63 @@ import GHC.Prelude +import GHC.Tc.Utils.Backpack+ import qualified GHC.Runtime.Linker as Linker+import GHC.Runtime.Linker.Types+import GHC.Runtime.Context +import GHC.Driver.Config import GHC.Driver.Phases import GHC.Driver.Pipeline import GHC.Driver.Session import GHC.Driver.Backend-import GHC.Utils.Error-import GHC.Driver.Finder import GHC.Driver.Monad+import GHC.Driver.Env+import GHC.Driver.Main+ import GHC.Parser.Header-import GHC.Driver.Types-import GHC.Unit-import GHC.Unit.State+import GHC.Parser.Errors.Ppr++import GHC.Utils.Error import GHC.IfaceToCore ( typecheckIface ) import GHC.Tc.Utils.Monad ( initIfaceCheck )-import GHC.Driver.Main import GHC.Data.Bag ( unitBag, listToBag, unionManyBags, isEmptyBag )-import GHC.Types.Basic import GHC.Data.Graph.Directed-import GHC.Utils.Exception ( tryIO ) import GHC.Data.FastString import GHC.Data.Maybe ( expectJust )-import GHC.Types.Name+import GHC.Data.StringBuffer+import qualified GHC.LanguageExtensions as LangExt+import GHC.SysTools.FileCleanup++import GHC.Utils.Exception ( tryIO ) import GHC.Utils.Monad ( allM ) import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Misc++import GHC.Types.Basic+import GHC.Types.Target+import GHC.Types.SourceFile+import GHC.Types.SourceError import GHC.Types.SrcLoc-import GHC.Data.StringBuffer import GHC.Types.Unique.FM import GHC.Types.Unique.DSet-import GHC.Tc.Utils.Backpack import GHC.Types.Unique.Set-import GHC.Utils.Misc-import qualified GHC.LanguageExtensions as LangExt+import GHC.Types.Name import GHC.Types.Name.Env-import GHC.SysTools.FileCleanup +import GHC.Unit+import GHC.Unit.External+import GHC.Unit.State+import GHC.Unit.Finder+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.Graph+import GHC.Unit.Home.ModInfo+ import Data.Either ( rights, partitionEithers ) import qualified Data.Map as Map import Data.Map (Map)@@ -94,6 +113,7 @@ import Data.Maybe import Data.Ord ( comparing ) import Data.Time+import Data.Bifunctor (first) import System.Directory import System.FilePath import System.IO ( fixIO )@@ -658,7 +678,7 @@ | nameIsFromExternalPackage home_unit old_name = old_name | otherwise = ic_name empty_ic where- home_unit = mkHomeUnitFromFlags dflags+ home_unit = hsc_home_unit hsc_env old_name = ic_name old_ic -- | If there is no -o option, guess the name of target executable@@ -1075,7 +1095,8 @@ -- work to compile the module (see parUpsweep_one). m_res <- MC.try $ unmask $ prettyPrintGhcErrors lcl_dflags $ parUpsweep_one mod home_mod_map comp_graph_loops- lcl_dflags mHscMessage cleanup+ lcl_dflags (hsc_home_unit hsc_env)+ mHscMessage cleanup par_sem hsc_env_var old_hpt_var stable_mods mod_idx (length sccs) @@ -1147,7 +1168,7 @@ -- The log_action callback that is used to synchronize messages from a -- worker thread. parLogAction :: LogQueue -> LogAction- parLogAction log_queue _dflags !reason !severity !srcSpan !msg = do+ parLogAction log_queue _dflags !reason !severity !srcSpan !msg = writeLogQueue log_queue (Just (reason,severity,srcSpan,msg)) -- Print each message from the log_queue using the log_action from the@@ -1177,6 +1198,8 @@ -- ^ The list of all module loops within the compilation graph. -> DynFlags -- ^ The thread-local DynFlags+ -> HomeUnit+ -- ^ The home-unit -> Maybe Messager -- ^ The messager -> (HscEnv -> IO ())@@ -1195,14 +1218,13 @@ -- ^ The total number of modules -> IO SuccessFlag -- ^ The result of this compile-parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags mHscMessage cleanup par_sem+parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags home_unit mHscMessage cleanup par_sem hsc_env_var old_hpt_var stable_mods mod_index num_mods = do let this_build_mod = mkBuildModule mod let home_imps = map unLoc $ ms_home_imps mod let home_src_imps = map unLoc $ ms_home_srcimps mod- let home_unit = mkHomeUnitFromFlags lcl_dflags -- All the textual imports of this module. let textual_deps = Set.fromList $@@ -2114,8 +2136,9 @@ -- otherwise those modules will fail to compile. -- See Note [-fno-code mode] #8025 let default_backend = platformDefaultBackend (targetPlatform dflags)+ home_unit = hsc_home_unit hsc_env map1 <- case backend dflags of- NoBackend -> enableCodeGenForTH default_backend map0+ NoBackend -> enableCodeGenForTH home_unit default_backend map0 Interpreter -> enableCodeGenForUnboxedTuplesOrSums default_backend map0 _ -> return map0 if null errs@@ -2200,10 +2223,10 @@ -- the specified target, disable optimization and change the .hi -- and .o file locations to be temporary files. -- See Note [-fno-code mode]-enableCodeGenForTH :: Backend+enableCodeGenForTH :: HomeUnit -> Backend -> NodeMap [Either ErrorMessages ModSummary] -> IO (NodeMap [Either ErrorMessages ModSummary])-enableCodeGenForTH =+enableCodeGenForTH home_unit = enableCodeGenWhen condition should_modify TFL_CurrentModule TFL_GhcSession where condition = isTemplateHaskellOrQQNonBoot@@ -2211,7 +2234,7 @@ backend dflags == NoBackend && -- Don't enable codegen for TH on indefinite packages; we -- can't compile anything anyway! See #16219.- isHomeUnitDefinite (mkHomeUnitFromFlags dflags)+ isHomeUnitDefinite home_unit -- | Update the every ModSummary that is depended on -- by a module that needs unboxed tuples. We enable codegen to@@ -2500,7 +2523,7 @@ | otherwise = find_it where dflags = hsc_dflags hsc_env- home_unit = mkHomeUnitFromFlags dflags+ home_unit = hsc_home_unit hsc_env check_timestamp old_summary location src_fn = checkSummaryTimestamp@@ -2669,7 +2692,11 @@ <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn (pi_srcimps, pi_theimps, L pi_mod_name_loc pi_mod_name)- <- ExceptT $ getImports pi_local_dflags pi_hspp_buf pi_hspp_fn src_fn+ <- ExceptT $ do+ let imp_prelude = xopt LangExt.ImplicitPrelude pi_local_dflags+ popts = initParserOpts pi_local_dflags+ mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn+ return (first (fmap pprError) mimps) return PreprocessedImports {..}
compiler/GHC/Driver/MakeFile.hs view
@@ -22,17 +22,21 @@ import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Utils.Misc-import GHC.Driver.Types+import GHC.Driver.Env import qualified GHC.SysTools as SysTools-import GHC.Unit.Module import GHC.Data.Graph.Directed ( SCC(..) )-import GHC.Driver.Finder import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Types.SourceError import GHC.Types.SrcLoc import Data.List import GHC.Data.FastString import GHC.SysTools.FileCleanup++import GHC.Unit.Module+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.Graph+import GHC.Unit.Finder import GHC.Utils.Exception import GHC.Utils.Error
compiler/GHC/Driver/Pipeline.hs view
@@ -1,4 +1,8 @@-{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns, MultiWayIf #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -39,44 +43,67 @@ import GHC.Prelude +import GHC.Platform++import GHC.Tc.Types++import GHC.Driver.Main+import GHC.Driver.Env hiding ( Hsc ) import GHC.Driver.Pipeline.Monad-import GHC.Unit-import GHC.Unit.State+import GHC.Driver.Config+import GHC.Driver.Phases+import GHC.Driver.Session+import GHC.Driver.Backend+import GHC.Driver.Ppr+import GHC.Driver.Hooks+ import GHC.Platform.Ways import GHC.Platform.ArchOS+ import GHC.Parser.Header-import GHC.Driver.Phases+import GHC.Parser.Errors.Ppr+ import GHC.SysTools import GHC.SysTools.ExtraObj-import GHC.Driver.Main-import GHC.Driver.Finder-import GHC.Driver.Types hiding ( Hsc )+import GHC.SysTools.FileCleanup+import GHC.SysTools.Ar+ import GHC.Utils.Outputable import GHC.Utils.Error-import GHC.Driver.Session-import GHC.Driver.Backend-import GHC.Driver.Ppr import GHC.Utils.Panic import GHC.Utils.Misc-import GHC.Data.StringBuffer ( hGetStringBuffer, hPutStringBuffer )-import GHC.Types.Basic ( SuccessFlag(..) )-import GHC.Data.Maybe ( expectJust )-import GHC.Types.SrcLoc-import GHC.CmmToLlvm ( llvmFixupAsm, llvmVersionList ) import GHC.Utils.Monad-import GHC.Platform-import GHC.Tc.Types-import GHC.Driver.Hooks+import GHC.Utils.Exception as Exception++import GHC.CmmToLlvm ( llvmFixupAsm, llvmVersionList ) import qualified GHC.LanguageExtensions as LangExt-import GHC.SysTools.FileCleanup-import GHC.SysTools.Ar import GHC.Settings-import GHC.Data.Bag ( unitBag )-import GHC.Data.FastString ( mkFastString )-import GHC.Iface.Make ( mkFullIface )-import GHC.Iface.UpdateIdInfos ( updateModDetailsIdInfos )+import GHC.Runtime.Linker.Types -import GHC.Utils.Exception as Exception+import GHC.Data.Bag ( unitBag )+import GHC.Data.FastString ( mkFastString )+import GHC.Data.StringBuffer ( hGetStringBuffer, hPutStringBuffer )+import GHC.Data.Maybe ( expectJust )++import GHC.Iface.Make ( mkFullIface )+import GHC.Iface.UpdateIdInfos ( updateModDetailsIdInfos )++import GHC.Types.Basic ( SuccessFlag(..) )+import GHC.Types.Target+import GHC.Types.SrcLoc+import GHC.Types.SourceFile+import GHC.Types.SourceError++import GHC.Unit+import GHC.Unit.State+import GHC.Unit.Finder+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.Graph (needsTemplateHaskellOrQQ)+import GHC.Unit.Module.Deps+import GHC.Unit.Home.ModInfo+ import System.Directory import System.FilePath import System.IO@@ -199,7 +226,7 @@ in return $! HomeModInfo iface hmi_details mb_linkable (HscNotGeneratingCode _ _, _) -> panic "compileOne HscNotGeneratingCode" (_, NoBackend) -> panic "compileOne NoBackend"- (HscUpdateBoot iface hmi_details, Interpreter) -> do+ (HscUpdateBoot iface hmi_details, Interpreter) -> return $! HomeModInfo iface hmi_details Nothing (HscUpdateBoot iface hmi_details, _) -> do touchObjectFile dflags object_filename@@ -314,8 +341,19 @@ current_dir = takeDirectory basename old_paths = includePaths dflags2 !prevailing_dflags = hsc_dflags hsc_env0+ -- Figure out which backend we're using+ (bcknd, dflags3)+ -- #8042: When module was loaded with `*` prefix in ghci, but DynFlags+ -- suggest to generate object code (which may happen in case -fobject-code+ -- was set), force it to generate byte-code. This is NOT transitive and+ -- only applies to direct targets.+ | Just (Target _ obj _) <- findTarget summary (hsc_targets hsc_env0)+ , not obj+ = (Interpreter, dflags2 { backend = Interpreter })+ | otherwise+ = (backend dflags, dflags2) dflags =- dflags2 { includePaths = addQuoteInclude old_paths [current_dir]+ dflags3 { includePaths = addQuoteInclude old_paths [current_dir] , log_action = log_action prevailing_dflags } -- use the prevailing log_action / log_finaliser, -- not the one cached in the summary. This is so@@ -323,9 +361,6 @@ -- to re-summarize all the source files. hsc_env = hsc_env0 {hsc_dflags = dflags} - -- Figure out which backend we're using- bcknd = backend dflags- -- -fforce-recomp should also work with --make force_recomp = gopt Opt_ForceRecomp dflags source_modified@@ -382,7 +417,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 home_unit = mkHomeUnitFromFlags dflags+ let home_unit = hsc_home_unit hsc_env src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;" writeFile empty_stub (showSDoc dflags (pprCode CStyle src)) _ <- runPipeline StopLn hsc_env@@ -584,7 +619,7 @@ findHSLib dflags dirs lib = do let batch_lib_file = if WayDyn `notElem` ways dflags then "lib" ++ lib <.> "a"- else mkSOName (targetPlatform dflags) lib+ else platformSOName (targetPlatform dflags) lib found <- filterM doesFileExist (map (</> batch_lib_file) dirs) case found of [] -> return Nothing@@ -742,7 +777,7 @@ -- path, then rerun the pipeline for the dyn way let dflags = hsc_dflags hsc_env -- NB: Currently disabled on Windows (ref #7134, #8228, and #5987)- when (not $ platformOS (targetPlatform dflags) == OSMinGW32) $ do+ when (not $ platformOS (targetPlatform dflags) == OSMinGW32) $ when isHaskellishFile $ whenCannotGenerateDynamicToo dflags $ do debugTraceMsg dflags 4 (text "Running the pipeline again for -dynamic-too")@@ -1063,31 +1098,30 @@ -- HsPp phase runPhase (RealPhase (HsPp sf)) input_fn dflags- = do- if not (gopt Opt_Pp dflags) then- -- no need to preprocess, just pass input file along- -- to the next phase of the pipeline.- return (RealPhase (Hsc sf), input_fn)- else do- PipeEnv{src_basename, src_suffix} <- getPipeEnv- let orig_fn = src_basename <.> src_suffix- output_fn <- phaseOutputFilename (Hsc sf)- liftIO $ GHC.SysTools.runPp dflags- ( [ GHC.SysTools.Option orig_fn- , GHC.SysTools.Option input_fn- , GHC.SysTools.FileOption "" output_fn- ]- )+ = if not (gopt Opt_Pp dflags) then+ -- no need to preprocess, just pass input file along+ -- to the next phase of the pipeline.+ return (RealPhase (Hsc sf), input_fn)+ else do+ PipeEnv{src_basename, src_suffix} <- getPipeEnv+ let orig_fn = src_basename <.> src_suffix+ output_fn <- phaseOutputFilename (Hsc sf)+ liftIO $ GHC.SysTools.runPp dflags+ ( [ GHC.SysTools.Option orig_fn+ , GHC.SysTools.Option input_fn+ , GHC.SysTools.FileOption "" output_fn+ ]+ ) - -- re-read pragmas now that we've parsed the file (see #3674)- src_opts <- liftIO $ getOptionsFromFile dflags output_fn- (dflags1, unhandled_flags, warns)- <- liftIO $ parseDynamicFilePragma dflags src_opts- setDynFlags dflags1- liftIO $ checkProcessArgsResult dflags1 unhandled_flags- liftIO $ handleFlagWarnings dflags1 warns+ -- re-read pragmas now that we've parsed the file (see #3674)+ src_opts <- liftIO $ getOptionsFromFile dflags output_fn+ (dflags1, unhandled_flags, warns)+ <- liftIO $ parseDynamicFilePragma dflags src_opts+ setDynFlags dflags1+ liftIO $ checkProcessArgsResult dflags1 unhandled_flags+ liftIO $ handleFlagWarnings dflags1 warns - return (RealPhase (Hsc sf), output_fn)+ return (RealPhase (Hsc sf), output_fn) ----------------------------------------------------------------------------- -- Hsc phase@@ -1113,11 +1147,12 @@ -- gather the imports and module name (hspp_buf,mod_name,imps,src_imps) <- liftIO $ do- do buf <- hGetStringBuffer input_fn- eimps <- getImports dflags buf input_fn (basename <.> suff)+ let imp_prelude = xopt LangExt.ImplicitPrelude dflags+ popts = initParserOpts dflags+ eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff) case eimps of- Left errs -> throwErrors errs+ Left errs -> throwErrors (fmap pprError errs) Right (src_imps,imps,L _ mod_name) -> return (Just buf, mod_name, imps, src_imps) @@ -1293,7 +1328,7 @@ pkg_include_dirs <- liftIO $ getUnitIncludePath (initSDocContext dflags defaultUserStyle) (unitState dflags)- (mkHomeUnitFromFlags dflags)+ home_unit pkgs let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)@@ -1325,7 +1360,7 @@ else getUnitExtraCcOpts (initSDocContext dflags defaultUserStyle) (unitState dflags)- (mkHomeUnitFromFlags dflags)+ home_unit pkgs framework_paths <-@@ -1333,7 +1368,7 @@ then do pkgFrameworkPaths <- liftIO $ getUnitFrameworkPath (initSDocContext dflags defaultUserStyle) (unitState dflags)- (mkHomeUnitFromFlags dflags)+ home_unit pkgs let cmdlineFrameworkPaths = frameworkPaths dflags return $ map ("-F"++)@@ -1445,8 +1480,8 @@ let local_includes = [ GHC.SysTools.Option ("-iquote" ++ p) | p <- includePathsQuote cmdline_include_paths ] let runAssembler inputFilename outputFilename- = liftIO $ do- withAtomicRename outputFilename $ \temp_outputFilename -> do+ = liftIO $+ withAtomicRename outputFilename $ \temp_outputFilename -> as_prog dflags (local_includes ++ global_includes@@ -1728,6 +1763,7 @@ toolSettings' = toolSettings dflags verbFlags = getVerbFlags dflags output_fn = exeFileName staticLink dflags+ home_unit = mkHomeUnitFromFlags dflags -- get the full list of packages to link with, by combining the -- explicit packages with the auto packages and all of their@@ -1740,7 +1776,7 @@ pkg_lib_paths <- getUnitLibraryPath (initSDocContext dflags defaultUserStyle) (unitState dflags)- (mkHomeUnitFromFlags dflags)+ home_unit (ways dflags) dep_units let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths@@ -1994,15 +2030,13 @@ linkDynLibCheck :: DynFlags -> [String] -> [UnitId] -> IO ()-linkDynLibCheck dflags o_files dep_units- = do- when (haveRtsOptsFlags dflags) $ do- putLogMsg dflags NoReason SevInfo noSrcSpan- $ withPprStyle defaultUserStyle- (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$- text " Call hs_init_ghc() from your main() function to set these options.")-- linkDynLib dflags o_files dep_units+linkDynLibCheck dflags o_files dep_units = do+ when (haveRtsOptsFlags dflags) $+ putLogMsg dflags NoReason SevInfo noSrcSpan+ $ withPprStyle defaultUserStyle+ (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$+ text " Call hs_init_ghc() from your main() function to set these options.")+ 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@@ -2012,6 +2046,7 @@ let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ] modules = o_files ++ extra_ld_inputs output_fn = exeFileName True dflags+ home_unit = mkHomeUnitFromFlags dflags full_output_fn <- if isAbsolute output_fn then return output_fn@@ -2023,7 +2058,7 @@ pkg_cfgs_init <- getPreloadUnitsAnd (initSDocContext dflags defaultUserStyle) (unitState dflags)- (mkHomeUnitFromFlags dflags)+ home_unit dep_units let pkg_cfgs@@ -2052,11 +2087,12 @@ doCpp dflags raw input_fn output_fn = do let hscpp_opts = picPOpts dflags let cmdline_include_paths = includePaths dflags+ let home_unit = mkHomeUnitFromFlags dflags pkg_include_dirs <- getUnitIncludePath (initSDocContext dflags defaultUserStyle) (unitState dflags)- (mkHomeUnitFromFlags dflags)+ home_unit [] let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)@@ -2277,7 +2313,7 @@ writeFile filelist $ unlines o_files ld_r [GHC.SysTools.Option "-filelist", GHC.SysTools.FileOption "" filelist]- else do+ else ld_r (map (GHC.SysTools.FileOption "") o_files) -- -----------------------------------------------------------------------------
compiler/GHC/Hs/Stats.hs view
@@ -1,12 +1,11 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+ -- | -- Statistics for per-module compilations -- -- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 ----{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-} module GHC.Hs.Stats ( ppSourceStats ) where
compiler/GHC/HsToCore.hs view
@@ -1,3 +1,8 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -6,11 +11,6 @@ The Desugarer: turning HsSyn into Core. -} -{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- module GHC.HsToCore ( -- * Desugaring operations deSugar, deSugarExpr@@ -20,56 +20,72 @@ import GHC.Prelude -import GHC.HsToCore.Usage import GHC.Driver.Session import GHC.Driver.Config-import GHC.Driver.Types+import GHC.Driver.Env import GHC.Driver.Backend+ import GHC.Hs++import GHC.HsToCore.Usage+import GHC.HsToCore.Monad+import GHC.HsToCore.Expr+import GHC.HsToCore.Binds+import GHC.HsToCore.Foreign.Decl+import GHC.HsToCore.Coverage+import GHC.HsToCore.Docs+ import GHC.Tc.Types import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances ) import GHC.Tc.Module ( runTcInteractive )-import GHC.Types.Id-import GHC.Types.Id.Info-import GHC.Types.Name+ import GHC.Core.Type import GHC.Core.TyCon ( tyConDataCons )-import GHC.Types.Avail import GHC.Core import GHC.Core.FVs ( exprsSomeFreeVarsList ) import GHC.Core.SimpleOpt ( simpleOptPgm, simpleOptExpr ) import GHC.Core.Utils import GHC.Core.Unfold.Make import GHC.Core.Ppr-import GHC.HsToCore.Monad-import GHC.HsToCore.Expr-import GHC.HsToCore.Binds-import GHC.HsToCore.Foreign.Decl-import GHC.Builtin.Names-import GHC.Builtin.Types.Prim import GHC.Core.Coercion-import GHC.Builtin.Types import GHC.Core.DataCon ( dataConWrapId ) import GHC.Core.Make-import GHC.Unit-import GHC.Types.Name.Set-import GHC.Types.Name.Env import GHC.Core.Rules-import GHC.Types.Basic import GHC.Core.Opt.Monad ( CoreToDo(..) ) import GHC.Core.Lint ( endPassIO )-import GHC.Types.Var.Set++import GHC.Builtin.Names+import GHC.Builtin.Types.Prim+import GHC.Builtin.Types+ import GHC.Data.FastString+import GHC.Data.OrdList+ import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Types.SrcLoc-import GHC.HsToCore.Coverage import GHC.Utils.Misc import GHC.Utils.Monad-import GHC.Data.OrdList-import GHC.HsToCore.Docs +import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.ForeignStubs+import GHC.Types.Avail+import GHC.Types.Basic+import GHC.Types.Var.Set+import GHC.Types.SrcLoc+import GHC.Types.SourceFile+import GHC.Types.TypeEnv+import GHC.Types.Name+import GHC.Types.Name.Set+import GHC.Types.Name.Env+import GHC.Types.Name.Ppr+import GHC.Types.HpcInfo++import GHC.Unit+import GHC.Unit.Module.ModGuts+import GHC.Unit.Module.ModIface+ import Data.List import Data.IORef import Control.Monad( when )@@ -120,7 +136,7 @@ }) = do { let dflags = hsc_dflags hsc_env- home_unit = mkHomeUnitFromFlags dflags+ home_unit = hsc_home_unit hsc_env print_unqual = mkPrintUnqualified (unitState dflags) home_unit@@ -183,7 +199,7 @@ ; let used_names = mkUsedNames tcg_env pluginModules = map lpModule (cachedPlugins (hsc_dflags hsc_env))- home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)+ home_unit = hsc_home_unit hsc_env ; deps <- mkDependencies (homeUnitId home_unit) (map mi_module pluginModules) tcg_env @@ -751,5 +767,3 @@ id = mkExportedVanillaId unsafeCoercePrimName ty `setIdInfo` info ; return (id, old_expr) }-- where
compiler/GHC/HsToCore/Arrows.hs view
@@ -1,3 +1,8 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -5,12 +10,6 @@ Desugaring arrow commands -}--{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.HsToCore.Arrows ( dsProcExpr ) where
compiler/GHC/HsToCore/Binds.hs view
@@ -1,3 +1,9 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -10,13 +16,6 @@ lower levels it is preserved with @let@/@letrec@s). -} -{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE FlexibleContexts #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- module GHC.HsToCore.Binds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec , dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule@@ -54,9 +53,8 @@ import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.Multiplicity-import GHC.Builtin.Types ( typeNatKind, typeSymbolKind )+import GHC.Builtin.Types ( naturalTy, typeSymbolKind ) import GHC.Types.Id-import GHC.Types.Id.Make(proxyHashId) import GHC.Types.Name import GHC.Types.Var.Set import GHC.Core.Rules@@ -385,10 +383,10 @@ | otherwise = case inlinePragmaSpec inline_prag of- NoUserInline -> (gbl_id, rhs)- NoInline -> (gbl_id, rhs)- Inlinable -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)- Inline -> inline_pair+ NoUserInlinePrag -> (gbl_id, rhs)+ NoInline -> (gbl_id, rhs)+ Inlinable -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)+ Inline -> inline_pair where simpl_opts = initSimpleOpts dflags@@ -1220,7 +1218,7 @@ dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr -- Return a CoreExpr :: Typeable ty -- This code is tightly coupled to the representation--- of TypeRep, in base library Data.Typeable.Internals+-- of TypeRep, in base library Data.Typeable.Internal dsEvTypeable ty ev = do { tyCl <- dsLookupTyCon typeableClassName -- Typeable ; let kind = typeKind ty@@ -1299,15 +1297,14 @@ = -- See Note [Typeable for Nat and Symbol] in GHC.Tc.Solver.Interact do { fun <- dsLookupGlobalId tr_fun ; dict <- dsEvTerm ev -- Of type KnownNat/KnownSymbol- ; let proxy = mkTyApps (Var proxyHashId) [ty_kind, ty]- ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict, proxy ]) }+ ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict ]) } where ty_kind = typeKind ty -- tr_fun is the Name of- -- typeNatTypeRep :: KnownNat a => Proxy# a -> TypeRep a- -- of typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep a- tr_fun | ty_kind `eqType` typeNatKind = typeNatTypeRepName+ -- typeNatTypeRep :: KnownNat a => TypeRep a+ -- of typeSymbolTypeRep :: KnownSymbol a => TypeRep a+ tr_fun | ty_kind `eqType` naturalTy = typeNatTypeRepName | ty_kind `eqType` typeSymbolKind = typeSymbolTypeRepName | otherwise = panic "dsEvTypeable: unknown type lit kind"
compiler/GHC/HsToCore/Coverage.hs view
@@ -1,54 +1,59 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ {- (c) Galois, 2006 (c) University of Glasgow, 2007 -} -{-# LANGUAGE NondecreasingIndentation, RecordWildCards #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DeriveFunctor #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- module GHC.HsToCore.Coverage (addTicksToBinds, hpcInitCode) where import GHC.Prelude as Prelude +import GHC.Driver.Session+import GHC.Driver.Backend+import GHC.Driver.Ppr+import GHC.Driver.Env+ import qualified GHC.Runtime.Interpreter as GHCi import GHCi.RemoteTypes-import Data.Array import GHC.ByteCode.Types import GHC.Stack.CCS-import GHC.Core.Type import GHC.Hs import GHC.Unit+import GHC.Cmm.CLabel++import GHC.Core.Type+import GHC.Core.ConLike+import GHC.Core+import GHC.Core.TyCon++import GHC.Data.Maybe+import GHC.Data.FastString+import GHC.Data.Bag++import GHC.Utils.Misc+import GHC.Utils.Error import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic-import GHC.Driver.Session-import GHC.Driver.Backend-import GHC.Driver.Ppr-import GHC.Core.ConLike-import Control.Monad+import GHC.Utils.Monad+ import GHC.Types.SrcLoc-import GHC.Utils.Error+import GHC.Types.Basic+import GHC.Types.Id+import GHC.Types.Var.Set import GHC.Types.Name.Set hiding (FreeVars) import GHC.Types.Name-import GHC.Data.Bag+import GHC.Types.HpcInfo import GHC.Types.CostCentre import GHC.Types.CostCentre.State-import GHC.Core-import GHC.Types.Id-import GHC.Types.Var.Set-import Data.List-import GHC.Data.FastString-import GHC.Driver.Types-import GHC.Core.TyCon-import GHC.Types.Basic-import GHC.Utils.Monad-import GHC.Data.Maybe-import GHC.Cmm.CLabel-import GHC.Utils.Misc +import Control.Monad+import Data.List+import Data.Array import Data.Time import System.Directory @@ -158,7 +163,7 @@ mkCCSArray :: HscEnv -> Module -> Int -> [MixEntry_] -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre))-mkCCSArray hsc_env modul count entries = do+mkCCSArray hsc_env modul count entries = case hsc_interp hsc_env of Just interp | GHCi.interpreterProfiled interp -> do let module_str = moduleNameString (moduleName modul)@@ -193,7 +198,7 @@ modTime <- getModificationUTCTime filename let entries' = [ (hpcPos, box) | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ]- when (entries' `lengthIsNot` count) $ do+ when (entries' `lengthIsNot` count) $ panic "the number of .mix entries are inconsistent" let hashNo = mixHash filename modTime tabStop entries' mixCreate hpc_mod_dir mod_name@@ -263,12 +268,12 @@ addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc) addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds,- abs_exports = abs_exports })) = do- withEnv add_exports $ do- withEnv add_inlines $ do- binds' <- addTickLHsBinds binds- return $ L pos $ bind { abs_binds = binds' }- where+ abs_exports = abs_exports })) =+ withEnv add_exports $+ withEnv add_inlines $ do+ binds' <- addTickLHsBinds binds+ return $ L pos $ bind { abs_binds = binds' }+ where -- in AbsBinds, the Id on each binding is not the actual top-level -- Id that we are defining, they are related by the abs_exports -- field of AbsBinds. So if we're doing TickExportedFunctions we need@@ -663,7 +668,7 @@ addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc) -> TM (GRHSs GhcTc (LHsExpr GhcTc))-addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (L l local_binds)) = do+addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (L l local_binds)) = bindLocals binders $ do local_binds' <- addTickHsLocalBinds local_binds guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded@@ -706,12 +711,12 @@ addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc) -> TM (Stmt GhcTc (LHsExpr GhcTc))-addTickStmt _isGuard (LastStmt x e noret ret) = do+addTickStmt _isGuard (LastStmt x e noret ret) = liftM3 (LastStmt x) (addTickLHsExpr e) (pure noret) (addTickSyntaxExpr hpcSrcSpan ret)-addTickStmt _isGuard (BindStmt xbs pat e) = do+addTickStmt _isGuard (BindStmt xbs pat e) = liftM4 (\b f -> BindStmt $ XBindStmtTc { xbstc_bindOp = b , xbstc_boundResultType = xbstc_boundResultType xbs@@ -722,15 +727,15 @@ (mapM (addTickSyntaxExpr hpcSrcSpan) (xbstc_failOp xbs)) (addTickLPat pat) (addTickLHsExprRHS e)-addTickStmt isGuard (BodyStmt x e bind' guard') = do+addTickStmt isGuard (BodyStmt x e bind' guard') = liftM3 (BodyStmt x) (addTick isGuard e) (addTickSyntaxExpr hpcSrcSpan bind') (addTickSyntaxExpr hpcSrcSpan guard')-addTickStmt _isGuard (LetStmt x (L l binds)) = do+addTickStmt _isGuard (LetStmt x (L l binds)) = liftM (LetStmt x . L l) (addTickHsLocalBinds binds)-addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) = do+addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) = liftM3 (ParStmt x) (mapM (addTickStmtAndBinders isGuard) pairs) (unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr))@@ -915,7 +920,7 @@ return $ match { m_grhss = gRHSs' } addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))-addTickCmdGRHSs (GRHSs x guarded (L l local_binds)) = do+addTickCmdGRHSs (GRHSs x guarded (L l local_binds)) = bindLocals binders $ do local_binds' <- addTickHsLocalBinds local_binds guarded' <- mapM (liftL addTickCmdGRHS) guarded@@ -948,21 +953,21 @@ binders = collectLStmtsBinders lstmts addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc))-addTickCmdStmt (BindStmt x pat c) = do+addTickCmdStmt (BindStmt x pat c) = liftM2 (BindStmt x) (addTickLPat pat) (addTickLHsCmd c)-addTickCmdStmt (LastStmt x c noret ret) = do+addTickCmdStmt (LastStmt x c noret ret) = liftM3 (LastStmt x) (addTickLHsCmd c) (pure noret) (addTickSyntaxExpr hpcSrcSpan ret)-addTickCmdStmt (BodyStmt x c bind' guard') = do+addTickCmdStmt (BodyStmt x c bind' guard') = liftM3 (BodyStmt x) (addTickLHsCmd c) (addTickSyntaxExpr hpcSrcSpan bind') (addTickSyntaxExpr hpcSrcSpan guard')-addTickCmdStmt (LetStmt x (L l binds)) = do+addTickCmdStmt (LetStmt x (L l binds)) = liftM (LetStmt x . L l) (addTickHsLocalBinds binds) addTickCmdStmt stmt@(RecStmt {})
compiler/GHC/HsToCore/Docs.hs view
@@ -189,7 +189,7 @@ , conArgDocs c) | c <- cons, cname <- getConNames c ] fields = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty)- | RecCon flds <- map getConArgs cons+ | Just flds <- map getRecConArgs_maybe cons , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds) , (L _ n) <- ns ] derivs = [ (instName, [unLoc doc], M.empty)@@ -216,22 +216,30 @@ _ -> Nothing -- | 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 . 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+conArgDocs :: ConDecl GhcRn -> Map Int HsDocString+conArgDocs (ConDeclH98{con_args = args}) =+ h98ConArgDocs args+conArgDocs (ConDeclGADT{con_g_args = args, con_res_ty = res_ty}) =+ gadtConArgDocs args (unLoc res_ty) - ret = case con of- ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ]- _ -> []+h98ConArgDocs :: HsConDeclH98Details GhcRn -> Map Int HsDocString+h98ConArgDocs con_args = case con_args of+ PrefixCon args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args+ InfixCon arg1 arg2 -> con_arg_docs 0 [ unLoc (hsScaledThing arg1)+ , unLoc (hsScaledThing arg2) ]+ RecCon _ -> M.empty++gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> Map Int HsDocString+gadtConArgDocs con_args res_ty = case con_args of+ PrefixConGADT args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args ++ [res_ty]+ RecConGADT _ -> con_arg_docs 1 [res_ty]++con_arg_docs :: Int -> [HsType GhcRn] -> Map Int HsDocString+con_arg_docs 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 isValD :: HsDecl a -> Bool isValD (ValD _ _) = True
compiler/GHC/HsToCore/Expr.hs view
@@ -1,3 +1,9 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -6,13 +12,6 @@ Desugaring expressions. -} -{-# LANGUAGE CPP, MultiWayIf #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- module GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds , dsValBinds, dsLit, dsSyntaxExpr@@ -32,6 +31,7 @@ import GHC.HsToCore.Arrows import GHC.HsToCore.Monad import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs )+import GHC.Types.SourceText import GHC.Types.Name import GHC.Types.Name.Env import GHC.Core.FamInstEnv( topNormaliseType )@@ -45,6 +45,7 @@ import GHC.Tc.Utils.Monad import GHC.Core.Type import GHC.Core.Multiplicity+import GHC.Core.Coercion( Coercion ) import GHC.Core import GHC.Core.Utils import GHC.Core.Make@@ -53,6 +54,7 @@ import GHC.Types.CostCentre import GHC.Types.Id import GHC.Types.Id.Make+import GHC.Types.Var.Env import GHC.Unit.Module import GHC.Core.ConLike import GHC.Core.DataCon@@ -61,16 +63,16 @@ import GHC.Builtin.Names import GHC.Types.Basic import GHC.Data.Maybe-import GHC.Types.Var.Env import GHC.Types.SrcLoc import GHC.Utils.Misc import GHC.Data.Bag import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Core.PatSyn- import Control.Monad +import qualified GHC.LanguageExtensions as LangExt+ {- ************************************************************************ * *@@ -237,16 +239,18 @@ ************************************************************************ -} -dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr -dsLExpr (L loc e)- = putSrcSpanDs loc $- do { core_expr <- dsExpr e- -- uncomment this check to test the hsExprType function in GHC.Tc.Utils.Zonk- -- ; MASSERT2( exprType core_expr `eqType` hsExprType e- -- , ppr e <+> dcolon <+> ppr (hsExprType e) $$- -- ppr core_expr <+> dcolon <+> ppr (exprType core_expr) )- ; return core_expr }+-- | Replace the body of the fucntion with this block to test the hsExprType+-- function in GHC.Tc.Utils.Zonk:+-- putSrcSpanDs loc $ do+-- { core_expr <- dsExpr e+-- ; MASSERT2( exprType core_expr `eqType` hsExprType e+-- , ppr e <+> dcolon <+> ppr (hsExprType e) $$+-- ppr core_expr <+> dcolon <+> ppr (exprType core_expr) )+-- ; return core_expr }+dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr+dsLExpr (L loc e) =+ putSrcSpanDs loc $ dsExpr e -- | Variant of 'dsLExpr' that ensures that the result is not levity -- polymorphic. This should be used when the resulting expression will@@ -348,8 +352,12 @@ Note [Desugaring operator sections] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-At first it looks as if we can convert+Desugaring left sections with -XPostfixOperators is straightforward: convert+(expr `op`) to (op expr). +Without -XPostfixOperators it's a bit more tricky. At first it looks as if we+can convert+ (expr `op`) naively to@@ -399,11 +407,18 @@ -- See Note [Desugaring operator sections]. -- N.B. this also must handle postfix operator sections due to -XPostfixOperators. dsExpr e@(SectionL _ expr op) = do+ postfix_operators <- xoptM LangExt.PostfixOperators+ if postfix_operators then+ -- Desugar (e !) to ((!) e)+ do { op' <- dsLExpr op+ ; dsWhenNoErrs (dsLExprNoLP expr) $ \expr' ->+ mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr' }+ else do core_op <- dsLExpr op x_core <- dsLExpr expr case splitFunTys (exprType core_op) of -- Binary operator section- (x_ty:y_ty:_, _) -> do+ (x_ty:y_ty:_, _) -> dsWhenNoErrs (newSysLocalsDsNoLP [x_ty, y_ty]) (\[x_id, y_id] ->@@ -412,7 +427,7 @@ core_op [Var x_id, Var y_id])) -- Postfix operator section- (_:_, _) -> do+ (_:_, _) -> return $ mkCoreAppDs (text "sectionl" <+> ppr e) core_op x_core _ -> pprPanic "dsExpr(SectionL)" (ppr e)@@ -449,11 +464,11 @@ -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make dsExpr (ExplicitSum types alt arity expr)- = do { dsWhenNoErrs (dsLExprNoLP expr)- (\core_expr -> mkCoreConApps (sumDataCon alt arity)- (map (Type . getRuntimeRep) types ++- map Type types ++- [core_expr]) ) }+ = dsWhenNoErrs (dsLExprNoLP expr)+ (\core_expr -> mkCoreConApps (sumDataCon alt arity)+ (map (Type . getRuntimeRep) types +++ map Type types +++ [core_expr]) ) dsExpr (HsPragE _ prag expr) = ds_prag_expr prag expr@@ -618,14 +633,71 @@ ~~~~~~~~~~~~~~~~~~~~~~~ Consider data T a b where- T1 :: { f1 :: a } -> T a Int+ MkT :: { foo :: a } -> T a Int -Then the wrapper function for T1 has type- $WT1 :: a -> T a Int-But if x::T a b, then- x { f1 = v } :: T a b (not T a Int!)-So we need to cast (T a Int) to (T a b). Sigh.+ upd :: T s t -> s -> T s t+ upd z y = z { foo = y} +We need to get this:+ $WMkT :: a -> T a Int+ MkT :: (b ~# Int) => a -> T a b++ upd = /\s t. \(z::T s t) (y::s) ->+ case z of+ MkT (co :: t ~# Int) _ -> $WMkT @s y |> T (Refl s) (Sym co)++Note the final cast+ T (Refl s) (Sym co) :: T s Int ~ T s t+which uses co, bound by the GADT match. This is the wrap_co coercion+in wrapped_rhs. How do we produce it?++* Start with raw materials+ tc, the tycon: T+ univ_tvs, the universally quantified tyvars of MkT: a,b+ NB: these are in 1-1 correspondence with the tyvars of tc++* Form univ_cos, a coercion for each of tc's args: (Refl s) (Sym co)+ We replaced+ a by (Refl s) since 's' instantiates 'a'+ b by (Sym co) since 'b' is in the data-con's EqSpec++* Then form the coercion T (Refl s) (Sym co)++It gets more complicated when data families are involved (#18809).+Consider+ data family F x+ data instance F (a,b) where+ MkF :: { foo :: Int } -> F (Int,b)++ bar :: F (s,t) -> Int -> F (s,t)+ bar z y = z { foo = y}++We have+ data R:FPair a b where+ MkF :: { foo :: Int } -> R:FPair Int b++ $WMkF :: Int -> F (Int,b)+ MkF :: forall a b. (a ~# Int) => Int -> R:FPair a b++ bar :: F (s,t) -> Int -> F (s,t)+ bar = /\s t. \(z::F (s,t)) \(y::Int) ->+ case z |> co1 of+ MkF (co2::s ~# Int) _ -> $WMkF @t y |> co3++(Side note: here (z |> co1) is built by typechecking the scrutinee, so+we ignore it here. In general the scrutinee is an aribtrary expression.)++The question is: what is co3, the cast for the RHS?+ co3 :: F (Int,t) ~ F (s,t)+Again, we can construct it using co2, bound by the GADT match.+We do /exactly/ the same as the non-family case up to building+univ_cos. But that gives us+ rep_tc: R:FPair+ univ_cos: (Sym co2) (Refl t)+But then we use mkTcFamilyTyConAppCo to "lift" this to the coercion+we want, namely+ F (Sym co2, Refl t) :: F (Int,t) ~ F (s,t)+ -} dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields@@ -711,8 +783,7 @@ dict_req_wrap <.> mkWpTyApps [ lookupTyVar out_subst tv `orElse` mkTyVarTy tv- | tv <- user_tvs- , not (tv `elemVarEnv` wrap_subst) ]+ | tv <- user_tvs ] -- Be sure to use user_tvs (which may be ordered -- differently than `univ_tvs ++ ex_tvs) above. -- See Note [DataCon user type variable binders]@@ -723,27 +794,30 @@ -- Note [Update for GADTs] wrapped_rhs = case con of- RealDataCon data_con ->- let- wrap_co =- mkTcTyConAppCo Nominal- (dataConTyCon data_con)- [ lookup tv ty- | (tv,ty) <- univ_tvs `zip` out_inst_tys ]- lookup univ_tv ty =- case lookupVarEnv wrap_subst univ_tv of- Just co' -> co'- Nothing -> mkTcReflCo Nominal ty- in if null eq_spec- then rhs- else mkLHsWrap (mkWpCastN wrap_co) rhs+ RealDataCon data_con+ | null eq_spec -> rhs+ | otherwise -> mkLHsWrap (mkWpCastN wrap_co) rhs+ -- This wrap is the punchline: Note [Update for GADTs]+ where+ rep_tc = dataConTyCon data_con+ wrap_co = mkTcFamilyTyConAppCo rep_tc univ_cos+ univ_cos = zipWithEqual "dsExpr:upd" mk_univ_co univ_tvs out_inst_tys++ mk_univ_co :: TyVar -- Universal tyvar from the DataCon+ -> Type -- Corresponding instantiating type+ -> Coercion+ mk_univ_co univ_tv inst_ty+ = case lookupVarEnv eq_spec_env univ_tv of+ Just co -> co+ Nothing -> mkTcNomReflCo inst_ty++ eq_spec_env :: VarEnv Coercion+ eq_spec_env = mkVarEnv [ (eqSpecTyVar spec, mkTcSymCo (mkTcCoVarCo eqs_var))+ | (spec,eqs_var) <- zipEqual "dsExpr:upd2" eq_spec eqs_vars ]+ -- eq_spec is always null for a PatSynCon PatSynCon _ -> rhs - wrap_subst =- mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var))- | (spec, eq_var) <- eq_spec `zip` eqs_vars- , let tv = eqSpecTyVar spec ] req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys @@ -1117,12 +1191,12 @@ -- Warn about discarding m a things in 'monadic' binding of the same type, -- but only if we didn't already warn due to Opt_WarnUnusedDoBind when warn_wrong $- do { case tcSplitAppTy_maybe norm_elt_ty of- Just (elt_m_ty, _)- | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty- -> warnDs (Reason Opt_WarnWrongDoBind)- (badMonadBind rhs elt_ty)- _ -> return () } } }+ case tcSplitAppTy_maybe norm_elt_ty of+ Just (elt_m_ty, _)+ | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty+ -> warnDs (Reason Opt_WarnWrongDoBind)+ (badMonadBind rhs elt_ty)+ _ -> return () } } | otherwise -- RHS does have type of form (m ty), which is weird = return () -- but at least this warning is irrelevant
compiler/GHC/HsToCore/Foreign/Call.hs view
@@ -30,6 +30,7 @@ import GHC.HsToCore.Monad import GHC.Core.Utils import GHC.Core.Make+import GHC.Types.SourceText import GHC.Types.Id.Make import GHC.Types.ForeignCall import GHC.Core.DataCon
compiler/GHC/HsToCore/Foreign/Decl.hs view
@@ -1,3 +1,9 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- (c) The University of Glasgow 2006 (c) The AQUA Project, Glasgow University, 1998@@ -6,13 +12,6 @@ Desugaring foreign declarations (see also GHC.HsToCore.Foreign.Call). -} -{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- module GHC.HsToCore.Foreign.Decl ( dsForeigns ) where #include "GhclibHsVersions.h"@@ -30,6 +29,8 @@ import GHC.Core.Unfold.Make import GHC.Types.Id import GHC.Types.Literal+import GHC.Types.ForeignStubs+import GHC.Types.SourceText import GHC.Unit.Module import GHC.Types.Name import GHC.Core.Type@@ -42,7 +43,6 @@ import GHC.Cmm.Expr import GHC.Cmm.Utils-import GHC.Driver.Types import GHC.Driver.Ppr import GHC.Types.ForeignCall import GHC.Builtin.Types@@ -416,7 +416,7 @@ { Capability *cap; cap = rts_lock();- rts_evalIO(&cap,+ rts_inCall(&cap, rts_apply(rts_apply(deRefStablePtr(s), rts_mkBool(b)), rts_mkInt(i))); rts_unlock(cap);@@ -631,7 +631,7 @@ | otherwise = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args - -- the target which will form the root of what we ask rts_evalIO to run+ -- the target which will form the root of what we ask rts_inCall to run the_cfun = case maybe_target of Nothing -> text "(StgClosure*)deRefStablePtr(the_stableptr)"@@ -639,7 +639,7 @@ cap = text "cap" <> comma - -- the expression we give to rts_evalIO+ -- the expression we give to rts_inCall expr_to_run = foldl' appArg the_cfun arg_info -- NOT aug_arg_info where@@ -675,7 +675,7 @@ , declareCResult , text "cap = rts_lock();" -- create the application + perform it.- , text "rts_evalIO" <> parens (+ , text "rts_inCall" <> parens ( char '&' <> cap <> text "rts_apply" <> parens ( cap <>
compiler/GHC/HsToCore/GuardedRHSs.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -5,9 +7,6 @@ Matching guarded right-hand-sides (GRHSs) -}--{-# LANGUAGE CPP #-}-{-# LANGUAGE ViewPatterns #-} module GHC.HsToCore.GuardedRHSs ( dsGuarded, dsGRHSs, isTrueLHsExpr ) where
compiler/GHC/HsToCore/ListComp.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -5,10 +8,6 @@ Desugaring list comprehensions, monad comprehensions and array comprehensions -}--{-# LANGUAGE CPP, NamedFieldPuns #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-} module GHC.HsToCore.ListComp ( dsListComp, dsMonadComp ) where
compiler/GHC/HsToCore/Match.hs view
@@ -1,20 +1,19 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998---The @match@ function--}- {-# LANGUAGE CPP #-} {-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++The @match@ function+-}+ module GHC.HsToCore.Match ( match, matchEquations, matchWrapper, matchSimply , matchSinglePat, matchSinglePatVar@@ -28,7 +27,8 @@ import {-#SOURCE#-} GHC.HsToCore.Expr (dsLExpr, dsSyntaxExpr) -import GHC.Types.Basic ( Origin(..) )+import GHC.Types.Basic ( Origin(..), isGenerated, Boxity(..) )+import GHC.Types.SourceText import GHC.Driver.Session import GHC.Hs import GHC.Tc.Utils.Zonk@@ -61,7 +61,6 @@ import GHC.Types.Name import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Types.Basic ( isGenerated, il_value, fl_value, Boxity(..) ) import GHC.Data.FastString import GHC.Types.Unique import GHC.Types.Unique.DFM@@ -409,7 +408,7 @@ tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats, eqn_orig = orig }) = do { (wrap, pat') <- tidy1 v orig pat- ; return (wrap, eqn { eqn_pats = do pat' : pats }) }+ ; return (wrap, eqn { eqn_pats = pat' : pats }) } tidy1 :: Id -- The Id being scrutinised -> Origin -- Was this a pattern the user wrote?
compiler/GHC/HsToCore/Match/Constructor.hs view
@@ -1,3 +1,8 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -5,12 +10,6 @@ Pattern-matching constructors -}--{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module GHC.HsToCore.Match.Constructor ( matchConFamily, matchPatSyn ) where
compiler/GHC/HsToCore/Match/Literal.hs view
@@ -1,3 +1,8 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -6,11 +11,6 @@ Pattern-matching literal patterns -} -{-# LANGUAGE CPP, ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- module GHC.HsToCore.Match.Literal ( dsLit, dsOverLit, hsLitKey , tidyLitPat, tidyNPat@@ -35,6 +35,7 @@ import GHC.Hs import GHC.Types.Id+import GHC.Types.SourceText import GHC.Core import GHC.Core.Make import GHC.Core.TyCon@@ -50,7 +51,6 @@ import GHC.Types.SrcLoc import Data.Ratio import GHC.Utils.Outputable as Outputable-import GHC.Types.Basic import GHC.Driver.Session import GHC.Utils.Misc import GHC.Utils.Panic@@ -105,7 +105,7 @@ HsString _ str -> mkStringExprFS str HsInteger _ i _ -> return (mkIntegerExpr i) HsInt _ i -> return (mkIntExpr platform (il_value i))- HsRat _ (FL _ _ val) ty -> do+ HsRat _ (FL _ _ val) ty -> return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom]) where num = mkIntegerExpr (numerator val)@@ -223,7 +223,7 @@ checkPositive :: Integer -> Name -> DsM () checkPositive i tc- = when (i < 0) $ do+ = when (i < 0) $ warnDs (Reason Opt_WarnOverflowedLiterals) (vcat [ text "Literal" <+> integer i <+> text "is negative but" <+> ppr tc@@ -232,7 +232,7 @@ check :: forall a. (Bounded a, Integral a) => Integer -> Name -> Proxy a -> DsM () check i tc _proxy- = when (i < minB || i > maxB) $ do+ = when (i < minB || i > maxB) $ warnDs (Reason Opt_WarnOverflowedLiterals) (vcat [ text "Literal" <+> integer i <+> text "is out of the" <+> ppr tc <+> ptext (sLit "range")
compiler/GHC/HsToCore/Monad.hs view
@@ -1,3 +1,10 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}++{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an orphan+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -6,14 +13,6 @@ Monadery used in desugaring -} -{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an orphan- module GHC.HsToCore.Monad ( DsM, mapM, mapAndUnzipM, initDs, initDsTc, initTcDsForSolver, initDsWithModGuts, fixDs,@@ -58,41 +57,59 @@ import GHC.Prelude -import GHC.Tc.Utils.Monad+import GHC.Driver.Env+import GHC.Driver.Session+import GHC.Driver.Ppr++import GHC.Hs++import GHC.HsToCore.Types+import GHC.HsToCore.Pmc.Solver.Types (Nablas, initNablas)+ import GHC.Core.FamInstEnv import GHC.Core import GHC.Core.Make ( unitExpr ) import GHC.Core.Utils ( exprType, isExprLevPoly )-import GHC.Hs+import GHC.Core.DataCon+import GHC.Core.ConLike+import GHC.Core.TyCon+import GHC.Core.Type+import GHC.Core.Multiplicity+ import GHC.IfaceToCore++import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcMType ( checkForLevPolyX, formatLevPolyErr )+ import GHC.Builtin.Names-import GHC.Types.Name.Reader-import GHC.Driver.Types+ import GHC.Data.Bag+import GHC.Data.FastString++import GHC.Unit.External+import GHC.Unit.Module+import GHC.Unit.Module.ModGuts+import GHC.Unit.Home+import GHC.Unit.State++import GHC.Types.Name.Reader import GHC.Types.Basic ( Origin )-import GHC.Core.DataCon-import GHC.Core.ConLike-import GHC.Core.TyCon-import GHC.HsToCore.Types-import GHC.HsToCore.Pmc.Solver.Types (Nablas, initNablas)+import GHC.Types.SourceFile import GHC.Types.Id-import GHC.Unit.Module-import GHC.Utils.Outputable import GHC.Types.SrcLoc-import GHC.Core.Type-import GHC.Core.Multiplicity+import GHC.Types.TypeEnv import GHC.Types.Unique.Supply import GHC.Types.Name import GHC.Types.Name.Env-import GHC.Driver.Session-import GHC.Driver.Ppr-import GHC.Utils.Error-import GHC.Utils.Panic-import GHC.Data.FastString+import GHC.Types.Name.Ppr import GHC.Types.Literal ( mkLitString ) import GHC.Types.CostCentre.State+import GHC.Types.TyThing +import GHC.Utils.Outputable+import GHC.Utils.Error+import GHC.Utils.Panic+ import Data.IORef {-@@ -213,6 +230,8 @@ = do { cc_st_var <- liftIO $ newIORef newCostCentreState ; eps <- liftIO $ hscEPS hsc_env ; let dflags = hsc_dflags hsc_env+ home_unit = hsc_home_unit hsc_env+ unit_state = unitState dflags this_mod = tcg_mod tcg_env type_env = tcg_type_env tcg_env rdr_env = tcg_rdr_env tcg_env@@ -220,7 +239,7 @@ complete_matches = hptCompleteSigs hsc_env -- from the home package ++ tcg_complete_matches tcg_env -- from the current module ++ eps_complete_matches eps -- from imports- ; return $ mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env+ ; return $ mkDsEnvs unit_state home_unit this_mod rdr_env type_env fam_inst_env msg_var cc_st_var complete_matches } @@ -244,6 +263,8 @@ ; msg_var <- newIORef emptyMessages ; eps <- liftIO $ hscEPS hsc_env ; let dflags = hsc_dflags hsc_env+ home_unit = hsc_home_unit hsc_env+ unit_state = unitState dflags type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts) rdr_env = mg_rdr_env guts fam_inst_env = mg_fam_inst_env guts@@ -256,7 +277,7 @@ bindsToIds (Rec binds) = map fst binds ids = concatMap bindsToIds (mg_binds guts) - envs = mkDsEnvs dflags this_mod rdr_env type_env+ envs = mkDsEnvs unit_state home_unit this_mod rdr_env type_env fam_inst_env msg_var cc_st_var complete_matches ; runDs hsc_env envs thing_inside@@ -285,10 +306,10 @@ updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env }) $ thing_inside } -mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv+mkDsEnvs :: UnitState -> HomeUnit -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv -> IORef Messages -> IORef CostCentreState -> CompleteMatches -> (DsGblEnv, DsLclEnv)-mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var cc_st_var+mkDsEnvs unit_state home_unit mod rdr_env type_env fam_inst_env msg_var cc_st_var complete_matches = let if_genv = IfGblEnv { if_doc = text "mkDsEnvs", if_rec_types = Just (mod, return type_env) }@@ -298,10 +319,7 @@ gbl_env = DsGblEnv { ds_mod = mod , ds_fam_inst_env = fam_inst_env , ds_if_env = (if_genv, if_lenv)- , ds_unqual = mkPrintUnqualified- (unitState dflags)- (mkHomeUnitFromFlags dflags)- rdr_env+ , ds_unqual = mkPrintUnqualified unit_state home_unit rdr_env , ds_msgs = msg_var , ds_complete_matches = complete_matches , ds_cc_st = cc_st_var
compiler/GHC/HsToCore/Pmc.hs view
@@ -1,12 +1,7 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-} -- | This module coverage checks pattern matches. It finds --@@ -59,7 +54,7 @@ import GHC.Types.Basic (Origin(..)) import GHC.Core (CoreExpr) import GHC.Driver.Session-import GHC.Driver.Types+import GHC.Driver.Env import GHC.Hs import GHC.Types.Id import GHC.Types.SrcLoc@@ -272,7 +267,7 @@ testRedSets RedSets { rs_cov = cov, rs_div = div, rs_bangs = bangs } = do is_covered <- isInhabited cov may_diverge <- isInhabited div- red_bangs <- flip mapMaybeM (fromOL bangs) $ \(nablas, bang) -> do+ red_bangs <- flip mapMaybeM (fromOL bangs) $ \(nablas, bang) -> isInhabited nablas >>= \case True -> pure Nothing False -> pure (Just bang)@@ -356,14 +351,14 @@ when (approx && (exists_u || exists_i)) $ putSrcSpanDs loc (warnDs NoReason approx_msg) - when exists_b $ forM_ redundant_bangs $ \(SrcInfo (L l q)) -> do+ when exists_b $ forM_ redundant_bangs $ \(SrcInfo (L l q)) -> putSrcSpanDs l (warnDs (Reason Opt_WarnRedundantBangPatterns) (pprEqn q "has redundant bang")) - when exists_r $ forM_ redundant_rhss $ \(SrcInfo (L l q)) -> do+ when exists_r $ forM_ redundant_rhss $ \(SrcInfo (L l q)) -> putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns) (pprEqn q "is redundant"))- when exists_i $ forM_ inaccessible_rhss $ \(SrcInfo (L l q)) -> do+ when exists_i $ forM_ inaccessible_rhss $ \(SrcInfo (L l q)) -> putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns) (pprEqn q "has inaccessible right hand side"))
compiler/GHC/HsToCore/Pmc/Check.hs view
@@ -1,12 +1,7 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} -- | Coverage checking step of the -- [Lower Your Guards paper](https://dl.acm.org/doi/abs/10.1145/3408989).
compiler/GHC/HsToCore/Pmc/Desugar.hs view
@@ -1,12 +1,7 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-} -- | Desugaring step of the -- [Lower Your Guards paper](https://dl.acm.org/doi/abs/10.1145/3408989).@@ -44,12 +39,11 @@ import GHC.Tc.Types.Evidence (HsWrapper(..), isIdHsWrapper) import {-# SOURCE #-} GHC.HsToCore.Expr (dsExpr, dsLExpr, dsSyntaxExpr) import {-# SOURCE #-} GHC.HsToCore.Binds (dsHsWrapper)-import GHC.HsToCore.Utils (selectMatchVar)+import GHC.HsToCore.Utils (isTrueLHsExpr, selectMatchVar) import GHC.HsToCore.Match.Literal (dsLit, dsOverLit) import GHC.HsToCore.Monad import GHC.Core.TyCo.Rep import GHC.Core.Type-import GHC.HsToCore.Utils (isTrueLHsExpr) import GHC.Data.Maybe import qualified GHC.LanguageExtensions as LangExt import GHC.Utils.Monad (concatMapM)@@ -193,7 +187,7 @@ , cpt_tvs = ex_tvs , cpt_dicts = dicts }- } -> do+ } -> desugarConPatOut x con arg_tys ex_tvs dicts ps NPat ty (L _ olit) mb_neg _ -> do@@ -368,7 +362,7 @@ -- recursion, pattern bindings etc. -- See Note [Long-distance information for HsLocalBinds]. desugarLocalBinds :: LHsLocalBinds GhcTc -> DsM [PmGrd]-desugarLocalBinds (L _ (HsValBinds _ (XValBindsLR (NValBinds binds _)))) = do+desugarLocalBinds (L _ (HsValBinds _ (XValBindsLR (NValBinds binds _)))) = concatMapM (concatMapM go . bagToList) (map snd binds) where go :: LHsBind GhcTc -> DsM [PmGrd]
compiler/GHC/HsToCore/Pmc/Ppr.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, ViewPatterns #-}+{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
compiler/GHC/HsToCore/Pmc/Solver.hs view
@@ -1,12 +1,14 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+ {- Authors: George Karachalias <george.karachalias@cs.kuleuven.be> Sebastian Graf <sgraf1337@gmail.com> Ryan Scott <ryan.gl.scott@gmail.com> -} -{-# LANGUAGE CPP, LambdaCase, TupleSections, PatternSynonyms, ViewPatterns,- MultiWayIf, ScopedTypeVariables, MagicHash #-}- -- | Model refinements type as per the -- [Lower Your Guards paper](https://dl.acm.org/doi/abs/10.1145/3408989). -- The main export of the module are the functions 'addPhiCtsNablas' for adding@@ -17,6 +19,7 @@ -- In terms of the LYG paper, this module is concerned with Sections 3.4, 3.6 -- and 3.7. E.g., it represents refinement types directly as a bunch of -- normalised refinement types 'Nabla'.+ module GHC.HsToCore.Pmc.Solver ( Nabla, Nablas(..), initNablas,@@ -67,6 +70,7 @@ import GHC.Core.DataCon import GHC.Core.PatSyn import GHC.Core.TyCon+import GHC.Core.TyCon.RecWalk import GHC.Builtin.Types import GHC.Builtin.Types.Prim (tYPETyCon) import GHC.Core.TyCo.Rep@@ -117,13 +121,13 @@ -- See Note [Implementation of COMPLETE pragmas] -- | Update the COMPLETE sets of 'ResidualCompleteMatches'.-updRcm :: (ConLikeSet -> ConLikeSet) -> ResidualCompleteMatches -> ResidualCompleteMatches+updRcm :: (CompleteMatch -> CompleteMatch) -> ResidualCompleteMatches -> ResidualCompleteMatches updRcm f (RCM vanilla pragmas) = RCM (f <$> vanilla) (fmap f <$> pragmas) -- | A pseudo-'CompleteMatch' for the vanilla complete set of the given data -- 'TyCon'. -- Ex.: @vanillaCompleteMatchTC 'Maybe' ==> Just ("Maybe", {'Just','Nothing'})@-vanillaCompleteMatchTC :: TyCon -> Maybe ConLikeSet+vanillaCompleteMatchTC :: TyCon -> Maybe CompleteMatch vanillaCompleteMatchTC tc = let -- | TYPE acts like an empty data type on the term-level (#14086), but -- it is a PrimTyCon, so tyConDataCons_maybe returns Nothing. Hence a@@ -384,7 +388,7 @@ -- efficient. normaliseSourceTypeWHNF :: TyState -> Type -> DsM Type normaliseSourceTypeWHNF _ ty | isSourceTypeInWHNF ty = pure ty-normaliseSourceTypeWHNF ty_st ty = do+normaliseSourceTypeWHNF ty_st ty = pmTopNormaliseType ty_st ty >>= \case NoChange ty -> pure ty NormalisedByConstraints ty -> pure ty@@ -1219,7 +1223,7 @@ where nabla_not_dirty = nabla{ nabla_tm_st = ts{ts_dirty=emptyDVarSet} } test_one :: VarInfo -> MaybeT DsM VarInfo- test_one vi = do+ test_one vi = lift (varNeedsTesting old_ty_st nabla vi) >>= \case True -> do -- tracPm "test_one" (ppr vi)@@ -1256,9 +1260,9 @@ -- | Returns (Just vi) if at least one member of each ConLike in the COMPLETE -- set satisfies the oracle ----- Internally uses and updates the ConLikeSets in vi_rcm.+-- Internally uses and updates the CompleteMatchs in vi_rcm. ----- NB: Does /not/ filter each ConLikeSet with the oracle; members may+-- NB: Does /not/ filter each CompleteMatch with the oracle; members may -- remain that do not statisfy it. This lazy approach just -- avoids doing unnecessary work. instantiate :: Int -> Nabla -> VarInfo -> MaybeT DsM VarInfo@@ -1322,7 +1326,7 @@ -- original Nabla, not a proper refinement! No positive information will be -- added, only negative information from failed instantiation attempts, -- entirely as an optimisation.-instCompleteSet :: Int -> Nabla -> Id -> ConLikeSet -> MaybeT DsM Nabla+instCompleteSet :: Int -> Nabla -> Id -> CompleteMatch -> MaybeT DsM Nabla instCompleteSet fuel nabla x cs | anyConLikeSolution (`elementOfUniqDSet` cs) (vi_pos vi) -- No need to instantiate a constructor of this COMPLETE set if we already@@ -1333,7 +1337,7 @@ where vi = lookupVarInfo (nabla_tm_st nabla) x - sorted_candidates :: ConLikeSet -> [ConLike]+ sorted_candidates :: CompleteMatch -> [ConLike] sorted_candidates cs -- If there aren't many candidates, we can try to sort them by number of -- strict fields, type constraints, etc., so that we are fast in the@@ -1701,7 +1705,7 @@ other_cons_nablas <- instantiate_cons x ty xs (n - length con_nablas) nabla cls pure (con_nablas ++ other_cons_nablas) -pickApplicableCompleteSets :: Type -> ResidualCompleteMatches -> DsM [ConLikeSet]+pickApplicableCompleteSets :: Type -> ResidualCompleteMatches -> DsM [CompleteMatch] pickApplicableCompleteSets ty rcm = do env <- dsGetFamInstEnvs pure $ filter (all (is_valid env) . uniqDSetToList) (getRcm rcm)
compiler/GHC/HsToCore/Pmc/Solver/Types.hs view
@@ -1,8 +1,6 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ApplicativeDo #-} -- | Domain types used in "GHC.HsToCore.Pmc.Solver". -- The ultimate goal is to define 'Nabla', which models normalised refinement@@ -15,7 +13,7 @@ Nabla(..), Nablas(..), initNablas, -- ** Caching residual COMPLETE sets- ConLikeSet, ResidualCompleteMatches(..), getRcm, isRcmInitialised,+ CompleteMatch, ResidualCompleteMatches(..), getRcm, isRcmInitialised, -- ** Representations for Literals and AltCons PmLit(..), PmLitValue(..), PmAltCon(..), pmLitType, pmAltConType,@@ -63,7 +61,7 @@ import GHC.Builtin.Types.Prim import GHC.Tc.Solver.Monad (InertSet, emptyInert) import GHC.Tc.Utils.TcType (isStringTy)-import GHC.Driver.Types (ConLikeSet)+import GHC.Types.CompleteMatch (CompleteMatch) import Numeric (fromRat) import Data.Foldable (find)@@ -92,7 +90,7 @@ instance Outputable Nabla where ppr nabla = hang (text "Nabla") 2 $ vcat [ -- intentionally formatted this way enable the dev to comment in only- -- the info she needs+ -- the info they need ppr (nabla_tm_st nabla), ppr (nabla_ty_st nabla) ]@@ -251,19 +249,19 @@ -- See also Note [Implementation of COMPLETE pragmas] data ResidualCompleteMatches = RCM- { rcm_vanilla :: !(Maybe ConLikeSet)+ { rcm_vanilla :: !(Maybe CompleteMatch) -- ^ The residual set for the vanilla COMPLETE set from the data defn. -- Tracked separately from 'rcm_pragmas', because it might only be -- known much later (when we have enough type information to see the 'TyCon' -- of the match), or not at all even. Until that happens, it is 'Nothing'.- , rcm_pragmas :: !(Maybe [ConLikeSet])+ , rcm_pragmas :: !(Maybe [CompleteMatch]) -- ^ The residual sets for /all/ COMPLETE sets from pragmas that are -- visible when compiling this module. Querying that set with -- 'dsGetCompleteMatches' requires 'DsM', so we initialise it with 'Nothing' -- until first needed in a 'DsM' context. } -getRcm :: ResidualCompleteMatches -> [ConLikeSet]+getRcm :: ResidualCompleteMatches -> [CompleteMatch] getRcm (RCM vanilla pragmas) = maybeToList vanilla ++ fromMaybe [] pragmas isRcmInitialised :: ResidualCompleteMatches -> Bool@@ -365,7 +363,7 @@ data PmAltCon = PmAltConLike ConLike | PmAltLit PmLit -data PmAltConSet = PACS !ConLikeSet ![PmLit]+data PmAltConSet = PACS !CompleteMatch ![PmLit] emptyPmAltConSet :: PmAltConSet emptyPmAltConSet = PACS emptyUniqDSet []
compiler/GHC/HsToCore/Pmc/Types.hs view
@@ -1,13 +1,12 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+ {- Author: George Karachalias <george.karachalias@cs.kuleuven.be> Sebastian Graf <sgraf1337@gmail.com> -}--{-# LANGUAGE CPP #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DeriveFunctor #-} -- | Types used through-out pattern match checking. This module is mostly there -- to be imported from "GHC.HsToCore.Types". The exposed API is that of
compiler/GHC/HsToCore/Pmc/Utils.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP, LambdaCase, TupleSections, PatternSynonyms, ViewPatterns,- MultiWayIf, ScopedTypeVariables, MagicHash #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-} -- | Utility module for the pattern-match coverage checker. module GHC.HsToCore.Pmc.Utils (
compiler/GHC/HsToCore/Quote.hs view
@@ -1,15 +1,14 @@-{-# LANGUAGE CPP, TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -35,49 +34,55 @@ import GHC.Prelude import GHC.Platform -import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr )+import GHC.Driver.Session +import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr ) import GHC.HsToCore.Match.Literal import GHC.HsToCore.Monad+import GHC.HsToCore.Binds import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Syntax as TH import GHC.Hs-import GHC.Builtin.Names -import GHC.Unit.Module-import GHC.Types.Id-import GHC.Types.Name hiding( varName, tcName )-import GHC.Builtin.Names.TH-import GHC.Types.Name.Env import GHC.Tc.Utils.TcType+import GHC.Tc.Types.Evidence++import GHC.Core.Class+import GHC.Core.DataCon 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-import GHC.Types.SrcLoc as SrcLoc-import GHC.Types.Unique-import GHC.Types.Basic++import GHC.Builtin.Names+import GHC.Builtin.Names.TH+import GHC.Builtin.Types++import GHC.Unit.Module+ import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Misc+import GHC.Utils.Monad+ import GHC.Data.Bag-import GHC.Driver.Session import GHC.Data.FastString-import GHC.Types.ForeignCall-import GHC.Utils.Misc import GHC.Data.Maybe-import GHC.Utils.Monad-import GHC.Tc.Types.Evidence-import Control.Monad.Trans.Reader-import Control.Monad.Trans.Class-import GHC.Core.Class-import GHC.Driver.Types ( MonadThings )-import GHC.Core.DataCon++import GHC.Types.SrcLoc as SrcLoc+import GHC.Types.Unique+import GHC.Types.Basic+import GHC.Types.ForeignCall import GHC.Types.Var-import GHC.HsToCore.Binds+import GHC.Types.Id+import GHC.Types.SourceText+import GHC.Types.Fixity+import GHC.Types.TyThing+import GHC.Types.Name hiding( varName, tcName )+import GHC.Types.Name.Env import GHC.TypeLits import Data.Kind (Constraint)@@ -86,6 +91,8 @@ import Control.Monad import Data.List import Data.Function+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Class data MetaWrappers = MetaWrappers { -- Applies its argument to a type argument `m` and dictionary `Quote m`@@ -586,9 +593,9 @@ repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn -> MetaM (Core (Maybe (M TH.Kind))) repFamilyResultSigToMaybeKind (NoSig _) =- do { coreNothingM kindTyConName }+ coreNothingM kindTyConName repFamilyResultSigToMaybeKind (KindSig _ ki) =- do { coreJustM kindTyConName =<< repLTy ki }+ coreJustM kindTyConName =<< repLTy ki repFamilyResultSigToMaybeKind TyVarSig{} = panic "repFamilyResultSigToMaybeKind: unexpected TyVarSig" @@ -596,7 +603,7 @@ repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) -> MetaM (Core (Maybe TH.InjectivityAnn)) repInjectivityAnn Nothing =- do { coreNothing injAnnTyConName }+ coreNothing injAnnTyConName repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) = do { lhs' <- lookupBinder (unLoc lhs) ; rhs1 <- mapM (lookupBinder . unLoc) rhs@@ -870,27 +877,26 @@ , con_forall = (L _ False) , con_mb_cxt = Nothing , con_args = args }))- = repDataCon con args+ = repH98DataCon con args repC (L _ (ConDeclH98 { con_name = con , con_forall = L _ is_existential , con_ex_tvs = con_tvs , con_mb_cxt = mcxt , con_args = args }))- = do { addHsTyVarBinds con_tvs $ \ ex_bndrs ->- do { c' <- repDataCon con args+ = addHsTyVarBinds con_tvs $ \ ex_bndrs ->+ do { c' <- repH98DataCon con args ; ctxt' <- repMbContext mcxt ; if not is_existential && isNothing mcxt then return c' else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) }- } repC (L _ (ConDeclGADT { con_g_ext = imp_tvs , con_names = cons , con_qvars = exp_tvs , con_mb_cxt = mcxt- , con_args = args+ , con_g_args = args , con_res_ty = res_ty })) | null imp_tvs && null exp_tvs -- No implicit or explicit variables , Nothing <- mcxt -- No context@@ -1109,10 +1115,10 @@ ; return [(loc, pragma)] } repInline :: InlineSpec -> MetaM (Core TH.Inline)-repInline NoInline = dataCon noInlineDataConName-repInline Inline = dataCon inlineDataConName-repInline Inlinable = dataCon inlinableDataConName-repInline NoUserInline = notHandled "NOUSERINLINE" empty+repInline NoInline = dataCon noInlineDataConName+repInline Inline = dataCon inlineDataConName+repInline Inlinable = dataCon inlinableDataConName+repInline NoUserInlinePrag = notHandled "NOUSERINLINE" empty repRuleMatch :: RuleMatchInfo -> MetaM (Core TH.RuleMatch) repRuleMatch ConLike = dataCon conLikeDataConName@@ -2248,8 +2254,11 @@ --------------- Expressions ----------------- repVarOrCon :: Name -> Core TH.Name -> MetaM (Core (M TH.Exp))-repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str- | otherwise = repVar str+repVarOrCon vc str+ | isVarNameSpace ns = repVar str -- Both type and term variables (#18740)+ | otherwise = repCon str+ where+ ns = nameNameSpace vc repVar :: Core TH.Name -> MetaM (Core (M TH.Exp)) repVar (MkC s) = rep2 varEName [s]@@ -2579,49 +2588,51 @@ repCtxt :: Core [(M TH.Pred)] -> MetaM (Core (M TH.Cxt)) repCtxt (MkC tys) = rep2 cxtName [tys] -repDataCon :: Located Name- -> HsConDeclDetails GhcRn- -> MetaM (Core (M TH.Con))-repDataCon con details+repH98DataCon :: Located Name+ -> HsConDeclH98Details GhcRn+ -> MetaM (Core (M TH.Con))+repH98DataCon con details = do con' <- lookupLOcc con -- See Note [Binders and occurrences]- repConstr details Nothing [con']+ case details of+ PrefixCon ps -> do+ arg_tys <- repPrefixConArgs ps+ rep2 normalCName [unC con', unC arg_tys]+ InfixCon st1 st2 -> do+ arg1 <- repBangTy (hsScaledThing st1)+ arg2 <- repBangTy (hsScaledThing st2)+ rep2 infixCName [unC arg1, unC con', unC arg2]+ RecCon ips -> do+ arg_vtys <- repRecConArgs ips+ rep2 recCName [unC con', unC arg_vtys] repGadtDataCons :: [Located Name]- -> HsConDeclDetails GhcRn+ -> HsConDeclGADTDetails GhcRn -> LHsType GhcRn -> MetaM (Core (M TH.Con)) repGadtDataCons cons details res_ty = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences]- repConstr details (Just res_ty) cons'---- Invariant:--- * for plain H98 data constructors second argument is Nothing and third--- argument is a singleton list--- * for GADTs data constructors second argument is (Just return_type) and--- third argument is a non-empty list-repConstr :: HsConDeclDetails GhcRn- -> Maybe (LHsType GhcRn)- -> [Core TH.Name]- -> MetaM (Core (M TH.Con))-repConstr (PrefixCon ps) Nothing [con]- = 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 (map hsScaledThing ps)- res_ty' <- repLTy res_ty- rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty']--repConstr (RecCon ips) resTy cons- = do args <- concatMapM rep_ip (unLoc ips)- arg_vtys <- coreListM varBangTypeTyConName args- case resTy of- Nothing -> rep2 recCName [unC (head cons), unC arg_vtys]- Just res_ty -> do+ case details of+ PrefixConGADT ps -> do+ arg_tys <- repPrefixConArgs ps res_ty' <- repLTy res_ty- rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys,+ rep2 gadtCName [ unC (nonEmptyCoreList cons'), unC arg_tys, unC res_ty']+ RecConGADT ips -> do+ arg_vtys <- repRecConArgs ips+ res_ty' <- repLTy res_ty+ rep2 recGadtCName [unC (nonEmptyCoreList cons'), unC arg_vtys, unC res_ty'] +-- Desugar the arguments in a data constructor declared with prefix syntax.+repPrefixConArgs :: [HsScaled GhcRn (LHsType GhcRn)]+ -> MetaM (Core [M TH.BangType])+repPrefixConArgs ps = repListM bangTypeTyConName repBangTy (map hsScaledThing ps)++-- Desugar the arguments in a data constructor declared with record syntax.+repRecConArgs :: Located [LConDeclField GhcRn]+ -> MetaM (Core [M TH.VarBangType])+repRecConArgs ips = do+ args <- concatMapM rep_ip (unLoc ips)+ coreListM varBangTypeTyConName args where rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip) @@ -2629,16 +2640,6 @@ rep_one_ip t n = do { MkC v <- lookupOcc (extFieldOcc $ unLoc n) ; MkC ty <- repBangTy t ; rep2 varBangTypeName [v,ty] }--repConstr (InfixCon st1 st2) Nothing [con]- = do arg1 <- repBangTy (hsScaledThing st1)- arg2 <- repBangTy (hsScaledThing st2)- rep2 infixCName [unC arg1, unC con, unC arg2]--repConstr (InfixCon {}) (Just _) _ =- panic "repConstr: infix GADT constructor should be in a PrefixCon"-repConstr _ _ _ =- panic "repConstr: invariant violated" ------------ Types -------------------
compiler/GHC/HsToCore/Types.hs view
@@ -22,7 +22,7 @@ import GHC.Unit.Module import GHC.Driver.Hooks (DsForeignsHook) import GHC.Data.OrdList (OrdList)-import GHC.Driver.Types (ForeignStubs)+import GHC.Types.ForeignStubs (ForeignStubs) {- ************************************************************************
compiler/GHC/HsToCore/Usage.hs view
@@ -1,6 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -13,22 +11,33 @@ import GHC.Prelude +import GHC.Driver.Env import GHC.Driver.Session++import GHC.Platform import GHC.Platform.Ways-import GHC.Driver.Types+ import GHC.Tc.Types-import GHC.Types.Name-import GHC.Types.Name.Set-import GHC.Unit-import GHC.Unit.State+ import GHC.Utils.Outputable import GHC.Utils.Misc-import GHC.Types.Unique.Set-import GHC.Types.Unique.FM import GHC.Utils.Fingerprint import GHC.Utils.Panic++import GHC.Types.Name+import GHC.Types.Name.Set+import GHC.Types.Unique.Set+import GHC.Types.Unique.FM++import GHC.Unit+import GHC.Unit.External+import GHC.Unit.State+import GHC.Unit.Finder+import GHC.Unit.Module.Imported+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.Deps+ import GHC.Data.Maybe-import GHC.Driver.Finder import Control.Monad (filterM) import Data.List@@ -177,7 +186,7 @@ -- search for the library files containing the plugin. let searchPaths = collectLibraryPaths (ways dflags) [pkg] useDyn = WayDyn `elem` ways dflags- suffix = if useDyn then soExt platform else "a"+ suffix = if useDyn then platformSOExt platform else "a" libLocs = [ searchPath </> "lib" ++ libLoc <.> suffix | searchPath <- searchPaths , libLoc <- packageHsLibs dflags pkg@@ -189,7 +198,7 @@ then libLocs else let dflags' = addWay' WayDyn dflags- dlibLocs = [ searchPath </> mkHsSOName platform dlibLoc+ dlibLocs = [ searchPath </> platformHsSOName platform dlibLoc | searchPath <- searchPaths , dlibLoc <- packageHsLibs dflags' pkg ]@@ -253,7 +262,7 @@ where hpt = hsc_HPT hsc_env dflags = hsc_dflags hsc_env- home_unit = mkHomeUnitFromFlags dflags+ home_unit = hsc_home_unit hsc_env used_mods = moduleEnvKeys ent_map dir_imp_mods = moduleEnvKeys direct_imports
compiler/GHC/HsToCore/Utils.hs view
@@ -1,3 +1,8 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -8,12 +13,6 @@ This module exports some utility functions of no great interest. -} -{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}- -- | Utility functions for constructing Core syntax, principally for desugaring module GHC.HsToCore.Utils ( EquationInfo(..),@@ -455,7 +454,7 @@ I# _ -> ...case b of {True -> fst x; False -> 0}... We can try to avoid doing this by ensuring that the binder-swap in the- case happens, so we get his at an early stage:+ case happens, so we get this at an early stage: case chp of chp2 { I# -> ...chp2... } But this is fragile. The real culprit is the source program. Perhaps we should have said explicitly
compiler/GHC/Iface/Binary.hs view
@@ -39,8 +39,8 @@ import GHC.Tc.Utils.Monad import GHC.Builtin.Utils ( isKnownKeyName, lookupKnownKeyName ) import GHC.Iface.Env-import GHC.Driver.Types import GHC.Unit+import GHC.Unit.Module.ModIface import GHC.Types.Name import GHC.Driver.Session import GHC.Platform.Profile
compiler/GHC/Iface/Env.hs view
@@ -16,7 +16,7 @@ ifaceExportNames, -- Name-cache stuff- allocateGlobalBinder, updNameCacheTc,+ allocateGlobalBinder, updNameCacheTc, updNameCache, mkNameCacheUpdater, NameCacheUpdater(..), ) where @@ -24,22 +24,29 @@ import GHC.Prelude +import GHC.Driver.Env+ import GHC.Tc.Utils.Monad-import GHC.Driver.Types import GHC.Core.Type-import GHC.Types.Var-import GHC.Types.Name-import GHC.Types.Avail+import GHC.Iface.Type+import GHC.Runtime.Context+ import GHC.Unit.Module+import GHC.Unit.Module.ModIface+ import GHC.Data.FastString import GHC.Data.FastString.Env-import GHC.Iface.Type++import GHC.Types.Var+import GHC.Types.Name+import GHC.Types.Avail import GHC.Types.Name.Cache import GHC.Types.Unique.Supply import GHC.Types.SrcLoc import GHC.Utils.Outputable import Data.List ( partition )+import Data.IORef {- *********************************************************@@ -296,3 +303,20 @@ = do { uniqs <- newUniqueSupply ; return [ mkInternalName uniq occ noSrcSpan | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }++{-+Names in a NameCache are always stored as a Global, and have the SrcLoc+of their binding locations.++Actually that's not quite right. When we first encounter the original+name, we might not be at its binding site (e.g. we are reading an+interface file); so we give it 'noSrcLoc' then. Later, when we find+its binding site, we fix it up.+-}++updNameCache :: IORef NameCache+ -> (NameCache -> (NameCache, c)) -- The updating function+ -> IO c+updNameCache ncRef upd_fn+ = atomicModifyIORef' ncRef upd_fn+
compiler/GHC/Iface/Ext/Ast.hs view
@@ -1,23 +1,22 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- Main functions for .hie file generation -}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE UndecidableSuperClasses #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE TupleSections #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module GHC.Iface.Ext.Ast ( mkHieFile, mkHieFileWithSource, getCompressedAsts, enrichHie) where @@ -38,8 +37,7 @@ 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.Driver.Env import GHC.Utils.Monad ( concatMapM, liftIO ) import GHC.Types.Id ( isDataConId_maybe ) import GHC.Types.Name ( Name, nameSrcSpan, nameUnique )@@ -63,6 +61,9 @@ import GHC.Iface.Ext.Types import GHC.Iface.Ext.Utils +import GHC.Unit.Module ( ModuleName, ml_hs_file )+import GHC.Unit.Module.ModSummary+ import qualified Data.Array as A import qualified Data.ByteString as BS import qualified Data.Map as M@@ -1320,6 +1321,10 @@ toHie (RecCon rec) = toHie rec toHie (InfixCon a b) = concatM [ toHie a, toHie b] +instance ToHie (HsConDeclGADTDetails GhcRn) where+ toHie (PrefixConGADT args) = toHie args+ toHie (RecConGADT rec) = toHie rec+ instance HiePass p => ToHie (Located (HsCmdTop (GhcPass p))) where toHie (L span top) = concatM $ makeNode top span : case top of HsCmdTop _ cmd ->@@ -1531,7 +1536,7 @@ instance ToHie (Located (ConDecl 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- , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->+ , con_mb_cxt = ctx, con_g_args = args, con_res_ty = typ } -> [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names , concatM $ [ bindingsOnly bindings , toHie $ tvScopes resScope NoScope exp_vars ]@@ -1542,7 +1547,9 @@ where rhsScope = combineScopes argsScope tyScope ctxScope = maybe NoScope mkLScope ctx- argsScope = condecl_scope args+ argsScope = case args of+ PrefixConGADT xs -> scaled_args_scope xs+ RecConGADT x -> mkLScope x tyScope = mkLScope typ resScope = ResolvedScopes [ctxScope, rhsScope] bindings = map (C $ TyVarBind (mkScope (loc exp_vars)) resScope) imp_vars@@ -1556,13 +1563,12 @@ where rhsScope = combineScopes ctxScope argsScope ctxScope = maybe NoScope mkLScope ctx- argsScope = condecl_scope dets- where condecl_scope :: HsConDeclDetails (GhcPass 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+ argsScope = case dets of+ PrefixCon xs -> scaled_args_scope xs+ InfixCon a b -> scaled_args_scope [a, b]+ RecCon x -> mkLScope x+ where scaled_args_scope :: [HsScaled GhcRn (LHsType GhcRn)] -> Scope+ scaled_args_scope = foldr combineScopes NoScope . map (mkLScope . hsScaledThing) instance ToHie (Located [Located (ConDeclField GhcRn)]) where toHie (L span decls) = concatM $
compiler/GHC/Iface/Ext/Binary.hs view
@@ -222,9 +222,7 @@ readHieFileContents :: BinHandle -> NameCacheUpdater -> IO HieFile readHieFileContents bh0 ncu = do-- dict <- get_dictionary bh0-+ dict <- get_dictionary bh0 -- read the symbol table so we are capable of reading the actual data bh1 <- do let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")@@ -236,8 +234,7 @@ return bh1' -- load the actual data- hiefile <- get bh1- return hiefile+ get bh1 where get_dictionary bin_handle = do dict_p <- get bin_handle
compiler/GHC/Iface/Ext/Debug.hs view
@@ -1,9 +1,9 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+ {- Functions to validate and check .hie file ASTs generated by GHC. -}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-} module GHC.Iface.Ext.Debug where
compiler/GHC/Iface/Ext/Types.hs view
@@ -1,16 +1,16 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+ {- Types for the .hie file format are defined here. For more information see https://gitlab.haskell.org/ghc/ghc/wikis/hie-files -}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternSynonyms #-} module GHC.Iface.Ext.Types where
compiler/GHC/Iface/Ext/Utils.hs view
@@ -194,9 +194,8 @@ compressTypes asts = (a, arr) where (a, (HTS _ m i)) = flip runState initialHTS $- for asts $ \typ -> do- i <- getTypeIndex typ- return i+ for asts $ \typ ->+ getTypeIndex typ arr = A.array (0,i-1) (IM.toList m) recoverFullType :: TypeIndex -> A.Array TypeIndex HieTypeFlat -> HieTypeFix
compiler/GHC/Iface/Load.hs view
@@ -2,13 +2,13 @@ (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --Loading interface files -} {-# LANGUAGE CPP, BangPatterns, RecordWildCards, NondecreasingIndentation #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Loading interface files module GHC.Iface.Load ( -- Importing one thing tcLookupImported_maybe, importDecl,@@ -23,7 +23,6 @@ loadInterface, loadSysInterface, loadUserInterface, loadPluginInterface, findAndReadIface, readIface, writeIface,- loadDecls, -- Should move to GHC.IfaceToCore and be renamed initExternalPackageState, moduleFreeHolesPrecise, needWiredInHomeIface, loadWiredInHomeIface,@@ -37,53 +36,71 @@ import GHC.Prelude import {-# SOURCE #-} GHC.IfaceToCore- ( tcIfaceDecl, tcIfaceRules, tcIfaceInst, tcIfaceFamInst+ ( tcIfaceDecls, tcIfaceRules, tcIfaceInst, tcIfaceFamInst , tcIfaceAnnotations, tcIfaceCompleteMatches ) +import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Backend import GHC.Driver.Ppr+import GHC.Driver.Hooks+import GHC.Driver.Plugins+ import GHC.Iface.Syntax-import GHC.Iface.Env-import GHC.Driver.Types+import GHC.Iface.Ext.Fields+import GHC.Iface.Binary+import GHC.Iface.Rename -import GHC.Types.Basic hiding (SuccessFlag(..)) import GHC.Tc.Utils.Monad import GHC.Utils.Binary ( BinData(..) )+import GHC.Utils.Error+import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc+ import GHC.Settings.Constants+ import GHC.Builtin.Names import GHC.Builtin.Utils import GHC.Builtin.PrimOps ( allThePrimOps, primOpFixity, primOpOcc )-import GHC.Types.Id.Make ( seqId, EnableBignumRules(..) )+ import GHC.Core.Rules import GHC.Core.TyCon-import GHC.Types.Annotations import GHC.Core.InstEnv import GHC.Core.FamInstEnv++import GHC.Types.Id.Make ( seqId, EnableBignumRules(..) )+import GHC.Types.Annotations import GHC.Types.Name 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+import GHC.Types.Fixity+import GHC.Types.Fixity.Env+import GHC.Types.SourceError+import GHC.Types.SourceText+import GHC.Types.SourceFile+import GHC.Types.SafeHaskell+import GHC.Types.TypeEnv import GHC.Types.Unique.FM+import GHC.Types.Unique.DSet import GHC.Types.SrcLoc-import GHC.Utils.Outputable as Outputable-import GHC.Iface.Binary-import GHC.Utils.Panic-import GHC.Utils.Misc-import GHC.Data.FastString-import GHC.Utils.Fingerprint-import GHC.Driver.Hooks import GHC.Types.FieldLabel-import GHC.Iface.Rename-import GHC.Types.Unique.DSet-import GHC.Driver.Plugins+import GHC.Types.TyThing++import GHC.Unit.External+import GHC.Unit.Module+import GHC.Unit.Module.Warnings+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.Deps+import GHC.Unit.State import GHC.Unit.Home+import GHC.Unit.Home.ModInfo+import GHC.Unit.Finder +import GHC.Data.Maybe+import GHC.Data.FastString+ import Control.Monad import Control.Exception import Data.IORef@@ -121,7 +138,7 @@ -- Returns (Failed err) if we can't find the interface file for the thing tcLookupImported_maybe name = do { hsc_env <- getTopEnv- ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)+ ; mb_thing <- liftIO (lookupType hsc_env name) ; case mb_thing of Just thing -> return (Succeeded thing) Nothing -> tcImportDecl_maybe name }@@ -402,8 +419,8 @@ loadInterface doc_str mod from | isHoleModule mod -- Hole modules get special treatment- = do dflags <- getDynFlags- let home_unit = mkHomeUnitFromFlags dflags+ = do hsc_env <- getTopEnv+ let home_unit = hsc_home_unit hsc_env -- Redo search for our local hole module loadInterface doc_str (mkHomeModule home_unit (moduleName mod)) from | otherwise@@ -416,7 +433,8 @@ -- Check whether we have the interface already ; dflags <- getDynFlags- ; let home_unit = mkHomeUnitFromFlags dflags+ ; hsc_env <- getTopEnv+ ; let home_unit = hsc_home_unit hsc_env ; case lookupIfaceByModule hpt (eps_PIT eps) mod of { Just iface -> return (Succeeded iface) ; -- Already loaded@@ -453,7 +471,7 @@ let loc_doc = text loc in- initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $ do+ initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $ dontLeakTheHPT $ do @@ -468,13 +486,13 @@ -- IfaceDecls, IfaceClsInst, IfaceFamInst, IfaceRules, -- out of the ModIface and put them into the big EPS pools - -- NB: *first* we do loadDecl, so that the provenance of all the locally-defined+ -- NB: *first* we do tcIfaceDecls, so that the provenance of all the locally-defined --- names is done correctly (notably, whether this is an .hi file or .hi-boot file). -- If we do loadExport first the wrong info gets into the cache (unless we -- explicitly tag each export which seems a bit of a bore) ; ignore_prags <- goptM Opt_IgnoreInterfacePragmas- ; new_eps_decls <- loadDecls ignore_prags (mi_decls iface)+ ; new_eps_decls <- tcIfaceDecls ignore_prags (mi_decls iface) ; new_eps_insts <- mapM tcIfaceInst (mi_insts iface) ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) ; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface)@@ -643,8 +661,8 @@ -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath)) computeInterface doc_str hi_boot_file mod0 = do MASSERT( not (isHoleModule mod0) )- dflags <- getDynFlags- let home_unit = mkHomeUnitFromFlags dflags+ hsc_env <- getTopEnv+ let home_unit = hsc_home_unit hsc_env case getModuleInstantiation mod0 of (imod, Just indef) | isHomeUnitIndefinite home_unit -> do r <- findAndReadIface doc_str imod mod0 hi_boot_file@@ -756,110 +774,6 @@ addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv addDeclsToPTE pte things = extendNameEnvList pte things -loadDecls :: Bool- -> [(Fingerprint, IfaceDecl)]- -> IfL [(Name,TyThing)]-loadDecls ignore_prags ver_decls- = concatMapM (loadDecl ignore_prags) ver_decls--loadDecl :: Bool -- Don't load pragmas into the decl pool- -> (Fingerprint, IfaceDecl)- -> IfL [(Name,TyThing)] -- The list can be poked eagerly, but the- -- TyThings are forkM'd thunks-loadDecl ignore_prags (_version, decl)- = do { -- Populate the name cache with final versions of all- -- the names associated with the decl- let main_name = ifName decl-- -- Typecheck the thing, lazily- -- NB. Firstly, the laziness is there in case we never need the- -- declaration (in one-shot mode), and secondly it is there so that- -- we don't look up the occurrence of a name before calling mk_new_bndr- -- on the binder. This is important because we must get the right name- -- which includes its nameParent.-- ; thing <- forkM doc $ do { bumpDeclStats main_name- ; tcIfaceDecl ignore_prags decl }-- -- Populate the type environment with the implicitTyThings too.- --- -- Note [Tricky iface loop]- -- ~~~~~~~~~~~~~~~~~~~~~~~~- -- Summary: The delicate point here is that 'mini-env' must be- -- buildable from 'thing' without demanding any of the things- -- 'forkM'd by tcIfaceDecl.- --- -- In more detail: Consider the example- -- data T a = MkT { x :: T a }- -- The implicitTyThings of T are: [ <datacon MkT>, <selector x>]- -- (plus their workers, wrappers, coercions etc etc)- --- -- We want to return an environment- -- [ "MkT" -> <datacon MkT>, "x" -> <selector x>, ... ]- -- (where the "MkT" is the *Name* associated with MkT, etc.)- --- -- We do this by mapping the implicit_names to the associated- -- TyThings. By the invariant on ifaceDeclImplicitBndrs and- -- implicitTyThings, we can use getOccName on the implicit- -- TyThings to make this association: each Name's OccName should- -- be the OccName of exactly one implicitTyThing. So the key is- -- to define a "mini-env"- --- -- [ 'MkT' -> <datacon MkT>, 'x' -> <selector x>, ... ]- -- where the 'MkT' here is the *OccName* associated with MkT.- --- -- However, there is a subtlety: due to how type checking needs- -- to be staged, we can't poke on the forkM'd thunks inside the- -- implicitTyThings while building this mini-env.- -- If we poke these thunks too early, two problems could happen:- -- (1) When processing mutually recursive modules across- -- hs-boot boundaries, poking too early will do the- -- type-checking before the recursive knot has been tied,- -- so things will be type-checked in the wrong- -- environment, and necessary variables won't be in- -- scope.- --- -- (2) Looking up one OccName in the mini_env will cause- -- others to be looked up, which might cause that- -- original one to be looked up again, and hence loop.- --- -- The code below works because of the following invariant:- -- getOccName on a TyThing does not force the suspended type- -- checks in order to extract the name. For example, we don't- -- poke on the "T a" type of <selector x> on the way to- -- extracting <selector x>'s OccName. Of course, there is no- -- reason in principle why getting the OccName should force the- -- thunks, but this means we need to be careful in- -- implicitTyThings and its helper functions.- --- -- All a bit too finely-balanced for my liking.-- -- This mini-env and lookup function mediates between the- --'Name's n and the map from 'OccName's to the implicit TyThings- ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing]- lookup n = case lookupOccEnv mini_env (getOccName n) of- Just thing -> thing- Nothing ->- pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (decl))-- ; implicit_names <- mapM lookupIfaceTop (ifaceDeclImplicitBndrs decl)---- ; traceIf (text "Loading decl for " <> ppr main_name $$ ppr implicit_names)- ; return $ (main_name, thing) :- -- uses the invariant that implicit_names and- -- implicitTyThings are bijective- [(n, lookup n) | n <- implicit_names]- }- where- doc = text "Declaration for" <+> ppr (ifName decl)--bumpDeclStats :: Name -> IfL () -- Record that one more declaration has actually been used-bumpDeclStats name- = do { traceIf (text "Loading decl for" <+> ppr name)- ; updateEps_ (\eps -> let stats = eps_stats eps- in eps { eps_stats = stats { n_decls_out = n_decls_out stats + 1 } })- }- {- ********************************************************* * *@@ -872,7 +786,7 @@ If the sought-for interface is in the current package (as determined by -package-name flag) then it jolly well should already be in the HPT because we process home-package modules in dependency order. (Except-in one-shot mode; see notes with hsc_HPT decl in GHC.Driver.Types).+in one-shot mode; see notes with hsc_HPT decl in GHC.Driver.Env). It is possible (though hard) to get this error through user behaviour. * Suppose package P (modules P1, P2) depends on package Q (modules Q1,@@ -925,7 +839,7 @@ -- Look for the file hsc_env <- getTopEnv mb_found <- liftIO (findExactModule hsc_env mod)- let home_unit = mkHomeUnitFromFlags dflags+ let home_unit = hsc_home_unit hsc_env case mb_found of InstalledFound loc mod -> do -- Found file, so read it
compiler/GHC/Iface/Load.hs-boot view
@@ -2,7 +2,7 @@ import GHC.Unit.Module (Module) import GHC.Tc.Utils.Monad (IfM)-import GHC.Driver.Types (ModIface)+import GHC.Unit.Module.ModIface (ModIface) import GHC.Utils.Outputable (SDoc) loadSysInterface :: SDoc -> Module -> IfM lcl ModIface
compiler/GHC/Iface/Make.hs view
@@ -1,11 +1,11 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NondecreasingIndentation #-}+ {- (c) The University of Glasgow 2006-2008 (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 -} -{-# LANGUAGE CPP, NondecreasingIndentation #-}-{-# LANGUAGE MultiWayIf #-}- -- | Module for constructing @ModIface@ values (interface files), -- writing them to disk and comparing two versions to see if -- recompilation is required.@@ -23,15 +23,21 @@ import GHC.Prelude +import GHC.Hs++import GHC.StgToCmm.Types (CgInfos (..))++import GHC.Tc.Utils.TcType+import GHC.Tc.Utils.Monad+ import GHC.Iface.Syntax import GHC.Iface.Recomp import GHC.Iface.Load+import GHC.Iface.Ext.Fields+ import GHC.CoreToIface import qualified GHC.LanguageExtensions as LangExt-import GHC.HsToCore.Usage ( mkUsageInfo, mkUsedNames, mkDependencies )-import GHC.Types.Id-import GHC.Types.Annotations import GHC.Core import GHC.Core.Class import GHC.Core.TyCon@@ -40,16 +46,19 @@ 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-import GHC.Tc.Utils.Monad-import GHC.Hs-import GHC.Driver.Types++import GHC.Driver.Env import GHC.Driver.Backend import GHC.Driver.Session import GHC.Driver.Ppr+import GHC.Driver.Plugins (LoadedPlugin(..))++import GHC.Types.Id+import GHC.Types.Fixity.Env+import GHC.Types.SafeHaskell+import GHC.Types.Annotations import GHC.Types.Var.Env import GHC.Types.Var import GHC.Types.Name@@ -58,21 +67,34 @@ import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Unique.DSet-import GHC.Unit+import GHC.Types.Basic hiding ( SuccessFlag(..) )+import GHC.Types.TypeEnv+import GHC.Types.SourceFile+import GHC.Types.TyThing+import GHC.Types.HpcInfo+ import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Types.Basic hiding ( SuccessFlag(..) ) import GHC.Utils.Misc hiding ( eqListBy )+ import GHC.Data.FastString import GHC.Data.Maybe+ import GHC.HsToCore.Docs+import GHC.HsToCore.Usage ( mkUsageInfo, mkUsedNames, mkDependencies ) +import GHC.Unit+import GHC.Unit.Module.Warnings+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.ModGuts+import GHC.Unit.Module.Deps+ import Data.Function import Data.List ( findIndex, mapAccumL, sortBy ) import Data.Ord import Data.IORef-import GHC.Driver.Plugins (LoadedPlugin(..)) {- ************************************************************************@@ -172,7 +194,7 @@ = do let used_names = mkUsedNames tc_result let pluginModules = map lpModule (cachedPlugins (hsc_dflags hsc_env))- let home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)+ let home_unit = hsc_home_unit hsc_env deps <- mkDependencies (homeUnitId home_unit) (map mi_module pluginModules) tc_result let hpc_info = emptyHpcInfo other_hpc_info@@ -228,7 +250,7 @@ -- to expose in the interface = do- let home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)+ let home_unit = hsc_home_unit hsc_env semantic_mod = homeModuleNameInstantiation home_unit (moduleName this_mod) entities = typeEnvElts type_env show_linear_types = xopt LangExt.LinearTypes (hsc_dflags hsc_env)
compiler/GHC/Iface/Recomp.hs view
@@ -14,45 +14,57 @@ import GHC.Prelude +import GHC.Driver.Backend+import GHC.Driver.Env+import GHC.Driver.Session+import GHC.Driver.Ppr+import GHC.Driver.Plugins ( PluginRecompile(..), PluginWithArgs(..), pluginRecompile', plugins )+ import GHC.Iface.Syntax import GHC.Iface.Recomp.Binary import GHC.Iface.Load import GHC.Iface.Recomp.Flags -import GHC.Types.Annotations import GHC.Core import GHC.Tc.Utils.Monad import GHC.Hs-import GHC.Driver.Backend-import GHC.Driver.Types-import GHC.Driver.Finder-import GHC.Driver.Session-import GHC.Driver.Ppr-import GHC.Types.Name-import GHC.Types.Name.Set-import GHC.Unit.Module++import GHC.Data.Graph.Directed+import GHC.Data.Maybe+import GHC.Data.FastString+ import GHC.Utils.Error import GHC.Utils.Panic-import GHC.Data.Graph.Directed-import GHC.Types.SrcLoc import GHC.Utils.Outputable as Outputable-import GHC.Types.Unique import GHC.Utils.Misc as Utils hiding ( eqListBy )-import GHC.Data.Maybe-import GHC.Data.FastString import GHC.Utils.Binary import GHC.Utils.Fingerprint import GHC.Utils.Exception++import GHC.Types.Annotations+import GHC.Types.Name+import GHC.Types.Name.Set+import GHC.Types.SrcLoc+import GHC.Types.Unique import GHC.Types.Unique.Set+import GHC.Types.Fixity.Env+import GHC.Types.SourceFile++import GHC.Unit.External+import GHC.Unit.Finder import GHC.Unit.State import GHC.Unit.Home+import GHC.Unit.Module+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.Warnings+import GHC.Unit.Module.Deps import Control.Monad import Data.Function import Data.List (find, sortBy, sort) import qualified Data.Map as Map import qualified Data.Set as Set-import GHC.Driver.Plugins ( PluginRecompile(..), PluginWithArgs(..), pluginRecompile', plugins ) --Qualified import so we can define a Semigroup instance -- but it doesn't clash with Outputable.<>@@ -256,7 +268,7 @@ ; return (recomp, Just iface) }}}}}}}}}} where- home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)+ home_unit = hsc_home_unit hsc_env -- This is a bit of a hack really mod_deps :: ModuleNameEnv ModuleNameWithIsBoot mod_deps = mkModDeps (dep_mods (mi_deps iface))@@ -271,7 +283,7 @@ pluginRecompileToRecompileRequired old_fingerprint new_fingerprint pr fingerprintPlugins :: HscEnv -> IO Fingerprint-fingerprintPlugins hsc_env = do+fingerprintPlugins hsc_env = fingerprintPlugins' $ plugins (hsc_dflags hsc_env) fingerprintPlugins' :: [PluginWithArgs] -> IO Fingerprint@@ -335,8 +347,8 @@ -- implementing module has changed. checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired checkHsig mod_summary iface = do- dflags <- getDynFlags- let home_unit = mkHomeUnitFromFlags dflags+ hsc_env <- getTopEnv+ let home_unit = hsc_home_unit hsc_env outer_mod = ms_mod mod_summary inner_mod = homeModuleNameInstantiation home_unit (moduleName outer_mod) MASSERT( isHomeModule home_unit outer_mod )@@ -436,7 +448,7 @@ -- Returns (RecompBecause <textual reason>) if recompilation is required. checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired checkDependencies hsc_env summary iface- = do+ = checkList $ [ checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary)) , do@@ -453,7 +465,7 @@ prev_dep_mods = dep_mods (mi_deps iface) prev_dep_plgn = dep_plgins (mi_deps iface) prev_dep_pkgs = dep_pkgs (mi_deps iface)- home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)+ home_unit = hsc_home_unit hsc_env dep_missing (mb_pkg, L _ mod) = do find_res <- liftIO $ findImportedModule hsc_env mod (mb_pkg)@@ -486,7 +498,6 @@ isOldHomeDeps = flip Set.member old_deps checkForNewHomeDependency (L _ mname) = do let- home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env) mod = mkHomeModule home_unit mname str_mname = moduleNameString mname reason = str_mname ++ " changed"@@ -607,8 +618,7 @@ recompile <- checkModuleFingerprint reason old_mod_hash new_mod_hash if not (recompileRequired recompile) then return UpToDate- else do-+ else -- CHECK EXPORT LIST checkMaybeHash reason maybe_old_export_hash new_export_hash (text " Export list changed") $ do@@ -863,7 +873,7 @@ extend_hash_env :: OccEnv (OccName,Fingerprint) -> (Fingerprint,IfaceDecl) -> IO (OccEnv (OccName,Fingerprint))- extend_hash_env env0 (hash,d) = do+ extend_hash_env env0 (hash,d) = return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0 (ifaceDeclFingerprints hash d)) @@ -1359,8 +1369,7 @@ | otherwise = lookup orig_mod where- dflags = hsc_dflags hsc_env- home_unit = mkHomeUnitFromFlags dflags+ home_unit = hsc_home_unit hsc_env hpt = hsc_HPT hsc_env pit = eps_PIT eps occ = nameOccName name@@ -1369,14 +1378,13 @@ MASSERT2( isExternalName name, ppr name ) iface <- case lookupIfaceByModule hpt pit mod of Just iface -> return iface- Nothing -> do+ Nothing -> -- This can occur when we're writing out ifaces for -- requirements; we didn't do any /real/ typechecking -- so there's no guarantee everything is loaded. -- Kind of a heinous hack.- iface <- initIfaceLoad hsc_env . withException- $ loadInterface (text "lookupVers2") mod ImportBySystem- return iface+ initIfaceLoad hsc_env . withException+ $ loadInterface (text "lookupVers2") mod ImportBySystem return $ snd (mi_hash_fn (mi_final_exts iface) occ `orElse` pprPanic "lookupVers1" (ppr mod <+> ppr occ))
compiler/GHC/Iface/Recomp/Flags.hs view
@@ -12,9 +12,9 @@ import GHC.Utils.Binary import GHC.Driver.Session-import GHC.Driver.Types import GHC.Unit.Module import GHC.Types.Name+import GHC.Types.SafeHaskell import GHC.Utils.Fingerprint import GHC.Iface.Recomp.Binary -- import GHC.Utils.Outputable@@ -34,7 +34,7 @@ -> IO Fingerprint fingerprintDynFlags dflags@DynFlags{..} this_mod nameio =- let mainis = if mainModIs == this_mod then Just mainFunIs else Nothing+ let mainis = if mainModIs dflags == this_mod then Just mainFunIs else Nothing -- see #5878 -- pkgopts = (homeUnit home_unit, sort $ packageFlags dflags) safeHs = setSafeMode safeHaskell
compiler/GHC/Iface/Rename.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -19,35 +18,40 @@ import GHC.Prelude -import GHC.Types.SrcLoc-import GHC.Utils.Outputable-import GHC.Driver.Types+import GHC.Driver.Session+import GHC.Driver.Env++import GHC.Tc.Utils.Monad++import GHC.Iface.Syntax+import GHC.Iface.Env+import {-# SOURCE #-} GHC.Iface.Load -- a bit vexing+ import GHC.Unit import GHC.Unit.State+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.Deps++import GHC.Types.SrcLoc import GHC.Types.Unique.FM import GHC.Types.Avail-import GHC.Iface.Syntax import GHC.Types.FieldLabel import GHC.Types.Var-import GHC.Utils.Error-+import GHC.Types.Basic import GHC.Types.Name-import GHC.Tc.Utils.Monad+import GHC.Types.Name.Shape++import GHC.Utils.Error+import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Fingerprint import GHC.Utils.Panic-import GHC.Types.Basic --- a bit vexing-import {-# SOURCE #-} GHC.Iface.Load-import GHC.Driver.Session+import GHC.Data.Bag import qualified Data.Traversable as T -import GHC.Data.Bag import Data.IORef-import GHC.Types.Name.Shape-import GHC.Iface.Env tcRnMsgMaybe :: IO (Either ErrorMessages a) -> TcM a tcRnMsgMaybe do_this = do@@ -99,7 +103,7 @@ -- when loading an interface to merge it into a requirement.) rnModIface :: HscEnv -> [(ModuleName, Module)] -> Maybe NameShape -> ModIface -> IO (Either ErrorMessages ModIface)-rnModIface hsc_env insts nsubst iface = do+rnModIface hsc_env insts nsubst iface = initRnIface hsc_env iface insts nsubst $ do mod <- rnModule (mi_module iface) sig_of <- case mi_sig_of iface of@@ -300,7 +304,7 @@ rnIfaceGlobal n = do hsc_env <- getTopEnv let dflags = hsc_dflags hsc_env- home_unit = mkHomeUnitFromFlags dflags+ home_unit = hsc_home_unit hsc_env iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv mb_nsubst <- fmap sh_if_shape getGblEnv hmap <- getHoleSubst
compiler/GHC/Iface/Tidy.hs view
@@ -1,13 +1,14 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 \section{Tidying up Core} -} -{-# LANGUAGE CPP, DeriveFunctor, ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- module GHC.Iface.Tidy ( mkBootModDetailsTc, tidyProgram ) where@@ -16,10 +17,13 @@ import GHC.Prelude -import GHC.Tc.Types import GHC.Driver.Session import GHC.Driver.Backend import GHC.Driver.Ppr+import GHC.Driver.Env++import GHC.Tc.Types+ import GHC.Core import GHC.Core.Unfold import GHC.Core.Unfold.Make@@ -33,36 +37,47 @@ import GHC.Core.PatSyn import GHC.Core.ConLike import GHC.Core.Opt.Arity ( exprArity, exprBotStrictness_maybe )+import GHC.Core.InstEnv+import GHC.Core.Type ( tidyTopType )+import GHC.Core.DataCon+import GHC.Core.TyCon+import GHC.Core.Class+ import GHC.Iface.Tidy.StaticPtrTable+import GHC.Iface.Env++import GHC.Tc.Utils.Env+import GHC.Tc.Utils.Monad++import GHC.Utils.Outputable+import GHC.Utils.Misc( filterOut )+import GHC.Utils.Panic+import qualified GHC.Utils.Error as Err++import GHC.Types.ForeignStubs import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Var import GHC.Types.Id import GHC.Types.Id.Make ( mkDictSelRhs ) import GHC.Types.Id.Info-import GHC.Core.InstEnv-import GHC.Core.Type ( tidyTopType ) import GHC.Types.Demand ( appIsDeadEnd, isTopSig, isDeadEndSig ) import GHC.Types.Cpr ( mkCprSig, botCpr ) import GHC.Types.Basic import GHC.Types.Name hiding (varName) import GHC.Types.Name.Set import GHC.Types.Name.Cache+import GHC.Types.Name.Ppr import GHC.Types.Avail-import GHC.Iface.Env-import GHC.Tc.Utils.Env-import GHC.Tc.Utils.Monad-import GHC.Core.DataCon-import GHC.Core.TyCon-import GHC.Core.Class+import GHC.Types.Unique.Supply+import GHC.Types.TypeEnv+ import GHC.Unit.Module-import GHC.Driver.Types+import GHC.Unit.Module.ModGuts+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.Deps+ import GHC.Data.Maybe-import GHC.Types.Unique.Supply-import GHC.Utils.Outputable-import GHC.Utils.Misc( filterOut )-import GHC.Utils.Panic-import qualified GHC.Utils.Error as Err import Control.Monad import Data.Function@@ -371,7 +386,7 @@ ; expose_all = gopt Opt_ExposeAllUnfoldings dflags ; print_unqual = mkPrintUnqualified (unitState dflags)- (mkHomeUnitFromFlags dflags)+ (hsc_home_unit hsc_env) rdr_env ; implicit_binds = concatMap getImplicitBinds tcs }
compiler/GHC/Iface/Tidy/StaticPtrTable.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE ViewPatterns #-}+ -- | Code generation for the Static Pointer Table -- -- (c) 2014 I/O Tweag@@ -45,7 +47,6 @@ -- > } -- -{-# LANGUAGE ViewPatterns, TupleSections #-} module GHC.Iface.Tidy.StaticPtrTable ( sptCreateStaticBinds , sptModuleInitCode@@ -123,24 +124,30 @@ -} import GHC.Prelude+import GHC.Platform -import GHC.Cmm.CLabel+import GHC.Driver.Session+import GHC.Driver.Env+ import GHC.Core import GHC.Core.Utils (collectMakeStaticArgs) import GHC.Core.DataCon-import GHC.Driver.Session-import GHC.Driver.Types-import GHC.Types.Id import GHC.Core.Make (mkStringExprFSWith)+import GHC.Core.Type++import GHC.Cmm.CLabel+ import GHC.Unit.Module-import GHC.Types.Name import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic-import GHC.Platform import GHC.Builtin.Names import GHC.Tc.Utils.Env (lookupGlobal)-import GHC.Core.Type+import GHC.Runtime.Linker.Types +import GHC.Types.Name+import GHC.Types.Id+import GHC.Types.TyThing+ import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State import Data.List@@ -241,11 +248,11 @@ PW8 -> mkWordLit platform . toInteger lookupIdHscEnv :: Name -> IO Id- lookupIdHscEnv n = lookupTypeHscEnv hsc_env n >>=+ lookupIdHscEnv n = lookupType hsc_env n >>= maybe (getError n) (return . tyThingId) lookupDataConHscEnv :: Name -> IO DataCon- lookupDataConHscEnv n = lookupTypeHscEnv hsc_env n >>=+ lookupDataConHscEnv n = lookupType hsc_env n >>= maybe (getError n) (return . tyThingDataCon) getError n = pprPanic "sptCreateStaticBinds.get: not found" $
compiler/GHC/Iface/UpdateIdInfos.hs view
@@ -8,13 +8,19 @@ import GHC.Core import GHC.Core.InstEnv-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.Types.TypeEnv+import GHC.Types.TyThing++import GHC.Unit.Module.ModDetails+ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic
compiler/GHC/IfaceToCore.hs view
@@ -16,7 +16,8 @@ importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, typecheckIfacesForMerging, typecheckIfaceForInstantiate,- tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,+ tcIfaceDecl, tcIfaceDecls,+ tcIfaceInst, tcIfaceFamInst, tcIfaceRules, tcIfaceAnnotations, tcIfaceCompleteMatches, tcIfaceExpr, -- Desired by HERMIT (#7683) tcIfaceGlobal,@@ -27,22 +28,28 @@ import GHC.Prelude +import GHC.Driver.Env+import GHC.Driver.Session+ import GHC.Builtin.Types.Literals(typeNatCoAxiomRules)+import GHC.Builtin.Types+ 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+ import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.Coercion.Axiom import GHC.Core.FVs import GHC.Core.TyCo.Rep -- needs to build types & coercions in a knot import GHC.Core.TyCo.Subst ( substTyCoVars )-import GHC.Driver.Types-import GHC.Types.Annotations import GHC.Core.InstEnv import GHC.Core.FamInstEnv import GHC.Core@@ -50,34 +57,46 @@ import GHC.Core.Unfold.Make import GHC.Core.Lint import GHC.Core.Make-import GHC.Types.Id-import GHC.Types.Id.Make-import GHC.Types.Id.Info import GHC.Core.Class import GHC.Core.TyCon import GHC.Core.ConLike import GHC.Core.DataCon-import GHC.Builtin.Types-import GHC.Types.Literal-import GHC.Types.Var as Var-import GHC.Types.Var.Set-import GHC.Types.Name-import GHC.Types.Name.Env-import GHC.Types.Name.Set import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )++import GHC.Unit.External import GHC.Unit.Module-import GHC.Types.Unique.FM-import GHC.Types.Unique.DSet ( mkUniqDSet )-import GHC.Types.Unique.Supply+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.ModIface+import GHC.Unit.Home.ModInfo+ import GHC.Utils.Outputable-import GHC.Data.Maybe-import GHC.Types.SrcLoc-import GHC.Driver.Session import GHC.Utils.Misc import GHC.Utils.Panic++import GHC.Data.Maybe import GHC.Data.FastString-import GHC.Types.Basic hiding ( SuccessFlag(..) ) import GHC.Data.List.SetOps++import GHC.Types.Annotations+import GHC.Types.SourceFile+import GHC.Types.SourceText+import GHC.Types.Basic hiding ( SuccessFlag(..) )+import GHC.Types.SrcLoc+import GHC.Types.TypeEnv+import GHC.Types.Unique.FM+import GHC.Types.Unique.DSet ( mkUniqDSet )+import GHC.Types.Unique.Supply+import GHC.Types.Literal+import GHC.Types.Var as Var+import GHC.Types.Var.Set+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Name.Set+import GHC.Types.Id+import GHC.Types.Id.Make+import GHC.Types.Id.Info+import GHC.Types.TyThing+ import GHC.Fingerprint import qualified GHC.Data.BooleanFormula as BF @@ -167,7 +186,7 @@ -- Typecheck the decls. This is done lazily, so that the knot-tying -- within this single module works out right. It's the callers -- job to make sure the knot is tied.- ; names_w_things <- loadDecls ignore_prags (mi_decls iface)+ ; names_w_things <- tcIfaceDecls ignore_prags (mi_decls iface) ; let type_env = mkNameEnv names_w_things -- Now do those rules, instances and annotations@@ -372,8 +391,8 @@ :: [OccEnv IfaceDecl] decl_env = foldl' mergeIfaceDecls emptyOccEnv decl_envs :: OccEnv IfaceDecl- -- TODO: change loadDecls to accept w/o Fingerprint- names_w_things <- loadDecls ignore_prags (map (\x -> (fingerprint0, x))+ -- TODO: change tcIfaceDecls to accept w/o Fingerprint+ names_w_things <- tcIfaceDecls ignore_prags (map (\x -> (fingerprint0, x)) (occEnvElts decl_env)) let global_type_env = mkNameEnv names_w_things writeMutVar tc_env_var global_type_env@@ -381,9 +400,9 @@ -- OK, now typecheck each ModIface using this environment details <- forM ifaces $ \iface -> do -- See Note [Resolving never-exported Names] in GHC.IfaceToCore- type_env <- fixM $ \type_env -> do+ type_env <- fixM $ \type_env -> setImplicitEnvM type_env $ do- decls <- loadDecls ignore_prags (mi_decls iface)+ decls <- tcIfaceDecls ignore_prags (mi_decls iface) return (mkNameEnv decls) -- But note that we use this type_env to typecheck references to DFun -- in 'IfaceInst'@@ -421,9 +440,9 @@ (mi_boot iface) nsubst $ do ignore_prags <- goptM Opt_IgnoreInterfacePragmas -- See Note [Resolving never-exported Names] in GHC.IfaceToCore- type_env <- fixM $ \type_env -> do+ type_env <- fixM $ \type_env -> setImplicitEnvM type_env $ do- decls <- loadDecls ignore_prags (mi_decls iface)+ decls <- tcIfaceDecls ignore_prags (mi_decls iface) return (mkNameEnv decls) -- See Note [rnIfaceNeverExported] setImplicitEnvM type_env $ do@@ -853,6 +872,110 @@ tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm) ; return (id, b) } +tcIfaceDecls :: Bool+ -> [(Fingerprint, IfaceDecl)]+ -> IfL [(Name,TyThing)]+tcIfaceDecls ignore_prags ver_decls+ = concatMapM (tc_iface_decl_fingerprint ignore_prags) ver_decls++tc_iface_decl_fingerprint :: Bool -- Don't load pragmas into the decl pool+ -> (Fingerprint, IfaceDecl)+ -> IfL [(Name,TyThing)] -- The list can be poked eagerly, but the+ -- TyThings are forkM'd thunks+tc_iface_decl_fingerprint ignore_prags (_version, decl)+ = do { -- Populate the name cache with final versions of all+ -- the names associated with the decl+ let main_name = ifName decl++ -- Typecheck the thing, lazily+ -- NB. Firstly, the laziness is there in case we never need the+ -- declaration (in one-shot mode), and secondly it is there so that+ -- we don't look up the occurrence of a name before calling mk_new_bndr+ -- on the binder. This is important because we must get the right name+ -- which includes its nameParent.++ ; thing <- forkM doc $ do { bumpDeclStats main_name+ ; tcIfaceDecl ignore_prags decl }++ -- Populate the type environment with the implicitTyThings too.+ --+ -- Note [Tricky iface loop]+ -- ~~~~~~~~~~~~~~~~~~~~~~~~+ -- Summary: The delicate point here is that 'mini-env' must be+ -- buildable from 'thing' without demanding any of the things+ -- 'forkM'd by tcIfaceDecl.+ --+ -- In more detail: Consider the example+ -- data T a = MkT { x :: T a }+ -- The implicitTyThings of T are: [ <datacon MkT>, <selector x>]+ -- (plus their workers, wrappers, coercions etc etc)+ --+ -- We want to return an environment+ -- [ "MkT" -> <datacon MkT>, "x" -> <selector x>, ... ]+ -- (where the "MkT" is the *Name* associated with MkT, etc.)+ --+ -- We do this by mapping the implicit_names to the associated+ -- TyThings. By the invariant on ifaceDeclImplicitBndrs and+ -- implicitTyThings, we can use getOccName on the implicit+ -- TyThings to make this association: each Name's OccName should+ -- be the OccName of exactly one implicitTyThing. So the key is+ -- to define a "mini-env"+ --+ -- [ 'MkT' -> <datacon MkT>, 'x' -> <selector x>, ... ]+ -- where the 'MkT' here is the *OccName* associated with MkT.+ --+ -- However, there is a subtlety: due to how type checking needs+ -- to be staged, we can't poke on the forkM'd thunks inside the+ -- implicitTyThings while building this mini-env.+ -- If we poke these thunks too early, two problems could happen:+ -- (1) When processing mutually recursive modules across+ -- hs-boot boundaries, poking too early will do the+ -- type-checking before the recursive knot has been tied,+ -- so things will be type-checked in the wrong+ -- environment, and necessary variables won't be in+ -- scope.+ --+ -- (2) Looking up one OccName in the mini_env will cause+ -- others to be looked up, which might cause that+ -- original one to be looked up again, and hence loop.+ --+ -- The code below works because of the following invariant:+ -- getOccName on a TyThing does not force the suspended type+ -- checks in order to extract the name. For example, we don't+ -- poke on the "T a" type of <selector x> on the way to+ -- extracting <selector x>'s OccName. Of course, there is no+ -- reason in principle why getting the OccName should force the+ -- thunks, but this means we need to be careful in+ -- implicitTyThings and its helper functions.+ --+ -- All a bit too finely-balanced for my liking.++ -- This mini-env and lookup function mediates between the+ --'Name's n and the map from 'OccName's to the implicit TyThings+ ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing]+ lookup n = case lookupOccEnv mini_env (getOccName n) of+ Just thing -> thing+ Nothing ->+ pprPanic "tc_iface_decl_fingerprint" (ppr main_name <+> ppr n $$ ppr (decl))++ ; implicit_names <- mapM lookupIfaceTop (ifaceDeclImplicitBndrs decl)++-- ; traceIf (text "Loading decl for " <> ppr main_name $$ ppr implicit_names)+ ; return $ (main_name, thing) :+ -- uses the invariant that implicit_names and+ -- implicitTyThings are bijective+ [(n, lookup n) | n <- implicit_names]+ }+ where+ doc = text "Declaration for" <+> ppr (ifName decl)++bumpDeclStats :: Name -> IfL () -- Record that one more declaration has actually been used+bumpDeclStats name+ = do { traceIf (text "Loading decl for" <+> ppr name)+ ; updateEps_ (\eps -> let stats = eps_stats eps+ in eps { eps_stats = stats { n_decls_out = n_decls_out stats + 1 } })+ }+ tc_fd :: FunDep IfLclName -> IfL (FunDep TyVar) tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1 ; tvs2' <- mapM tcIfaceTyVar tvs2@@ -1133,10 +1256,9 @@ } tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name)-tcIfaceAnnTarget (NamedTarget occ) = do- name <- lookupIfaceTop occ- return $ NamedTarget name-tcIfaceAnnTarget (ModuleTarget mod) = do+tcIfaceAnnTarget (NamedTarget occ) =+ NamedTarget <$> lookupIfaceTop occ+tcIfaceAnnTarget (ModuleTarget mod) = return $ ModuleTarget mod {-@@ -1669,7 +1791,7 @@ where via_external = do { hsc_env <- getTopEnv- ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)+ ; mb_thing <- liftIO (lookupType hsc_env name) ; case mb_thing of { Just thing -> return thing ; Nothing -> do
compiler/GHC/IfaceToCore.hs-boot view
@@ -3,13 +3,15 @@ import GHC.Prelude import GHC.Iface.Syntax ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule , IfaceAnnotation, IfaceCompleteMatch )-import GHC.Core.TyCo.Rep ( TyThing )+import GHC.Types.TyThing ( TyThing ) import GHC.Tc.Types ( IfL ) import GHC.Core.InstEnv ( ClsInst ) import GHC.Core.FamInstEnv ( FamInst ) import GHC.Core ( CoreRule )-import GHC.Driver.Types ( CompleteMatch )+import GHC.Types.CompleteMatch ( CompleteMatch ) import GHC.Types.Annotations ( Annotation )+import GHC.Types.Name+import GHC.Fingerprint.Type tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule]@@ -17,3 +19,4 @@ tcIfaceFamInst :: IfaceFamInst -> IfL FamInst tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation] tcIfaceCompleteMatches :: [IfaceCompleteMatch] -> IfL [CompleteMatch]+tcIfaceDecls :: Bool -> [(Fingerprint, IfaceDecl)] -> IfL [(Name,TyThing)]
compiler/GHC/Llvm/MetaData.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-} module GHC.Llvm.MetaData where
compiler/GHC/Llvm/Types.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} --------------------------------------------------------------------------------
compiler/GHC/Plugins.hs view
@@ -33,7 +33,7 @@ , module GHC.Core.TyCon , module GHC.Core.Coercion , module GHC.Builtin.Types- , module GHC.Driver.Types+ , module GHC.Driver.Env , module GHC.Types.Basic , module GHC.Types.Var.Set , module GHC.Types.Var.Env@@ -51,6 +51,11 @@ , module GHC.Types.Unique.Supply , module GHC.Data.FastString , module GHC.Tc.Errors.Hole.FitTypes -- for hole-fit plugins+ , module GHC.Unit.Module.ModGuts+ , module GHC.Unit.Module.ModSummary+ , module GHC.Unit.Module.ModIface+ , module GHC.Types.Meta+ , module GHC.Types.SourceError , -- * Getting 'Name's thNameToGhcName )@@ -60,6 +65,8 @@ import GHC.Driver.Plugins -- Variable naming+import GHC.Types.TyThing+import GHC.Types.SourceError import GHC.Types.Name.Reader import GHC.Types.Name.Occurrence hiding ( varName {- conflicts with Var.varName -} ) import GHC.Types.Name hiding ( varName {- reexport from OccName, conflicts with Var.varName -} )@@ -78,23 +85,24 @@ import GHC.Core.Subst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst ) -- These names are also exported by Type --- Core "extras" import GHC.Core.Rules import GHC.Types.Annotations+import GHC.Types.Meta --- Pipeline-related stuff import GHC.Driver.Session import GHC.Unit.State --- Important GHC types import GHC.Unit.Module+import GHC.Unit.Module.ModGuts+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.ModIface import GHC.Core.Type hiding {- conflict with GHC.Core.Subst -} ( substTy, extendTvSubst, extendTvSubstList, isInScope ) import GHC.Core.Coercion hiding {- conflict with GHC.Core.Subst -} ( substCo ) import GHC.Core.TyCon import GHC.Builtin.Types-import GHC.Driver.Types+import GHC.Driver.Env import GHC.Types.Basic -- Collections and maps
compiler/GHC/Rename/Bind.hs view
@@ -885,7 +885,7 @@ -> LHsBindsLR GhcRn GhcPs -> RnM (LHsBindsLR GhcRn GhcPs) rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest- = setSrcSpan loc $ do+ = setSrcSpan loc $ do { sel_name <- wrapLocM (lookupInstDeclBndr cls (text "method")) name -- We use the selector name as the binder ; let bind' = bind { fun_id = sel_name, fun_ext = noExtField }@@ -1034,7 +1034,7 @@ new_mty <- traverse lookupLocatedOccRn mty this_mod <- fmap tcg_mod getGblEnv- unless (any (nameIsLocalOrFrom this_mod . unLoc) new_bf) $ do+ unless (any (nameIsLocalOrFrom this_mod . unLoc) new_bf) $ -- Why 'any'? See Note [Orphan COMPLETE pragmas] addErrCtxt (text "In" <+> ppr sig) $ failWithTc orphanError @@ -1173,20 +1173,20 @@ -> RnM (LMatch GhcRn (Located (body GhcRn)), FreeVars) rnMatch ctxt rnBody = wrapLocFstM (rnMatch' ctxt rnBody) +-- Note that there are no local fixity decls for matches rnMatch' :: Outputable (body GhcPs) => HsMatchContext GhcRn -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -> Match GhcPs (Located (body GhcPs)) -> RnM (Match GhcRn (Located (body GhcRn)), FreeVars)-rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss })- = do { -- Note that there are no local fixity decls for matches- ; rnPats ctxt pats $ \ pats' -> do+rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss }) =+ rnPats ctxt pats $ \ pats' -> do { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss ; let mf' = case (ctxt, mf) of- (FunRhs { mc_fun = L _ funid }, FunRhs { mc_fun = L lf _ })- -> mf { mc_fun = L lf funid }- _ -> ctxt+ (FunRhs { mc_fun = L _ funid }, FunRhs { mc_fun = L lf _ }) ->+ mf { mc_fun = L lf funid }+ _ -> ctxt ; return (Match { m_ext = noExtField, m_ctxt = mf', m_pats = pats'- , m_grhss = grhss'}, grhss_fvs ) }}+ , m_grhss = grhss'}, grhss_fvs ) } emptyCaseErr :: HsMatchContext GhcRn -> SDoc emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt)
− compiler/GHC/Rename/Doc.hs
@@ -1,25 +0,0 @@-{-# LANGUAGE ViewPatterns #-}--module GHC.Rename.Doc ( rnHsDoc, rnLHsDoc, rnMbLHsDoc ) where--import GHC.Prelude--import GHC.Tc.Types-import GHC.Hs-import GHC.Types.SrcLoc---rnMbLHsDoc :: Maybe LHsDocString -> RnM (Maybe LHsDocString)-rnMbLHsDoc mb_doc = case mb_doc of- Just doc -> do- doc' <- rnLHsDoc doc- return (Just doc')- Nothing -> return Nothing--rnLHsDoc :: LHsDocString -> RnM LHsDocString-rnLHsDoc (L pos doc) = do- doc' <- rnHsDoc doc- return (L pos doc')--rnHsDoc :: HsDocString -> RnM HsDocString-rnHsDoc = pure
compiler/GHC/Rename/Env.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeApplications #-}+ {- (c) The GRASP/AQUA Project, Glasgow University, 1992-2006 @@ -5,8 +9,6 @@ -} -{-# LANGUAGE CPP, MultiWayIf, NamedFieldPuns #-}- module GHC.Rename.Env ( newTopSrcBinder, lookupLocatedTopBndrRn, lookupTopBndrRn,@@ -54,10 +56,9 @@ import GHC.Iface.Env import GHC.Hs import GHC.Types.Name.Reader-import GHC.Driver.Types import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad-import GHC.Parser.PostProcess ( filterCTuple, setRdrNameSpace )+import GHC.Parser.PostProcess ( setRdrNameSpace ) import GHC.Builtin.RebindableNames import GHC.Builtin.Types import GHC.Types.Name@@ -65,12 +66,14 @@ import GHC.Types.Name.Env import GHC.Types.Avail import GHC.Unit.Module+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.Warnings ( WarningTxt, pprWarningTxtForMsg ) import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Utils.Error ( MsgDoc ) import GHC.Builtin.Names( rOOT_MAIN )-import GHC.Types.Basic ( pprWarningTxtForMsg, TopLevelFlag(..), TupleSort(..) )+import GHC.Types.Basic ( TopLevelFlag(..), TupleSort(..) ) import GHC.Types.SrcLoc as SrcLoc import GHC.Utils.Outputable as Outputable import GHC.Types.Unique.Set ( uniqSetAny )@@ -1005,6 +1008,17 @@ , text "instead of" , quotes (ppr name) <> dot ] +-- If the given RdrName can be promoted to the type level and its promoted variant is in scope,+-- lookup_promoted returns the corresponding type-level Name.+-- Otherwise, the function returns Nothing.+-- See Note [Promotion] below.+lookup_promoted :: RdrName -> RnM (Maybe Name)+lookup_promoted rdr_name+ | Just promoted_rdr <- promoteRdrName rdr_name+ = lookupOccRn_maybe promoted_rdr+ | otherwise+ = return Nothing+ badVarInType :: RdrName -> RnM Name badVarInType rdr_name = do { addErr (text "Illegal promoted term variable in a type:"@@ -1040,6 +1054,26 @@ The final result (after the renamer) will be: HsTyVar ("Zero", DataName)++Note [Promotion]+~~~~~~~~~~~~~~~+When the user mentions a type constructor or a type variable in a+term-level context, then we report that a value identifier was expected+instead of a type-level one. That makes error messages more precise.+Previously, such errors contained only the info that a given value was out of scope (#18740).+We promote the namespace of RdrName and look up after that+(see the functions promotedRdrName and lookup_promoted).++In particular, we have the following error message+ • Illegal term-level use of the type constructor ‘Int’+ imported from ‘Prelude’ (and originally defined in ‘GHC.Types’)+ • In the first argument of ‘id’, namely ‘Int’+ In the expression: id Int+ In an equation for ‘x’: x = id Int++when the user writes the following declaration++ x = id Int -} lookupOccRnX_maybe :: (RdrName -> RnM (Maybe r)) -> (Name -> r) -> RdrName@@ -1054,14 +1088,22 @@ lookupOccRn_overloaded :: Bool -> RdrName -> RnM (Maybe (Either Name [Name]))-lookupOccRn_overloaded overload_ok- = lookupOccRnX_maybe global_lookup Left- where- global_lookup :: RdrName -> RnM (Maybe (Either Name [Name]))- global_lookup n =- runMaybeT . msum . map MaybeT $- [ lookupGlobalOccRn_overloaded overload_ok n- , fmap Left . listToMaybe <$> lookupQualifiedNameGHCi n ]+lookupOccRn_overloaded overload_ok rdr_name+ = do { mb_name <- lookupOccRnX_maybe global_lookup Left rdr_name+ ; case mb_name of+ Nothing -> fmap @Maybe Left <$> lookup_promoted rdr_name+ -- See Note [Promotion].+ -- We try looking up the name as a+ -- type constructor or type variable, if+ -- we failed to look up the name at the term level.+ p -> return p }++ where+ global_lookup :: RdrName -> RnM (Maybe (Either Name [Name]))+ global_lookup n =+ runMaybeT . msum . map MaybeT $+ [ lookupGlobalOccRn_overloaded overload_ok n+ , fmap Left . listToMaybe <$> lookupQualifiedNameGHCi n ]
compiler/GHC/Rename/Expr.hs view
@@ -1,3 +1,12 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -10,16 +19,6 @@ free variables. -} -{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- module GHC.Rename.Expr ( rnLExpr, rnExpr, rnStmts ) where@@ -48,11 +47,12 @@ import GHC.Driver.Session import GHC.Builtin.Names -import GHC.Types.Basic+import GHC.Types.Fixity import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Reader import GHC.Types.Unique.Set+import GHC.Types.SourceText import Data.List import Data.Maybe (isJust, isNothing) import GHC.Utils.Misc@@ -108,16 +108,16 @@ ; return (HsVar noExtField (L l name), unitFV name) } rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars)-rnUnboundVar v- = do { if isUnqual v- then -- Treat this as a "hole"- -- Do not fail right now; instead, return HsUnboundVar- -- and let the type checker report the error- return (HsUnboundVar noExtField (rdrNameOcc v), emptyFVs)+rnUnboundVar v =+ if isUnqual v+ then -- Treat this as a "hole"+ -- Do not fail right now; instead, return HsUnboundVar+ -- and let the type checker report the error+ return (HsUnboundVar noExtField (rdrNameOcc v), emptyFVs) - else -- Fail immediately (qualified name)- do { n <- reportUnboundName v- ; return (HsVar noExtField (noLoc n), emptyFVs) } }+ else -- Fail immediately (qualified name)+ do { n <- reportUnboundName v+ ; return (HsVar noExtField (noLoc n), emptyFVs) } rnExpr (HsVar _ (L l v)) = do { opt_DuplicateRecordFields <- xoptM LangExt.DuplicateRecordFields@@ -282,7 +282,6 @@ rnExpr (ExplicitTuple x tup_args boxity) = do { checkTupleSection tup_args- ; checkTupSize (length tup_args) ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args ; return (ExplicitTuple x tup_args' boxity, plusFVs fvs) } where@@ -848,10 +847,10 @@ -- but it does not matter because the names are unique rnStmt _ _ (L loc (LetStmt _ (L l binds))) thing_inside- = do { rnLocalBindsAndThen binds $ \binds' bind_fvs -> do+ = rnLocalBindsAndThen binds $ \binds' bind_fvs -> do { (thing, fvs) <- thing_inside (collectLocalBinders binds') ; return ( ([(L loc (LetStmt noExtField (L l binds')), bind_fvs)], thing)- , fvs) } }+ , fvs) } rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside = do { (return_op, fvs1) <- lookupQualifiedDoStmtName ctxt returnMName
compiler/GHC/Rename/Fixity.hs view
@@ -1,11 +1,8 @@-{-# LANGUAGE ViewPatterns #-}- {-- This module contains code which maintains and manipulates the fixity environment during renaming.- -}+ module GHC.Rename.Fixity ( MiniFixityEnv , addLocalFixities@@ -13,28 +10,34 @@ , lookupFixityRn_help , lookupFieldFixityRn , lookupTyFixityRn- )-where+ ) where import GHC.Prelude import GHC.Iface.Load import GHC.Hs-import GHC.Types.Name.Reader-import GHC.Driver.Types import GHC.Tc.Utils.Monad++import GHC.Unit.Module+import GHC.Unit.Module.ModIface++import GHC.Types.Fixity.Env import GHC.Types.Name import GHC.Types.Name.Env-import GHC.Unit.Module-import GHC.Types.Basic ( Fixity(..), FixityDirection(..), minPrecedence,- defaultFixity, SourceText(..) )+import GHC.Types.Name.Reader+import GHC.Types.Fixity+import GHC.Types.SourceText import GHC.Types.SrcLoc+ import GHC.Utils.Outputable import GHC.Utils.Panic+ import GHC.Data.Maybe++import GHC.Rename.Unbound+ import Data.List import Data.Function ( on )-import GHC.Rename.Unbound {- *********************************************************
compiler/GHC/Rename/HsType.hs view
@@ -1,13 +1,12 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+ {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TypeFamilies #-}- module GHC.Rename.HsType ( -- Type related stuff rnHsType, rnLHsType, rnLHsTypes, rnContext,@@ -30,7 +29,8 @@ rnImplicitBndrs, bindSigTyVarsFV, bindHsQTyVars, FreeKiTyVars, extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,- extractHsTysRdrTyVars, extractRdrKindSigVars, extractDataDefnKindVars,+ extractHsTysRdrTyVars, extractRdrKindSigVars,+ extractConDeclGADTDetailsTyVars, extractDataDefnKindVars, extractHsTvBndrs, extractHsTyArgRdrKiTyVars, forAllOrNothing, nubL ) where@@ -41,7 +41,6 @@ import GHC.Driver.Session import GHC.Hs-import GHC.Rename.Doc ( rnLHsDoc, rnMbLHsDoc ) import GHC.Rename.Env import GHC.Rename.Utils ( HsDocContext(..), inHsDocContext, withHsDocContext , mapFvRn, pprHsDocContext, bindLocalNamesFV@@ -58,9 +57,9 @@ import GHC.Types.FieldLabel import GHC.Utils.Misc-import GHC.Types.Basic ( compareFixity, negateFixity- , Fixity(..), FixityDirection(..), LexicalFixity(..)- , TypeOrKind(..) )+import GHC.Types.Fixity ( compareFixity, negateFixity+ , Fixity(..), FixityDirection(..), LexicalFixity(..) )+import GHC.Types.Basic ( TypeOrKind(..) ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Data.FastString@@ -442,9 +441,9 @@ rnHsType is here because we call it from loadInstDecl, and I didn't want a gratuitous knot. -Note [QualTy in kinds]+Note [HsQualTy in kinds] ~~~~~~~~~~~~~~~~~~~~~~-I was wondering whether QualTy could occur only at TypeLevel. But no,+I was wondering whether HsQualTy could occur only at TypeLevel. But no, we can have a qualified type in a kind too. Here is an example: type family F a where@@ -467,9 +466,9 @@ Expected kind: G Bool Actual kind: F Bool -However: in a kind, the constraints in the QualTy must all be+However: in a kind, the constraints in the HsQualTy must all be equalities; or at least, any kinds with a class constraint are-uninhabited.+uninhabited. See Note [Constraints in kinds] in GHC.Core.TyCo.Rep. -} data RnTyKiEnv@@ -575,7 +574,9 @@ , fvs) } } rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau })- = do { checkPolyKinds env ty -- See Note [QualTy in kinds]+ = do { data_kinds <- xoptM LangExt.DataKinds -- See Note [HsQualTy in kinds]+ ; when (not data_kinds && isRnKindLevel env)+ (addErr (dataKindsErr env ty)) ; (ctxt', fvs1) <- rnTyKiContext env lctxt ; (tau', fvs2) <- rnLHsTyKi env tau ; return (HsQualTy { hst_xqual = noExtField, hst_ctxt = ctxt'@@ -623,11 +624,11 @@ 2 (ppr ty)) ; return [] } -rnHsTyKi env (HsFunTy _ mult ty1 ty2)+rnHsTyKi env (HsFunTy u mult ty1 ty2) = do { (ty1', fvs1) <- rnLHsTyKi env ty1 ; (ty2', fvs2) <- rnLHsTyKi env ty2 ; (mult', w_fvs) <- rnHsArrow env mult- ; return (HsFunTy noExtField mult' ty1' ty2'+ ; return (HsFunTy u mult' ty1' ty2' , plusFVs [fvs1, fvs2, w_fvs]) } rnHsTyKi env listTy@(HsListTy _ ty)@@ -637,9 +638,8 @@ ; (ty', fvs) <- rnLHsTyKi env ty ; return (HsListTy noExtField ty', fvs) } -rnHsTyKi env t@(HsKindSig _ ty k)- = do { checkPolyKinds env t- ; kind_sigs_ok <- xoptM LangExt.KindSignatures+rnHsTyKi env (HsKindSig _ ty k)+ = do { kind_sigs_ok <- xoptM LangExt.KindSignatures ; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty) ; (ty', lhs_fvs) <- rnLHsTyKi env ty ; (k', sig_fvs) <- rnLHsTyKi (env { rtke_level = KindLevel }) k@@ -666,7 +666,6 @@ = do { data_kinds <- xoptM LangExt.DataKinds ; unless data_kinds (addErr (dataKindsErr env tyLit)) ; when (negLit t) (addErr negLitErr)- ; checkPolyKinds env tyLit ; return (HsTyLit noExtField t, emptyFVs) } where negLit (HsStrTy _ _) = False@@ -698,8 +697,7 @@ rnHsTyKi env (HsDocTy _ ty haddock_doc) = do { (ty', fvs) <- rnLHsTyKi env ty- ; haddock_doc' <- rnLHsDoc haddock_doc- ; return (HsDocTy noExtField ty' haddock_doc', fvs) }+ ; return (HsDocTy noExtField ty' haddock_doc, fvs) } rnHsTyKi _ (XHsType (NHsCoreTy ty)) = return (XHsType (NHsCoreTy ty), emptyFVs)@@ -707,15 +705,13 @@ -- but I don't think it matters rnHsTyKi env ty@(HsExplicitListTy _ ip tys)- = do { checkPolyKinds env ty- ; data_kinds <- xoptM LangExt.DataKinds+ = do { data_kinds <- xoptM LangExt.DataKinds ; unless data_kinds (addErr (dataKindsErr env ty)) ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys ; return (HsExplicitListTy noExtField ip tys', fvs) } rnHsTyKi env ty@(HsExplicitTupleTy _ tys)- = do { checkPolyKinds env ty- ; data_kinds <- xoptM LangExt.DataKinds+ = do { data_kinds <- xoptM LangExt.DataKinds ; unless data_kinds (addErr (dataKindsErr env ty)) ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys ; return (HsExplicitTupleTy noExtField tys', fvs) }@@ -725,10 +721,10 @@ ; 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+rnHsArrow _env (HsUnrestrictedArrow u) = return (HsUnrestrictedArrow u, emptyFVs)+rnHsArrow _env (HsLinearArrow u) = return (HsLinearArrow u, emptyFVs)+rnHsArrow env (HsExplicitMult u p)+ = (\(mult, fvs) -> (HsExplicitMult u mult, fvs)) <$> rnLHsTyKi env p -------------- rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name@@ -1168,8 +1164,7 @@ rnField fl_env env (L l (ConDeclField _ names ty haddock_doc)) = do { let new_names = map (fmap lookupField) names ; (new_ty, fvs) <- rnLHsTyKi env ty- ; new_haddock_doc <- rnMbLHsDoc haddock_doc- ; return (L l (ConDeclField noExtField new_names new_ty new_haddock_doc)+ ; return (L l (ConDeclField noExtField new_names new_ty haddock_doc) , fvs) } where lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn@@ -1768,8 +1763,8 @@ -- | 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.-extractHsTysRdrTyVars :: [LHsType GhcPs] -> FreeKiTyVars-extractHsTysRdrTyVars tys = extract_ltys tys []+extractHsTysRdrTyVars :: [LHsType GhcPs] -> FreeKiTyVars -> FreeKiTyVars+extractHsTysRdrTyVars tys = extract_ltys tys -- Returns the free kind variables of any explicitly-kinded binders, returning -- variable occurrences in left-to-right order.@@ -1789,6 +1784,15 @@ TyVarSig _ (L _ (KindedTyVar _ _ _ k)) -> extractHsTyRdrTyVars k _ -> [] +-- | Extracts free type and kind variables from an argument in a GADT+-- constructor, returning variable occurrences in left-to-right order.+-- See @Note [Ordering of implicit variables]@.+extractConDeclGADTDetailsTyVars ::+ HsConDeclGADTDetails GhcPs -> FreeKiTyVars -> FreeKiTyVars+extractConDeclGADTDetailsTyVars con_args = case con_args of+ PrefixConGADT args -> extract_scaled_ltys args+ RecConGADT (L _ flds) -> extract_ltys $ map (cd_fld_type . unLoc) $ flds+ -- | Get type/kind variables mentioned in the kind signature, preserving -- left-to-right order: --@@ -1803,6 +1807,14 @@ extract_lctxt :: LHsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars extract_lctxt ctxt = extract_ltys (unLoc ctxt) +extract_scaled_ltys :: [HsScaled GhcPs (LHsType GhcPs)]+ -> FreeKiTyVars -> FreeKiTyVars+extract_scaled_ltys args acc = foldr extract_scaled_lty acc args++extract_scaled_lty :: HsScaled GhcPs (LHsType GhcPs)+ -> FreeKiTyVars -> FreeKiTyVars+extract_scaled_lty (HsScaled m ty) acc = extract_lty ty $ extract_hs_arrow m acc+ extract_ltys :: [LHsType GhcPs] -> FreeKiTyVars -> FreeKiTyVars extract_ltys tys acc = foldr extract_lty acc tys @@ -1849,7 +1861,7 @@ extract_hs_arrow :: HsArrow GhcPs -> FreeKiTyVars -> FreeKiTyVars-extract_hs_arrow (HsExplicitMult p) acc = extract_lty p acc+extract_hs_arrow (HsExplicitMult _ p) acc = extract_lty p acc extract_hs_arrow _ acc = acc extract_hs_for_all_telescope :: HsForAllTelescope GhcPs
compiler/GHC/Rename/Module.hs view
@@ -1,18 +1,17 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 Main pass of renamer -} -{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- module GHC.Rename.Module ( rnSrcDecls, addTcgDUs, findSplice ) where@@ -38,13 +37,12 @@ , addNoNestedForallsContextsErr, checkInferredVars ) import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr ) import GHC.Rename.Names-import GHC.Rename.Doc ( rnHsDoc, rnMbLHsDoc ) import GHC.Tc.Gen.Annotation ( annCtxt ) import GHC.Tc.Utils.Monad import GHC.Types.ForeignCall ( CCallTarget(..) ) import GHC.Unit-import GHC.Driver.Types ( Warnings(..), plusWarns )+import GHC.Unit.Module.Warnings import GHC.Builtin.Names( applicativeClassName, pureAName, thenAName , monadClassName, returnMName, thenMName , semigroupClassName, sappendName@@ -62,7 +60,7 @@ import GHC.Driver.Session import GHC.Utils.Misc ( debugIsOn, lengthExceeds, partitionWith ) import GHC.Utils.Panic-import GHC.Driver.Types ( HscEnv, hsc_dflags )+import GHC.Driver.Env ( HscEnv(..)) import GHC.Data.List.SetOps ( findDupsEq, removeDups, equivClasses ) import GHC.Data.Graph.Directed ( SCC, flattenSCC, flattenSCCs, Node(..) , stronglyConnCompFromEdgedVerticesUniq )@@ -199,8 +197,6 @@ (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl default_decls ; (rn_deriv_decls, src_fvs6) <- rnList rnSrcDerivDecl deriv_decls ; (rn_splice_decls, src_fvs7) <- rnList rnSpliceDecl splice_decls ;- -- Haddock docs; no free vars- rn_docs <- mapM (wrapLocM rnDocDecl) docs ; last_tcg_env <- getGblEnv ; -- (I) Compute the results and return@@ -216,7 +212,7 @@ hs_annds = rn_ann_decls, hs_defds = rn_default_decls, hs_ruleds = rn_rule_decls,- hs_docs = rn_docs } ;+ hs_docs = docs } ; tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ; other_def = (Just (mkNameSet tcf_bndrs), emptyNameSet) ;@@ -248,28 +244,6 @@ {- ********************************************************* * *- HsDoc stuff-* *-*********************************************************--}--rnDocDecl :: DocDecl -> RnM DocDecl-rnDocDecl (DocCommentNext doc) = do- rn_doc <- rnHsDoc doc- return (DocCommentNext rn_doc)-rnDocDecl (DocCommentPrev doc) = do- rn_doc <- rnHsDoc doc- return (DocCommentPrev rn_doc)-rnDocDecl (DocCommentNamed str doc) = do- rn_doc <- rnHsDoc doc- return (DocCommentNamed str rn_doc)-rnDocDecl (DocGroup lev doc) = do- rn_doc <- rnHsDoc doc- return (DocGroup lev rn_doc)--{--*********************************************************-* * Source-code deprecations declarations * * *********************************************************@@ -375,7 +349,7 @@ ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty -- Mark any PackageTarget style imports as coming from the current package- ; let home_unit = mkHomeUnitFromFlags (hsc_dflags topEnv)+ ; let home_unit = hsc_home_unit topEnv spec' = patchForeignImport (homeUnitAsUnit home_unit) spec ; return (ForeignImport { fd_i_ext = noExtField@@ -453,10 +427,12 @@ checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM () checkCanonicalInstances cls poly_ty mbinds = do whenWOptM Opt_WarnNonCanonicalMonadInstances- checkCanonicalMonadInstances+ $ checkCanonicalMonadInstances+ "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return" whenWOptM Opt_WarnNonCanonicalMonoidInstances- checkCanonicalMonoidInstances+ $ checkCanonicalMonoidInstances+ "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid" where -- | Warn about unsound/non-canonical 'Applicative'/'Monad' instance@@ -472,33 +448,33 @@ -- * Warn if 'pure' is defined backwards (i.e. @pure = return@). -- * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@). --- checkCanonicalMonadInstances- | cls == applicativeClassName = do- forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do+ checkCanonicalMonadInstances refURL+ | cls == applicativeClassName =+ forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ case mbind of FunBind { fun_id = L _ name , fun_matches = mg } | name == pureAName, isAliasMG mg == Just returnMName- -> addWarnNonCanonicalMethod1+ -> addWarnNonCanonicalMethod1 refURL Opt_WarnNonCanonicalMonadInstances "pure" "return" | name == thenAName, isAliasMG mg == Just thenMName- -> addWarnNonCanonicalMethod1+ -> addWarnNonCanonicalMethod1 refURL Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)" _ -> return () - | cls == monadClassName = do- forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do+ | cls == monadClassName =+ forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ case mbind of FunBind { fun_id = L _ name , fun_matches = mg } | name == returnMName, isAliasMG mg /= Just pureAName- -> addWarnNonCanonicalMethod2+ -> addWarnNonCanonicalMethod2 refURL Opt_WarnNonCanonicalMonadInstances "return" "pure" | name == thenMName, isAliasMG mg /= Just thenAName- -> addWarnNonCanonicalMethod2+ -> addWarnNonCanonicalMethod2 refURL Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)" _ -> return ()@@ -518,26 +494,27 @@ -- -- * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@). --- checkCanonicalMonoidInstances- | cls == semigroupClassName = do- forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do+ checkCanonicalMonoidInstances refURL+ | cls == semigroupClassName =+ forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ case mbind of FunBind { fun_id = L _ name , fun_matches = mg } | name == sappendName, isAliasMG mg == Just mappendName- -> addWarnNonCanonicalMethod1+ -> addWarnNonCanonicalMethod1 refURL Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend" _ -> return () - | cls == monoidClassName = do- forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do+ | cls == monoidClassName =+ forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ case mbind of FunBind { fun_id = L _ name , fun_matches = mg } | name == mappendName, isAliasMG mg /= Just sappendName- -> addWarnNonCanonicalMethod2NoDefault- Opt_WarnNonCanonicalMonoidInstances "mappend" "(<>)"+ -> addWarnNonCanonicalMethod2 refURL+ Opt_WarnNonCanonicalMonoidInstances+ "mappend" "(<>)" _ -> return () @@ -554,7 +531,7 @@ isAliasMG _ = Nothing -- got "lhs = rhs" but expected something different- addWarnNonCanonicalMethod1 flag lhs rhs = do+ addWarnNonCanonicalMethod1 refURL flag lhs rhs = addWarn (Reason flag) $ vcat [ text "Noncanonical" <+> quotes (text (lhs ++ " = " ++ rhs)) <+>@@ -563,29 +540,26 @@ , text "Move definition from" <+> quotes (text rhs) <+> text "to" <+> quotes (text lhs)+ , text "See also:" <+>+ text refURL ] -- expected "lhs = rhs" but got something else- addWarnNonCanonicalMethod2 flag lhs rhs = do+ addWarnNonCanonicalMethod2 refURL flag lhs rhs = addWarn (Reason flag) $ vcat [ text "Noncanonical" <+> quotes (text lhs) <+> text "definition detected" , instDeclCtxt1 poly_ty+ , quotes (text lhs) <+>+ text "will eventually be removed in favour of" <+>+ quotes (text rhs) , text "Either remove definition for" <+>- quotes (text lhs) <+> text "or define as" <+>- quotes (text (lhs ++ " = " ++ rhs))- ]-- -- like above, but method has no default impl- addWarnNonCanonicalMethod2NoDefault flag lhs rhs = do- addWarn (Reason flag) $ vcat- [ text "Noncanonical" <+>- quotes (text lhs) <+>- text "definition detected"- , instDeclCtxt1 poly_ty- , text "Define as" <+>+ quotes (text lhs) <+> text "(recommended)" <+>+ text "or define as" <+> quotes (text (lhs ++ " = " ++ rhs))+ , text "See also:" <+>+ text refURL ] -- stolen from GHC.Tc.TyCl.Instance@@ -1770,15 +1744,12 @@ -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn -- and the methods are already in scope - -- Haddock docs- ; docs' <- mapM (wrapLocM rnDocDecl) docs- ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls', tcdTyVars = tyvars', tcdFixity = fixity, tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',- tcdDocs = docs', tcdCExt = all_fvs },+ tcdDocs = docs, tcdCExt = all_fvs }, all_fvs ) } where cls_doc = ClassDeclCtx lcls@@ -2196,7 +2167,6 @@ , con_doc = mb_doc, con_forall = forall }) = do { _ <- addLocM checkConName name ; new_name <- lookupLocatedTopBndrRn name- ; mb_doc' <- rnMbLHsDoc mb_doc -- We bind no implicit binders here; this is just like -- a nested HsForAllTy. E.g. consider@@ -2211,7 +2181,7 @@ ; 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+ ; (new_args, fvs2) <- rnConDeclH98Details (unLoc new_name) ctxt args ; let all_fvs = fvs1 `plusFV` fvs2 ; traceRn "rnConDecl (ConDeclH98)" (ppr name <+> vcat [ text "ex_tvs:" <+> ppr ex_tvs@@ -2220,7 +2190,7 @@ ; return (decl { con_ext = noExtField , con_name = new_name, con_ex_tvs = new_ex_tvs , con_mb_cxt = new_context, con_args = new_args- , con_doc = mb_doc'+ , con_doc = mb_doc , con_forall = forall }, -- Remove when #18311 is fixed all_fvs) }} @@ -2228,16 +2198,12 @@ , con_forall = forall@(L _ explicit_forall) , con_qvars = explicit_tkvs , con_mb_cxt = mcxt- , con_args = args+ , con_g_args = args , con_res_ty = res_ty , con_doc = mb_doc }) = do { mapM_ (addLocM checkConName) names ; new_names <- mapM lookupLocatedTopBndrRn names- ; mb_doc' <- rnMbLHsDoc mb_doc - ; let theta = hsConDeclTheta mcxt- arg_tys = hsConDeclArgTys args- -- We must ensure that we extract the free tkvs in left-to-right -- order of their appearance in the constructor type. -- That order governs the order the implicitly-quantified type@@ -2245,7 +2211,9 @@ -- See #14808. ; implicit_bndrs <- forAllOrNothing explicit_forall $ extractHsTvBndrs explicit_tkvs- $ extractHsTysRdrTyVars (theta ++ map hsScaledThing arg_tys ++ [res_ty])+ $ extractHsTysRdrTyVars (hsConDeclTheta mcxt)+ $ extractConDeclGADTDetailsTyVars args+ $ extractHsTyRdrTyVars res_ty ; let ctxt = ConDeclCtx new_names @@ -2253,7 +2221,7 @@ 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_args, fvs2) <- rnConDeclGADTDetails (unLoc (head new_names)) ctxt args ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty -- Ensure that there are no nested `forall`s or contexts, per@@ -2268,8 +2236,8 @@ (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 = new_args, con_res_ty = new_res_ty- , con_doc = mb_doc'+ , con_g_args = new_args, con_res_ty = new_res_ty+ , con_doc = mb_doc , con_forall = forall }, -- Remove when #18311 is fixed all_fvs) } } @@ -2279,27 +2247,45 @@ rnMbContext doc (Just cxt) = do { (ctx',fvs) <- rnContext doc cxt ; return (Just ctx',fvs) } -rnConDeclDetails- :: Name+rnConDeclH98Details ::+ Name -> HsDocContext- -> HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (Located [LConDeclField GhcPs])- -> RnM ((HsConDetails (HsScaled GhcRn (LHsType GhcRn))) (Located [LConDeclField GhcRn]),- FreeVars)-rnConDeclDetails _ doc (PrefixCon tys)+ -> HsConDeclH98Details GhcPs+ -> RnM (HsConDeclH98Details GhcRn, FreeVars)+rnConDeclH98Details _ doc (PrefixCon tys) = do { (new_tys, fvs) <- mapFvRn (rnScaledLHsType doc) tys ; return (PrefixCon new_tys, fvs) }--rnConDeclDetails _ doc (InfixCon ty1 ty2)+rnConDeclH98Details _ doc (InfixCon ty1 ty2) = do { (new_ty1, fvs1) <- rnScaledLHsType doc ty1 ; (new_ty2, fvs2) <- rnScaledLHsType doc ty2 ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }+rnConDeclH98Details con doc (RecCon flds)+ = do { (new_flds, fvs) <- rnRecConDeclFields con doc flds+ ; return (RecCon new_flds, fvs) } -rnConDeclDetails con doc (RecCon (L l fields))+rnConDeclGADTDetails ::+ Name+ -> HsDocContext+ -> HsConDeclGADTDetails GhcPs+ -> RnM (HsConDeclGADTDetails GhcRn, FreeVars)+rnConDeclGADTDetails _ doc (PrefixConGADT tys)+ = do { (new_tys, fvs) <- mapFvRn (rnScaledLHsType doc) tys+ ; return (PrefixConGADT new_tys, fvs) }+rnConDeclGADTDetails con doc (RecConGADT flds)+ = do { (new_flds, fvs) <- rnRecConDeclFields con doc flds+ ; return (RecConGADT new_flds, fvs) }++rnRecConDeclFields ::+ Name+ -> HsDocContext+ -> Located [LConDeclField GhcPs]+ -> RnM (Located [LConDeclField GhcRn], FreeVars)+rnRecConDeclFields con doc (L l fields) = do { fls <- lookupConstructorFields con ; (new_fields, fvs) <- rnConDeclFields doc fls fields -- No need to check for duplicate fields -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn- ; return (RecCon (L l new_fields), fvs) }+ ; pure (L l new_fields, fvs) } -------------------------------------------------
compiler/GHC/Rename/Names.hs view
@@ -34,38 +34,54 @@ import GHC.Prelude +import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Ppr-import GHC.Core.TyCo.Ppr-import GHC.Hs-import GHC.Tc.Utils.Env+ import GHC.Rename.Env import GHC.Rename.Fixity import GHC.Rename.Utils ( warnUnusedTopBinds, mkFieldEnv )-import GHC.Iface.Load ( loadSrcInterface )++import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad++import GHC.Hs+import GHC.Iface.Load ( loadSrcInterface ) import GHC.Builtin.Names-import GHC.Unit+import GHC.Parser.PostProcess ( setRdrNameSpace )+import GHC.Core.Type+import GHC.Core.PatSyn+import GHC.Core.TyCo.Ppr+import qualified GHC.LanguageExtensions as LangExt++import GHC.Utils.Outputable as Outputable+import GHC.Utils.Misc as Utils+import GHC.Utils.Panic++import GHC.Types.Fixity.Env+import GHC.Types.SafeHaskell import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set+import GHC.Types.Name.Reader import GHC.Types.Avail import GHC.Types.FieldLabel-import GHC.Driver.Types-import GHC.Types.Name.Reader-import GHC.Parser.PostProcess ( setRdrNameSpace )-import GHC.Utils.Outputable as Outputable-import GHC.Data.Maybe+import GHC.Types.SourceFile import GHC.Types.SrcLoc as SrcLoc-import GHC.Types.Basic ( TopLevelFlag(..), StringLiteral(..) )-import GHC.Utils.Misc as Utils-import GHC.Utils.Panic+import GHC.Types.Basic ( TopLevelFlag(..) )+import GHC.Types.SourceText+import GHC.Types.Id+import GHC.Types.HpcInfo++import GHC.Unit+import GHC.Unit.Module.Warnings+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.Imported+import GHC.Unit.Module.Deps++import GHC.Data.Maybe import GHC.Data.FastString import GHC.Data.FastString.Env-import GHC.Types.Id-import GHC.Core.Type-import GHC.Core.PatSyn-import qualified GHC.LanguageExtensions as LangExt import Control.Monad import Data.Either ( partitionEithers, isRight, rights )@@ -365,7 +381,9 @@ || (not implicit && safeDirectImpsReq dflags) || (implicit && safeImplicitImpsReq dflags) - let imv = ImportedModsVal+ hsc_env <- getTopEnv+ let home_unit = hsc_home_unit hsc_env+ imv = ImportedModsVal { imv_name = qual_mod_name , imv_span = loc , imv_is_safe = mod_safe'@@ -373,7 +391,7 @@ , imv_all_exports = potential_gres , imv_qualified = qual_only }- imports = calculateAvails dflags iface mod_safe' want_boot (ImportedByUser imv)+ imports = calculateAvails home_unit iface mod_safe' want_boot (ImportedByUser imv) -- Complain if we import a deprecated module whenWOptM Opt_WarnWarningsDeprecations (@@ -395,13 +413,13 @@ -- | Calculate the 'ImportAvails' induced by an import of a particular -- interface, but without 'imp_mods'.-calculateAvails :: DynFlags+calculateAvails :: HomeUnit -> ModIface -> IsSafeImport -> IsBootInterface -> ImportedBy -> ImportAvails-calculateAvails dflags iface mod_safe' want_boot imported_by =+calculateAvails home_unit iface mod_safe' want_boot imported_by = let imp_mod = mi_module iface imp_sem_mod= mi_semantic_module iface orph_iface = mi_orphan (mi_final_exts iface)@@ -451,8 +469,6 @@ -- to be trusted? See Note [Trust Own Package] ptrust = trust == Sf_Trustworthy || trust_pkg - home_unit = mkHomeUnitFromFlags dflags- (dependent_mods, dependent_pkgs, pkg_trust_req) | isHomeUnit home_unit pkg = -- Imported module is from the home package@@ -552,7 +568,7 @@ Note [Top-level Names in Template Haskell decl quotes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See also: Note [Interactively-bound Ids in GHCi] in GHC.Driver.Types+See also: Note [Interactively-bound Ids in GHCi] in GHC.Driver.Env Note [Looking up Exact RdrNames] in GHC.Rename.Env Consider a Template Haskell declaration quotation like this:@@ -759,7 +775,7 @@ = [( find_con_name rdr , concatMap find_con_decl_flds (unLoc cdflds) )] find_con_flds (L _ (ConDeclGADT { con_names = rdrs- , con_args = RecCon flds }))+ , con_g_args = RecConGADT flds })) = [ ( find_con_name rdr , concatMap find_con_decl_flds (unLoc flds)) | L _ rdr <- rdrs ]@@ -1009,7 +1025,7 @@ -- different parents). See Note [Dealing with imports] lookup_ie :: IE GhcPs -> IELookupM ([(IE GhcRn, AvailInfo)], [IELookupWarning])- lookup_ie ie = handle_bad_import $ do+ lookup_ie ie = handle_bad_import $ case ie of IEVar _ (L l n) -> do (name, avail, _) <- lookup_name ie $ ieWrappedName n
compiler/GHC/Rename/Pat.hs view
@@ -1,3 +1,14 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -9,18 +20,6 @@ general, all of these functions return a renamed thing, and a set of free variables. -}--{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE DeriveFunctor #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- module GHC.Rename.Pat (-- main entry points rnPat, rnPats, rnBindPat, rnPatAndThen, @@ -38,8 +37,8 @@ -- Literals rnLit, rnOverLit, - -- Pattern Error messages that are also used elsewhere- checkTupSize, patSigErr+ -- Pattern Error message that is also used elsewhere+ patSigErr ) where -- ENH: thin imports to only what is necessary for patterns@@ -60,13 +59,14 @@ , warnUnusedMatches, newLocalBndrRn , checkUnusedRecordWildcard , checkDupNames, checkDupAndShadowedNames- , checkTupSize , unknownSubordinateErr )+ , unknownSubordinateErr ) import GHC.Rename.HsType import GHC.Builtin.Names import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Reader import GHC.Types.Basic+import GHC.Types.SourceText import GHC.Utils.Misc import GHC.Data.List.SetOps( removeDups ) import GHC.Utils.Outputable@@ -161,8 +161,8 @@ g _ = T1 Arguably we should report T2 as unused, even though it appears in a-pattern, because it never occurs in a constructed position. See-#7336.+pattern, because it never occurs in a constructed position.+See #7336. However, implementing this in the face of pattern synonyms would be less straightforward, since given two pattern synonyms @@ -498,8 +498,7 @@ False -> return (ListPat Nothing pats') } rnPatAndThen mk (TuplePat x pats boxed)- = do { liftCps $ checkTupSize (length pats)- ; pats' <- rnLPatsAndThen mk pats+ = do { pats' <- rnLPatsAndThen mk pats ; return (TuplePat x pats' boxed) } rnPatAndThen mk (SumPat x pat alt arity)
compiler/GHC/Rename/Splice.hs view
@@ -1,6 +1,5 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -27,7 +26,8 @@ import GHC.Rename.Unbound ( isUnboundName ) import GHC.Rename.Module ( rnSrcDecls, findSplice ) import GHC.Rename.Pat ( rnPat )-import GHC.Types.Basic ( TopLevelFlag, isTopLevel, SourceText(..) )+import GHC.Types.Basic ( TopLevelFlag, isTopLevel )+import GHC.Types.SourceText ( SourceText(..) ) import GHC.Utils.Outputable import GHC.Unit.Module import GHC.Types.SrcLoc@@ -37,17 +37,16 @@ import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr ) -import GHC.Tc.Utils.Env ( checkWellStaged )-import GHC.Builtin.Names.TH ( liftName )+import GHC.Tc.Utils.Env ( checkWellStaged, tcMetaTy ) import GHC.Driver.Session import GHC.Data.FastString import GHC.Utils.Error ( dumpIfSet_dyn_printer, DumpFormat (..) ) import GHC.Utils.Panic-import GHC.Tc.Utils.Env ( tcMetaTy ) import GHC.Driver.Hooks-import GHC.Builtin.Names.TH ( quoteExpName, quotePatName, quoteDecName, quoteTypeName- , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, )+import GHC.Builtin.Names.TH ( decsQTyConName, expQTyConName, liftName+ , patQTyConName, quoteDecName, quoteExpName+ , quotePatName, quoteTypeName, typeQTyConName) import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcCheckPolyExpr ) import {-# SOURCE #-} GHC.Tc.Gen.Splice
compiler/GHC/Rename/Unbound.hs view
@@ -20,22 +20,28 @@ import GHC.Prelude -import GHC.Types.Name.Reader-import GHC.Driver.Types+import GHC.Driver.Session+import GHC.Driver.Ppr+ import GHC.Tc.Utils.Monad-import GHC.Types.Name-import GHC.Unit.Module-import GHC.Types.SrcLoc as SrcLoc-import GHC.Utils.Outputable as Outputable import GHC.Builtin.Names ( mkUnboundName, isUnboundName, getUnique)+import GHC.Utils.Outputable as Outputable import GHC.Utils.Misc+ import GHC.Data.Maybe-import GHC.Driver.Session-import GHC.Driver.Ppr import GHC.Data.FastString++import GHC.Types.SrcLoc as SrcLoc+import GHC.Types.Name+import GHC.Types.Name.Reader+import GHC.Types.Unique.DFM (udfmToList)++import GHC.Unit.Module+import GHC.Unit.Module.Imported+import GHC.Unit.Home.ModInfo+ import Data.List import Data.Function ( on )-import GHC.Types.Unique.DFM (udfmToList) {- ************************************************************************
compiler/GHC/Rename/Utils.hs view
@@ -1,18 +1,17 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {- This module contains miscellaneous functions related to renaming. -}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- module GHC.Rename.Utils ( checkDupRdrNames, checkShadowedRdrNames, checkDupNames, checkDupAndShadowedNames, dupNamesErr,- checkTupSize,+ checkTupSize, checkCTupSize, addFvRn, mapFvRn, mapMaybeFvRn, warnUnusedMatches, warnUnusedTypePatterns, warnUnusedTopBinds, warnUnusedLocalBinds,@@ -40,7 +39,6 @@ import GHC.Core.Type import GHC.Hs import GHC.Types.Name.Reader-import GHC.Driver.Types import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad import GHC.Types.Name@@ -48,6 +46,7 @@ import GHC.Types.Name.Env import GHC.Core.DataCon import GHC.Types.SrcLoc as SrcLoc+import GHC.Types.SourceFile import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc@@ -58,7 +57,7 @@ import GHC.Data.FastString import Control.Monad import Data.List-import GHC.Settings.Constants ( mAX_TUPLE_SIZE )+import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE ) import qualified Data.List.NonEmpty as NE import qualified GHC.LanguageExtensions as LangExt @@ -367,8 +366,8 @@ -> FreeVars -> Maybe [Name] -> RnM ()-checkUnusedRecordWildcard _ _ Nothing = return ()-checkUnusedRecordWildcard loc _ (Just []) = do+checkUnusedRecordWildcard _ _ Nothing = return ()+checkUnusedRecordWildcard loc _ (Just []) = -- Add a new warning if the .. pattern binds no variables setSrcSpan loc $ warnRedundantRecordWildcard checkUnusedRecordWildcard loc fvs (Just dotdot_names) =@@ -573,7 +572,9 @@ <+> quotes (char '@' <> ppr k)) 2 (text "Perhaps you intended to use TypeApplications") -checkTupSize :: Int -> RnM ()+-- | Ensure that a boxed or unboxed tuple has arity no larger than+-- 'mAX_TUPLE_SIZE'.+checkTupSize :: Int -> TcM () checkTupSize tup_size | tup_size <= mAX_TUPLE_SIZE = return ()@@ -581,6 +582,16 @@ = addErr (sep [text "A" <+> int tup_size <> ptext (sLit "-tuple is too large for GHC"), nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)), nest 2 (text "Workaround: use nested tuples or define a data type")])++-- | Ensure that a constraint tuple has arity no larger than 'mAX_CTUPLE_SIZE'.+checkCTupSize :: Int -> TcM ()+checkCTupSize tup_size+ | tup_size <= mAX_CTUPLE_SIZE+ = return ()+ | otherwise+ = addErr (hang (text "Constraint tuple arity too large:" <+> int tup_size+ <+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE))+ 2 (text "Instead, use a nested tuple")) {-
compiler/GHC/Runtime/Debugger.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE MagicHash #-}- ----------------------------------------------------------------------------- -- -- GHCi Interactive debugging commands@@ -16,29 +14,34 @@ import GHC.Prelude +import GHC++import GHC.Driver.Session+import GHC.Driver.Ppr+import GHC.Driver.Monad+import GHC.Driver.Env+ import GHC.Runtime.Linker import GHC.Runtime.Heap.Inspect- import GHC.Runtime.Interpreter-import GHCi.RemoteTypes-import GHC.Driver.Monad-import GHC.Driver.Types-import GHC.Types.Id+import GHC.Runtime.Context+ import GHC.Iface.Syntax ( showToHeader ) import GHC.Iface.Env ( newInteractiveBinder )-import GHC.Types.Name-import GHC.Types.Var hiding ( varName )-import GHC.Types.Var.Set-import GHC.Types.Unique.Set import GHC.Core.Type-import GHC+ import GHC.Utils.Outputable-import GHC.Core.Ppr.TyThing import GHC.Utils.Error import GHC.Utils.Monad-import GHC.Driver.Session-import GHC.Driver.Ppr import GHC.Utils.Exception++import GHC.Types.Id+import GHC.Types.Name+import GHC.Types.Var hiding ( varName )+import GHC.Types.Var.Set+import GHC.Types.Unique.Set+import GHC.Types.TyThing.Ppr+import GHC.Types.TyThing import Control.Monad import Control.Monad.Catch as MC
compiler/GHC/Runtime/Eval.hs view
@@ -1,5 +1,7 @@-{-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -48,28 +50,57 @@ import GHC.Prelude -import GHC.Runtime.Eval.Types+import GHC.Driver.Monad+import GHC.Driver.Main+import GHC.Driver.Env+import GHC.Driver.Session+import GHC.Driver.Ppr +import GHC.Runtime.Eval.Types import GHC.Runtime.Interpreter as GHCi import GHC.Runtime.Interpreter.Types+import GHC.Runtime.Linker as Linker+import GHC.Runtime.Linker.Types+import GHC.Runtime.Heap.Inspect+import GHC.Runtime.Context import GHCi.Message import GHCi.RemoteTypes-import GHC.Driver.Monad-import GHC.Driver.Main+import GHC.ByteCode.Types+ import GHC.Hs-import GHC.Driver.Types++import GHC.Core.Predicate import GHC.Core.InstEnv-import GHC.Iface.Env ( newInteractiveBinder ) import GHC.Core.FamInstEnv ( FamInst ) import GHC.Core.FVs ( orphNamesOfFamInst ) import GHC.Core.TyCon import GHC.Core.Type hiding( typeKind ) import qualified GHC.Core.Type as Type-import GHC.Types.RepType++import GHC.Iface.Env ( newInteractiveBinder ) import GHC.Tc.Utils.TcType import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin-import GHC.Core.Predicate++import GHC.Builtin.Names ( toDynName, pretendNameIsInScope )+import GHC.Builtin.Types ( isCTupleTyConName )++import GHC.Data.Maybe+import GHC.Data.FastString+import GHC.Data.Bag++import GHC.Utils.Monad+import GHC.Utils.Panic+import GHC.Utils.Error+import GHC.Utils.Outputable+import GHC.Utils.Misc++import qualified GHC.Parser.Lexer as Lexer (P (..), ParseResult(..), unP, initParserState)+import GHC.Parser.Lexer (ParserOpts)+import qualified GHC.Parser as Parser (parseStmt, parseModule, parseDeclaration, parseImport)++import GHC.Types.RepType+import GHC.Types.Fixity.Env import GHC.Types.Var import GHC.Types.Id as Id import GHC.Types.Name hiding ( varName )@@ -77,28 +108,15 @@ import GHC.Types.Avail import GHC.Types.Name.Reader import GHC.Types.Var.Env-import GHC.ByteCode.Types-import GHC.Runtime.Linker as Linker-import GHC.Driver.Session-import GHC.Driver.Ppr+import GHC.Types.SrcLoc import GHC.Types.Unique import GHC.Types.Unique.Supply-import GHC.Utils.Monad+import GHC.Types.TyThing+ import GHC.Unit-import GHC.Builtin.Names ( toDynName, pretendNameIsInScope )-import GHC.Builtin.Types ( isCTupleTyConName )-import GHC.Utils.Panic-import GHC.Data.Maybe-import GHC.Utils.Error-import GHC.Types.SrcLoc-import GHC.Runtime.Heap.Inspect-import GHC.Utils.Outputable-import GHC.Data.FastString-import GHC.Data.Bag-import GHC.Utils.Misc-import qualified GHC.Parser.Lexer as Lexer (P (..), ParseResult(..), unP, initParserState)-import GHC.Parser.Lexer (ParserOpts)-import qualified GHC.Parser as Parser (parseStmt, parseModule, parseDeclaration, parseImport)+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModSummary+import GHC.Unit.Home.ModInfo import System.Directory import Data.Dynamic@@ -420,14 +438,14 @@ , resumeBindings = bindings, resumeFinalIds = final_ids , resumeApStack = apStack, resumeBreakInfo = mb_brkpt , resumeSpan = span- , resumeHistory = hist } -> do+ , resumeHistory = hist } -> withVirtualCWD $ do status <- liftIO $ GHCi.resumeStmt hsc_env (isStep step) fhv let prevHistoryLst = fromListBL 50 hist hist' = case mb_brkpt of Nothing -> prevHistoryLst Just bi- | not $canLogSpan span -> prevHistoryLst+ | not $ canLogSpan span -> prevHistoryLst | otherwise -> mkHistory hsc_env apStack bi `consBL` fromListBL 50 hist handleRunStatus step expr bindings final_ids status hist'@@ -614,8 +632,7 @@ [id | id <- tmp_ids , not $ noSkolems id , (occNameFS.nameOccName.idName) id /= result_fs]- hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)- return hsc_env'+ foldM improveTypes hsc_env (map idName incompletelyTypedIds) where noSkolems = noFreeVarsOfType . idType improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do@@ -811,7 +828,7 @@ -- its full top-level scope available. moduleIsInterpreted :: GhcMonad m => Module -> m Bool moduleIsInterpreted modl = withSession $ \h ->- if notHomeModule (mkHomeUnitFromFlags (hsc_dflags h)) modl+ if notHomeModule (hsc_home_unit h) modl then return False else case lookupHpt (hsc_HPT h) (moduleName modl) of Just details -> return (isJust (mi_globals (hm_iface details)))@@ -854,7 +871,7 @@ -- | Returns all names in scope in the current interactive context getNamesInScope :: GhcMonad m => m [Name]-getNamesInScope = withSession $ \hsc_env -> do+getNamesInScope = withSession $ \hsc_env -> return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env)))) -- | Returns all 'RdrName's in scope in the current interactive@@ -901,7 +918,7 @@ -- | Returns @True@ if passed string is a declaration but __/not a splice/__. isDecl :: ParserOpts -> String -> Bool-isDecl pflags stmt = do+isDecl pflags stmt = case parseThing Parser.parseDeclaration pflags stmt of Lexer.POk _ thing -> case unLoc thing of@@ -995,7 +1012,7 @@ -- | Get the kind of a type typeKind :: GhcMonad m => Bool -> String -> m (Type, Kind)-typeKind normalise str = withSession $ \hsc_env -> do+typeKind normalise str = withSession $ \hsc_env -> liftIO $ hscKcType hsc_env normalise str -- ----------------------------------------------------------------------------@@ -1046,8 +1063,8 @@ -- Find all instances that match a provided type getInstancesForType :: GhcMonad m => Type -> m [ClsInst]-getInstancesForType ty = withSession $ \hsc_env -> do- liftIO $ runInteractiveHsc hsc_env $ do+getInstancesForType ty = withSession $ \hsc_env ->+ liftIO $ runInteractiveHsc hsc_env $ ioMsgMaybe $ runTcInteractive hsc_env $ do -- Bring class and instances from unqualified modules into scope, this fixes #16793. loadUnqualIfaces hsc_env (hsc_IC hsc_env)@@ -1188,7 +1205,7 @@ -- | Parse an expression, the parsed expression can be further processed and -- passed to compileParsedExpr. parseExpr :: GhcMonad m => String -> m (LHsExpr GhcPs)-parseExpr expr = withSession $ \hsc_env -> do+parseExpr expr = withSession $ \hsc_env -> liftIO $ runInteractiveHsc hsc_env $ hscParseExpr expr -- | Compile an expression, run it, and deliver the resulting HValue.
compiler/GHC/Runtime/Heap/Inspect.hs view
@@ -30,7 +30,7 @@ import GHC.Runtime.Interpreter as GHCi import GHCi.RemoteTypes-import GHC.Driver.Types+import GHC.Driver.Env import GHCi.Message ( fromSerializableException ) import GHC.Core.DataCon@@ -1019,7 +1019,7 @@ traceTR (text "Constr1" <+> ppr dcname) (mb_dc, _) <- tryTc (tcLookupDataCon dcname) case mb_dc of- Nothing-> do+ Nothing-> forM pArgs $ \x -> do tv <- newVar liftedTypeKind return (tv, x)
compiler/GHC/Runtime/Interpreter.hs view
@@ -55,28 +55,36 @@ import GHC.Prelude +import GHC.Driver.Ppr (showSDoc)+import GHC.Driver.Env+import GHC.Driver.Session+ import GHC.Runtime.Interpreter.Types import GHCi.Message import GHCi.RemoteTypes import GHCi.ResolvedBCO import GHCi.BreakArray (BreakArray)-import GHC.Utils.Fingerprint-import GHC.Driver.Types+import GHC.Runtime.Eval.Types(BreakInfo(..))+import GHC.Runtime.Linker.Types+import GHC.ByteCode.Types++import GHC.Data.Maybe+import GHC.Data.FastString++import GHC.Types.Unique+import GHC.Types.SrcLoc import GHC.Types.Unique.FM+import GHC.Types.Basic+ import GHC.Utils.Panic-import GHC.Driver.Session import GHC.Utils.Exception as Ex-import GHC.Types.Basic-import GHC.Data.FastString-import GHC.Utils.Misc-import GHC.Runtime.Eval.Types(BreakInfo(..)) import GHC.Utils.Outputable(brackets, ppr)-import GHC.Driver.Ppr (showSDoc)-import GHC.Types.SrcLoc-import GHC.Data.Maybe+import GHC.Utils.Fingerprint+import GHC.Utils.Misc+ import GHC.Unit.Module-import GHC.ByteCode.Types-import GHC.Types.Unique+import GHC.Unit.Module.ModIface+import GHC.Unit.Home.ModInfo #if defined(HAVE_INTERNAL_INTERPRETER) import GHCi.Run@@ -183,7 +191,7 @@ InternalInterp -> run msg -- Just run it directly #endif (ExternalInterp c i) -> withIServ_ c i $ \iserv ->- uninterruptibleMask_ $ do -- Note [uninterruptibleMask_]+ uninterruptibleMask_ $ -- Note [uninterruptibleMask_] iservCall iserv msg @@ -215,7 +223,7 @@ withIServ :: (ExceptionMonad m) => IServConfig -> IServ -> (IServInstance -> m (IServInstance, a)) -> m a-withIServ conf (IServ mIServState) action = do+withIServ conf (IServ mIServState) action = MC.mask $ \restore -> do state <- liftIO $ takeMVar mIServState @@ -278,7 +286,7 @@ handleEvalStatus hsc_env status abandonStmt :: HscEnv -> ForeignRef (ResumeContext [HValueRef]) -> IO ()-abandonStmt hsc_env resume_ctxt = do+abandonStmt hsc_env resume_ctxt = withForeignRef resume_ctxt $ \rhv -> iservCmd hsc_env (AbandonStmt rhv) @@ -292,24 +300,24 @@ EvalComplete alloc <$> addFinalizer res where addFinalizer (EvalException e) = return (EvalException e)- addFinalizer (EvalSuccess rs) = do+ addFinalizer (EvalSuccess rs) = EvalSuccess <$> mapM (mkFinalizedHValue hsc_env) rs -- | Execute an action of type @IO ()@ evalIO :: HscEnv -> ForeignHValue -> IO ()-evalIO hsc_env fhv = do+evalIO hsc_env fhv = liftIO $ withForeignRef fhv $ \fhv -> iservCmd hsc_env (EvalIO fhv) >>= fromEvalResult -- | Execute an action of type @IO String@ evalString :: HscEnv -> ForeignHValue -> IO String-evalString hsc_env fhv = do+evalString hsc_env fhv = liftIO $ withForeignRef fhv $ \fhv -> iservCmd hsc_env (EvalString fhv) >>= fromEvalResult -- | Execute an action of type @String -> IO String@ evalStringToIOString :: HscEnv -> ForeignHValue -> String -> IO String-evalStringToIOString hsc_env fhv str = do+evalStringToIOString hsc_env fhv str = liftIO $ withForeignRef fhv $ \fhv -> iservCmd hsc_env (EvalStringToString fhv str) >>= fromEvalResult @@ -371,12 +379,12 @@ mkFinalizedHValue hsc_env breakArray enableBreakpoint :: HscEnv -> ForeignRef BreakArray -> Int -> Bool -> IO ()-enableBreakpoint hsc_env ref ix b = do+enableBreakpoint hsc_env ref ix b = withForeignRef ref $ \breakarray -> iservCmd hsc_env (EnableBreakpoint breakarray ix b) breakpointStatus :: HscEnv -> ForeignRef BreakArray -> Int -> IO Bool-breakpointStatus hsc_env ref ix = do+breakpointStatus hsc_env ref ix = withForeignRef ref $ \breakarray -> iservCmd hsc_env (BreakpointStatus breakarray ix) @@ -400,10 +408,10 @@ -- | Process the result of a Seq or ResumeSeq message. #2950 handleSeqHValueStatus :: HscEnv -> EvalStatus () -> IO (EvalResult ())-handleSeqHValueStatus hsc_env eval_status = do+handleSeqHValueStatus hsc_env eval_status = case eval_status of (EvalBreak is_exception _ ix mod_uniq resume_ctxt _) -> do- -- A breakpoint was hit, inform the user and tell him+ -- A breakpoint was hit; inform the user and tell them -- which breakpoint was hit. resume_ctxt_fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt let hmi = expectJust "handleRunStatus" $
compiler/GHC/Runtime/Linker.hs view
@@ -31,39 +31,53 @@ import GHC.Prelude +import GHC.Platform+import GHC.Platform.Ways++import GHC.Driver.Phases+import GHC.Driver.Env+import GHC.Driver.Session+import GHC.Driver.Ppr++import GHC.Tc.Utils.Monad+ import GHC.Runtime.Interpreter import GHC.Runtime.Interpreter.Types+import GHC.Runtime.Linker.Types import GHCi.RemoteTypes+ import GHC.Iface.Load+ import GHC.ByteCode.Linker import GHC.ByteCode.Asm import GHC.ByteCode.Types-import GHC.Tc.Utils.Monad-import GHC.Unit.State as Packages-import GHC.Driver.Phases-import GHC.Driver.Finder-import GHC.Driver.Types-import GHC.Platform.Ways++import GHC.SysTools+import GHC.SysTools.FileCleanup++import GHC.Types.Basic import GHC.Types.Name import GHC.Types.Name.Env-import GHC.Unit.Module-import GHC.Unit.Home-import GHC.Data.List.SetOps-import GHC.Runtime.Linker.Types (DynLinker(..), PersistentLinkerState(..))-import GHC.Driver.Session-import GHC.Driver.Ppr-import GHC.Types.Basic+import GHC.Types.SrcLoc+import GHC.Types.Unique.DSet+ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Utils.Error-import GHC.Types.SrcLoc++import GHC.Unit.Finder+import GHC.Unit.Module+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.Deps+import GHC.Unit.Home+import GHC.Unit.Home.ModInfo+import GHC.Unit.State as Packages++import qualified GHC.Data.ShortText as ST import qualified GHC.Data.Maybe as Maybes-import GHC.Types.Unique.DSet import GHC.Data.FastString-import GHC.Platform-import GHC.SysTools-import GHC.SysTools.FileCleanup+import GHC.Data.List.SetOps -- Standard libraries import Control.Monad@@ -229,7 +243,7 @@ -- lose those changes (we might have linked a new module or -- package), so the reset action only removes the names we -- added earlier.- reset_old_env = liftIO $ do+ reset_old_env = liftIO $ modifyPLS_ dl $ \pls -> let cur = closure_env pls new = delListFromNameEnv cur (map fst new_env)@@ -299,7 +313,7 @@ linkCmdLineLibs hsc_env = do let dl = hsc_dynLinker hsc_env initDynLinker hsc_env- modifyPLS_ dl $ \pls -> do+ modifyPLS_ dl $ \pls -> linkCmdLineLibs' hsc_env pls linkCmdLineLibs' :: HscEnv -> PersistentLinkerState -> IO PersistentLinkerState@@ -445,7 +459,7 @@ return pls DLL dll_unadorned -> do- maybe_errstr <- loadDLL hsc_env (mkSOName platform dll_unadorned)+ maybe_errstr <- loadDLL hsc_env (platformSOName platform dll_unadorned) case maybe_errstr of Nothing -> maybePutStrLn dflags "done" Just mm | platformOS platform /= OSDarwin ->@@ -596,7 +610,7 @@ | otherwise = return (Just (hostWayTag ++ "o")) where- targetFullWays = Set.filter (not . wayRTSOnly) (ways (hsc_dflags hsc_env))+ targetFullWays = fullWays (ways (hsc_dflags hsc_env)) hostWayTag = case waysTag hostFullWays of "" -> "" tag -> tag ++ "_"@@ -682,7 +696,7 @@ let pkg = moduleUnit mod deps = mi_deps iface- home_unit = mkHomeUnitFromFlags dflags+ home_unit = hsc_home_unit hsc_env pkg_deps = dep_pkgs deps (boot_deps, mod_deps) = flip partitionWith (dep_mods deps) $@@ -901,7 +915,7 @@ -- If resolving failed, unload all our -- object modules and carry on- if succeeded ok then do+ if succeeded ok then return (pls1, Succeeded) else do pls2 <- unload_wkr hsc_env [] pls1@@ -917,7 +931,7 @@ let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ] let minus_big_ls = [ lib | Option ('-':'L':lib) <- ldInputs dflags ] (soFile, libPath , libName) <-- newTempLibName dflags TFL_CurrentModule (soExt platform)+ newTempLibName dflags TFL_CurrentModule (platformSOExt platform) let dflags2 = dflags { -- We don't want the original ldInputs in@@ -1245,7 +1259,7 @@ -- a lock. initDynLinker hsc_env let dl = hsc_dynLinker hsc_env- modifyPLS_ dl $ \pls -> do+ modifyPLS_ dl $ \pls -> linkPackages' hsc_env new_pkgs pls linkPackages' :: HscEnv -> [UnitId] -> PersistentLinkerState@@ -1282,10 +1296,10 @@ let dflags = hsc_dflags hsc_env platform = targetPlatform dflags is_dyn = interpreterDynamic (hscInterp hsc_env)- dirs | is_dyn = Packages.unitLibraryDynDirs pkg- | otherwise = Packages.unitLibraryDirs pkg+ dirs | is_dyn = map ST.unpack $ Packages.unitLibraryDynDirs pkg+ | otherwise = map ST.unpack $ Packages.unitLibraryDirs pkg - let hs_libs = Packages.unitLibraries pkg+ let hs_libs = map ST.unpack $ Packages.unitLibraries pkg -- The FFI GHCi import lib isn't needed as -- GHC.Runtime.Linker + rts/Linker.c link the -- interpreted references to FFI to the compiled FFI.@@ -1300,11 +1314,12 @@ -- libs do not exactly match the .so/.dll equivalents. So if the -- package file provides an "extra-ghci-libraries" field then we use -- that instead of the "extra-libraries" field.- extra_libs =- (if null (Packages.unitExtDepLibsGhc pkg)- then Packages.unitExtDepLibsSys pkg- else Packages.unitExtDepLibsGhc pkg)- ++ [ lib | '-':'l':lib <- Packages.unitLinkerOptions pkg ]+ extdeplibs = map ST.unpack (if null (Packages.unitExtDepLibsGhc pkg)+ then Packages.unitExtDepLibsSys pkg+ else Packages.unitExtDepLibsGhc pkg)+ linkerlibs = [ lib | '-':'l':lib <- (map ST.unpack $ Packages.unitLinkerOptions pkg) ]+ extra_libs = extdeplibs ++ linkerlibs+ -- See Note [Fork/Exec Windows] gcc_paths <- getGCCPaths dflags (platformOS platform) dirs_env <- addEnvPaths "LIBRARY_PATH" dirs@@ -1340,7 +1355,7 @@ mapM_ (load_dyn hsc_env True) known_dlls -- 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+ mapM_ (load_dyn hsc_env (not is_dyn) . platformSOName 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@@ -1434,8 +1449,8 @@ loadFrameworks hsc_env platform pkg = when (platformUsesFrameworks platform) $ mapM_ load frameworks where- fw_dirs = Packages.unitExtDepFrameworkDirs pkg- frameworks = Packages.unitExtDepFrameworks pkg+ fw_dirs = map ST.unpack $ Packages.unitExtDepFrameworkDirs pkg+ frameworks = map ST.unpack $ Packages.unitExtDepFrameworks pkg load fw = do r <- loadFramework hsc_env fw_dirs fw case r of@@ -1526,9 +1541,9 @@ ] hs_dyn_lib_name = lib ++ '-':programName dflags ++ projectVersion dflags- hs_dyn_lib_file = mkHsSOName platform hs_dyn_lib_name+ hs_dyn_lib_file = platformHsSOName platform hs_dyn_lib_name - so_name = mkSOName platform lib+ so_name = platformSOName platform lib lib_so_name = "lib" ++ so_name dyn_lib_file = case (arch, os) of (ArchX86_64, OSSolaris2) -> "64" </> so_name
compiler/GHC/Runtime/Loader.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, MagicHash #-}+{-# LANGUAGE CPP #-} -- | Dynamically lookup up values from modules and loading them. module GHC.Runtime.Loader (@@ -21,39 +21,46 @@ ) where import GHC.Prelude+ import GHC.Driver.Session import GHC.Driver.Ppr+import GHC.Driver.Hooks+import GHC.Driver.Plugins import GHC.Runtime.Linker ( linkModule, getHValue ) import GHC.Runtime.Interpreter ( wormhole, withInterp ) import GHC.Runtime.Interpreter.Types-import GHC.Types.SrcLoc ( noSrcSpan )-import GHC.Driver.Finder ( findPluginModule, cannotFindModule )+ import GHC.Tc.Utils.Monad ( initTcInteractive, initIfaceTcRn ) import GHC.Iface.Load ( loadPluginInterface )-import GHC.Types.Name.Reader ( RdrName, ImportSpec(..), ImpDeclSpec(..)- , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName- , gre_name, mkRdrQual )-import GHC.Types.Name.Occurrence ( OccName, mkVarOcc ) import GHC.Rename.Names ( gresFromAvails )-import GHC.Driver.Plugins import GHC.Builtin.Names ( pluginTyConName, frontendPluginTyConName ) -import GHC.Driver.Types+import GHC.Driver.Env import GHCi.RemoteTypes ( HValue ) import GHC.Core.Type ( Type, eqType, mkTyConTy )-import GHC.Core.TyCo.Ppr ( pprTyThingCategory ) import GHC.Core.TyCon ( TyCon )++import GHC.Types.SrcLoc ( noSrcSpan ) import GHC.Types.Name ( Name, nameModule_maybe ) import GHC.Types.Id ( idType )+import GHC.Types.TyThing+import GHC.Types.Name.Occurrence ( OccName, mkVarOcc )+import GHC.Types.Name.Reader ( RdrName, ImportSpec(..), ImpDeclSpec(..)+ , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName+ , gre_name, mkRdrQual )++import GHC.Unit.Finder ( findPluginModule, cannotFindModule, FindResult(..) ) import GHC.Unit.Module ( Module, ModuleName )+import GHC.Unit.Module.ModIface+ import GHC.Utils.Panic-import GHC.Data.FastString import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Exception-import GHC.Driver.Hooks +import GHC.Data.FastString+ import Control.Monad ( unless ) import Data.Maybe ( mapMaybe ) import Unsafe.Coerce ( unsafeCoerce )@@ -73,8 +80,7 @@ | otherwise = do loadedPlugins <- loadPlugins (hsc_env { hsc_dflags = df }) let df' = df { cachedPlugins = loadedPlugins }- df'' <- withPlugins df' runDflagsPlugin df'- return df''+ withPlugins df' runDflagsPlugin df' where argumentsForPlugin p = map snd . filter ((== lpModuleName p) . fst) runDflagsPlugin p opts dynflags = dynflagsPlugin p opts dynflags@@ -161,7 +167,7 @@ forceLoadTyCon hsc_env con_name = do forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of loadTyConTy") con_name - mb_con_thing <- lookupTypeHscEnv hsc_env con_name+ mb_con_thing <- lookupType hsc_env con_name case mb_con_thing of Nothing -> throwCmdLineErrorS dflags $ missingTyThingError con_name Just (ATyCon tycon) -> return tycon@@ -193,7 +199,7 @@ getHValueSafely hsc_env val_name expected_type = do forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of getHValueSafely") val_name -- Now look up the names for the value and type constructor in the type environment- mb_val_thing <- lookupTypeHscEnv hsc_env val_name+ mb_val_thing <- lookupType hsc_env val_name case mb_val_thing of Nothing -> throwCmdLineErrorS dflags $ missingTyThingError val_name Just (AnId id) -> do
compiler/GHC/Settings/IO.hs view
@@ -155,8 +155,6 @@ ghcWithSMP <- getBooleanSetting "Support SMP" ghcRTSWays <- getSetting "RTS ways" useLibFFI <- getBooleanSetting "Use LibFFI"- ghcThreaded <- getBooleanSetting "Use Threads"- ghcDebugged <- getBooleanSetting "Use Debugging" ghcRtsWithLibdw <- getBooleanSetting "RTS expects libdw" return $ Settings@@ -225,8 +223,6 @@ , platformMisc_ghcWithSMP = ghcWithSMP , platformMisc_ghcRTSWays = ghcRTSWays , platformMisc_libFFI = useLibFFI- , platformMisc_ghcThreaded = ghcThreaded- , platformMisc_ghcDebugged = ghcDebugged , platformMisc_ghcRtsWithLibdw = ghcRtsWithLibdw , platformMisc_llvmTarget = llvmTarget }
compiler/GHC/Stg/Lift.hs view
@@ -202,11 +202,11 @@ liftRhs mb_former_fvs rhs@(StgRhsCon ccs con args) = ASSERT2(isNothing mb_former_fvs, text "Should never lift a constructor" $$ pprStgRhs panicStgPprOpts rhs) StgRhsCon ccs con <$> traverse liftArgs args-liftRhs Nothing (StgRhsClosure _ ccs upd infos body) = do+liftRhs Nothing (StgRhsClosure _ ccs upd infos body) = -- This RHS wasn't lifted. withSubstBndrs (map binderInfoBndr infos) $ \bndrs' -> StgRhsClosure noExtFieldSilent ccs upd bndrs' <$> liftExpr body-liftRhs (Just former_fvs) (StgRhsClosure _ ccs upd infos body) = do+liftRhs (Just former_fvs) (StgRhsClosure _ ccs upd infos body) = -- This RHS was lifted. Insert extra binders for @former_fvs@. withSubstBndrs (map binderInfoBndr infos) $ \bndrs' -> do let bndrs'' = dVarSetElems former_fvs ++ bndrs'
compiler/GHC/Stg/Lift/Analysis.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-}
compiler/GHC/Stg/Lint.hs view
@@ -27,8 +27,8 @@ for Stg code that is currently perfectly acceptable for code generation. Solution: don't use it! (KSW 2000-05). -Since then there were some attempts at enabling it again, as summarised in-#14787. It's finally decided that we remove all type checking and only look for+Since then there were some attempts at enabling it again, as summarised in #14787.+It's finally decided that we remove all type checking and only look for basic properties listed above. -}
compiler/GHC/Stg/Unarise.hs view
@@ -1,5 +1,9 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- (c) The GRASP/AQUA Project, Glasgow University, 1992-2012 @@ -193,10 +197,6 @@ * Binders always have zero (for void arguments) or one PrimRep. -}--{-# LANGUAGE CPP, TupleSections, PatternSynonyms #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module GHC.Stg.Unarise (unarise) where
compiler/GHC/StgToCmm.hs view
@@ -16,6 +16,9 @@ import GHC.Prelude as Prelude +import GHC.Driver.Backend+import GHC.Driver.Session+ import GHC.StgToCmm.Prof (initCostCentres, ldvEnter) import GHC.StgToCmm.Monad import GHC.StgToCmm.Env@@ -31,32 +34,34 @@ import GHC.Cmm import GHC.Cmm.Utils import GHC.Cmm.CLabel+import GHC.Cmm.Graph import GHC.Stg.Syntax-import GHC.Driver.Session-import GHC.Utils.Error -import GHC.Driver.Types-import GHC.Driver.Backend import GHC.Types.CostCentre+import GHC.Types.HpcInfo import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.RepType+import GHC.Types.Basic+import GHC.Types.Var.Set ( isEmptyDVarSet )+import GHC.Types.Unique.FM+import GHC.Types.Name.Env+ import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.Multiplicity+ import GHC.Unit.Module++import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Panic-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.Stream import GHC.Data.OrdList-import GHC.Cmm.Graph import Data.IORef import Control.Monad (when,void)
compiler/GHC/StgToCmm/Expr.hs view
@@ -178,12 +178,10 @@ cgLetNoEscapeClosure bndr cc_slot _unused_cc args body = do platform <- getPlatform- return ( lneIdInfo platform bndr args- , code )+ return ( lneIdInfo platform bndr args, code ) where- code = forkLneBody $ do {- ; withNewTickyCounterLNE (idName bndr) args $ do- ; restoreCurrentCostCentre cc_slot+ code = forkLneBody $ withNewTickyCounterLNE (idName bndr) args $ do+ { restoreCurrentCostCentre cc_slot ; arg_regs <- bindArgsToRegs args ; void $ noEscapeHeapCheck arg_regs (tickyEnterLNE >> cgExpr body) }
compiler/GHC/StgToCmm/Foreign.hs view
@@ -47,6 +47,7 @@ import GHC.Utils.Panic import GHC.Types.Unique.Supply import GHC.Types.Basic+import GHC.Unit.Types import GHC.Core.TyCo.Rep import GHC.Builtin.Types.Prim@@ -91,7 +92,7 @@ -> let labelSource = case mPkgId of Nothing -> ForeignLabelInThisPackage- Just pkgId -> ForeignLabelInPackage pkgId+ Just pkgId -> ForeignLabelInPackage (toUnitId pkgId) size = call_size cmm_args in ( unzip cmm_args , CmmLit (CmmLabel
compiler/GHC/StgToCmm/Heap.hs view
@@ -650,7 +650,7 @@ tickyHeapCheck emitAssign hpReg bump_hp emit =<< mkCmmIfThen' hp_oflo (alloc_n <*> mkBranch gc_id) (Just False)- else do+ else when (checkYield && not (gopt Opt_OmitYields dflags)) $ do -- Yielding if HpLim == 0 let yielding = CmmMachOp (mo_wordEq platform)
compiler/GHC/StgToCmm/Hpc.hs view
@@ -9,18 +9,20 @@ module GHC.StgToCmm.Hpc ( initHpc, mkTickBox ) where import GHC.Prelude+import GHC.Platform +import GHC.Driver.Session+ import GHC.StgToCmm.Monad+import GHC.StgToCmm.Utils -import GHC.Platform import GHC.Cmm.Graph import GHC.Cmm.Expr import GHC.Cmm.CLabel-import GHC.Unit.Module import GHC.Cmm.Utils-import GHC.StgToCmm.Utils-import GHC.Driver.Types-import GHC.Driver.Session++import GHC.Unit.Module+import GHC.Types.HpcInfo import Control.Monad
compiler/GHC/StgToCmm/Monad.hs view
@@ -734,7 +734,7 @@ emitUnwind :: [(GlobalReg, Maybe CmmExpr)] -> FCode () emitUnwind regs = do dflags <- getDynFlags- when (debugLevel dflags > 0) $ do+ when (debugLevel dflags > 0) $ emitCgStmt $ CgStmt $ CmmUnwind regs emitAssign :: CmmReg -> CmmExpr -> FCode ()
compiler/GHC/StgToCmm/Prim.hs view
@@ -266,7 +266,7 @@ -- First we handle various awkward cases specially. - ParOp -> \[arg] -> opIntoRegs $ \[res] -> do+ ParOp -> \[arg] -> opIntoRegs $ \[res] -> -- for now, just implement this in a C function -- later, we might want to inline it. emitCCall@@ -293,13 +293,13 @@ | otherwise = CmmLit (zeroCLit platform) emitAssign (CmmLocal res) val - GetCurrentCCSOp -> \[_] -> opIntoRegs $ \[res] -> do+ GetCurrentCCSOp -> \[_] -> opIntoRegs $ \[res] -> emitAssign (CmmLocal res) cccsExpr - MyThreadIdOp -> \[] -> opIntoRegs $ \[res] -> do+ MyThreadIdOp -> \[] -> opIntoRegs $ \[res] -> emitAssign (CmmLocal res) currentTSOExpr - ReadMutVarOp -> \[mutv] -> opIntoRegs $ \[res] -> do+ ReadMutVarOp -> \[mutv] -> opIntoRegs $ \[res] -> emitAssign (CmmLocal res) (cmmLoadIndexW platform mutv (fixedHdrSizeW profile) (gcWord platform)) WriteMutVarOp -> \[mutv, var] -> opIntoRegs $ \res@[] -> do@@ -320,7 +320,7 @@ -- #define sizzeofByteArrayzh(r,a) \ -- r = ((StgArrBytes *)(a))->bytes- SizeofByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do+ SizeofByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform)) -- #define sizzeofMutableByteArrayzh(r,a) \@@ -329,31 +329,31 @@ -- #define getSizzeofMutableByteArrayzh(r,a) \ -- r = ((StgArrBytes *)(a))->bytes- GetSizeofMutableByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do+ GetSizeofMutableByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform)) -- #define touchzh(o) /* nothing */- TouchOp -> \args@[_] -> opIntoRegs $ \res@[] -> do+ TouchOp -> \args@[_] -> opIntoRegs $ \res@[] -> emitPrimCall res MO_Touch args -- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)- ByteArrayContents_Char -> \[arg] -> opIntoRegs $ \[res] -> do+ ByteArrayContents_Char -> \[arg] -> opIntoRegs $ \[res] -> emitAssign (CmmLocal res) (cmmOffsetB platform arg (arrWordsHdrSize profile)) -- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn)- StableNameToIntOp -> \[arg] -> opIntoRegs $ \[res] -> do+ StableNameToIntOp -> \[arg] -> opIntoRegs $ \[res] -> emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform)) - ReallyUnsafePtrEqualityOp -> \[arg1, arg2] -> opIntoRegs $ \[res] -> do+ ReallyUnsafePtrEqualityOp -> \[arg1, arg2] -> opIntoRegs $ \[res] -> emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq platform) [arg1,arg2]) -- #define addrToHValuezh(r,a) r=(P_)a- AddrToAnyOp -> \[arg] -> opIntoRegs $ \[res] -> do+ AddrToAnyOp -> \[arg] -> opIntoRegs $ \[res] -> emitAssign (CmmLocal res) arg -- #define hvalueToAddrzh(r, a) r=(W_)a- AnyToAddrOp -> \[arg] -> opIntoRegs $ \[res] -> do+ AnyToAddrOp -> \[arg] -> opIntoRegs $ \[res] -> emitAssign (CmmLocal res) arg {- Freezing arrays-of-ptrs requires changing an info table, for the@@ -366,70 +366,70 @@ -- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_DIRTY_info); -- r = a; -- }- UnsafeFreezeArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do+ UnsafeFreezeArrayOp -> \[arg] -> opIntoRegs $ \[res] -> emit $ catAGraphs [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)), mkAssign (CmmLocal res) arg ]- UnsafeFreezeArrayArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do+ UnsafeFreezeArrayArrayOp -> \[arg] -> opIntoRegs $ \[res] -> emit $ catAGraphs [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)), mkAssign (CmmLocal res) arg ]- UnsafeFreezeSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do+ UnsafeFreezeSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] -> emit $ catAGraphs [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN_DIRTY_infoLabel)), mkAssign (CmmLocal res) arg ] -- #define unsafeFreezzeByteArrayzh(r,a) r=(a)- UnsafeFreezeByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do+ UnsafeFreezeByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> emitAssign (CmmLocal res) arg -- Reading/writing pointer arrays - ReadArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> do+ ReadArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> doReadPtrArrayOp res obj ix- IndexArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> do+ IndexArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> doReadPtrArrayOp res obj ix- WriteArrayOp -> \[obj, ix, v] -> opIntoRegs $ \[] -> do+ WriteArrayOp -> \[obj, ix, v] -> opIntoRegs $ \[] -> doWritePtrArrayOp obj ix v - IndexArrayArrayOp_ByteArray -> \[obj, ix] -> opIntoRegs $ \[res] -> do+ IndexArrayArrayOp_ByteArray -> \[obj, ix] -> opIntoRegs $ \[res] -> doReadPtrArrayOp res obj ix- IndexArrayArrayOp_ArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] -> do+ IndexArrayArrayOp_ArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] -> doReadPtrArrayOp res obj ix- ReadArrayArrayOp_ByteArray -> \[obj, ix] -> opIntoRegs $ \[res] -> do+ ReadArrayArrayOp_ByteArray -> \[obj, ix] -> opIntoRegs $ \[res] -> doReadPtrArrayOp res obj ix- ReadArrayArrayOp_MutableByteArray -> \[obj, ix] -> opIntoRegs $ \[res] -> do+ ReadArrayArrayOp_MutableByteArray -> \[obj, ix] -> opIntoRegs $ \[res] -> doReadPtrArrayOp res obj ix- ReadArrayArrayOp_ArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] -> do+ ReadArrayArrayOp_ArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] -> doReadPtrArrayOp res obj ix- ReadArrayArrayOp_MutableArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] -> do+ ReadArrayArrayOp_MutableArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] -> doReadPtrArrayOp res obj ix- WriteArrayArrayOp_ByteArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> do+ WriteArrayArrayOp_ByteArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> doWritePtrArrayOp obj ix v- WriteArrayArrayOp_MutableByteArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> do+ WriteArrayArrayOp_MutableByteArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> doWritePtrArrayOp obj ix v- WriteArrayArrayOp_ArrayArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> do+ WriteArrayArrayOp_ArrayArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> doWritePtrArrayOp obj ix v- WriteArrayArrayOp_MutableArrayArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> do+ WriteArrayArrayOp_MutableArrayArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> doWritePtrArrayOp obj ix v - ReadSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> do+ ReadSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> doReadSmallPtrArrayOp res obj ix- IndexSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> do+ IndexSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> doReadSmallPtrArrayOp res obj ix- WriteSmallArrayOp -> \[obj,ix,v] -> opIntoRegs $ \[] -> do+ WriteSmallArrayOp -> \[obj,ix,v] -> opIntoRegs $ \[] -> doWriteSmallPtrArrayOp obj ix v -- Getting the size of pointer arrays - SizeofArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do+ SizeofArrayOp -> \[arg] -> opIntoRegs $ \[res] -> emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile + bytesToWordsRoundUp platform (pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform))) (bWord platform)) SizeofMutableArrayOp -> emitPrimOp dflags SizeofArrayOp SizeofArrayArrayOp -> emitPrimOp dflags SizeofArrayOp SizeofMutableArrayArrayOp -> emitPrimOp dflags SizeofArrayOp- SizeofSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do+ SizeofSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] -> emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile + bytesToWordsRoundUp platform (pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)))@@ -440,409 +440,409 @@ -- IndexXXXoffAddr - IndexOffAddrOp_Char -> \args -> opIntoRegs $ \res -> do+ IndexOffAddrOp_Char -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp (Just (mo_u_8ToWord platform)) b8 res args- IndexOffAddrOp_WideChar -> \args -> opIntoRegs $ \res -> do+ IndexOffAddrOp_WideChar -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp (Just (mo_u_32ToWord platform)) b32 res args- IndexOffAddrOp_Int -> \args -> opIntoRegs $ \res -> do+ IndexOffAddrOp_Int -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing (bWord platform) res args- IndexOffAddrOp_Word -> \args -> opIntoRegs $ \res -> do+ IndexOffAddrOp_Word -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing (bWord platform) res args- IndexOffAddrOp_Addr -> \args -> opIntoRegs $ \res -> do+ IndexOffAddrOp_Addr -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing (bWord platform) res args- IndexOffAddrOp_Float -> \args -> opIntoRegs $ \res -> do+ IndexOffAddrOp_Float -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing f32 res args- IndexOffAddrOp_Double -> \args -> opIntoRegs $ \res -> do+ IndexOffAddrOp_Double -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing f64 res args- IndexOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res -> do+ IndexOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing (bWord platform) res args- IndexOffAddrOp_Int8 -> \args -> opIntoRegs $ \res -> do+ IndexOffAddrOp_Int8 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp (Just (mo_s_8ToWord platform)) b8 res args- IndexOffAddrOp_Int16 -> \args -> opIntoRegs $ \res -> do+ IndexOffAddrOp_Int16 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp (Just (mo_s_16ToWord platform)) b16 res args- IndexOffAddrOp_Int32 -> \args -> opIntoRegs $ \res -> do+ IndexOffAddrOp_Int32 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp (Just (mo_s_32ToWord platform)) b32 res args- IndexOffAddrOp_Int64 -> \args -> opIntoRegs $ \res -> do+ IndexOffAddrOp_Int64 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing b64 res args- IndexOffAddrOp_Word8 -> \args -> opIntoRegs $ \res -> do+ IndexOffAddrOp_Word8 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp (Just (mo_u_8ToWord platform)) b8 res args- IndexOffAddrOp_Word16 -> \args -> opIntoRegs $ \res -> do+ IndexOffAddrOp_Word16 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp (Just (mo_u_16ToWord platform)) b16 res args- IndexOffAddrOp_Word32 -> \args -> opIntoRegs $ \res -> do+ IndexOffAddrOp_Word32 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp (Just (mo_u_32ToWord platform)) b32 res args- IndexOffAddrOp_Word64 -> \args -> opIntoRegs $ \res -> do+ IndexOffAddrOp_Word64 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing b64 res args -- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr. - ReadOffAddrOp_Char -> \args -> opIntoRegs $ \res -> do+ ReadOffAddrOp_Char -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp (Just (mo_u_8ToWord platform)) b8 res args- ReadOffAddrOp_WideChar -> \args -> opIntoRegs $ \res -> do+ ReadOffAddrOp_WideChar -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp (Just (mo_u_32ToWord platform)) b32 res args- ReadOffAddrOp_Int -> \args -> opIntoRegs $ \res -> do+ ReadOffAddrOp_Int -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing (bWord platform) res args- ReadOffAddrOp_Word -> \args -> opIntoRegs $ \res -> do+ ReadOffAddrOp_Word -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing (bWord platform) res args- ReadOffAddrOp_Addr -> \args -> opIntoRegs $ \res -> do+ ReadOffAddrOp_Addr -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing (bWord platform) res args- ReadOffAddrOp_Float -> \args -> opIntoRegs $ \res -> do+ ReadOffAddrOp_Float -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing f32 res args- ReadOffAddrOp_Double -> \args -> opIntoRegs $ \res -> do+ ReadOffAddrOp_Double -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing f64 res args- ReadOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res -> do+ ReadOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing (bWord platform) res args- ReadOffAddrOp_Int8 -> \args -> opIntoRegs $ \res -> do+ ReadOffAddrOp_Int8 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp (Just (mo_s_8ToWord platform)) b8 res args- ReadOffAddrOp_Int16 -> \args -> opIntoRegs $ \res -> do+ ReadOffAddrOp_Int16 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp (Just (mo_s_16ToWord platform)) b16 res args- ReadOffAddrOp_Int32 -> \args -> opIntoRegs $ \res -> do+ ReadOffAddrOp_Int32 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp (Just (mo_s_32ToWord platform)) b32 res args- ReadOffAddrOp_Int64 -> \args -> opIntoRegs $ \res -> do+ ReadOffAddrOp_Int64 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing b64 res args- ReadOffAddrOp_Word8 -> \args -> opIntoRegs $ \res -> do+ ReadOffAddrOp_Word8 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp (Just (mo_u_8ToWord platform)) b8 res args- ReadOffAddrOp_Word16 -> \args -> opIntoRegs $ \res -> do+ ReadOffAddrOp_Word16 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp (Just (mo_u_16ToWord platform)) b16 res args- ReadOffAddrOp_Word32 -> \args -> opIntoRegs $ \res -> do+ ReadOffAddrOp_Word32 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp (Just (mo_u_32ToWord platform)) b32 res args- ReadOffAddrOp_Word64 -> \args -> opIntoRegs $ \res -> do+ ReadOffAddrOp_Word64 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing b64 res args -- IndexXXXArray - IndexByteArrayOp_Char -> \args -> opIntoRegs $ \res -> do+ IndexByteArrayOp_Char -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp (Just (mo_u_8ToWord platform)) b8 res args- IndexByteArrayOp_WideChar -> \args -> opIntoRegs $ \res -> do+ IndexByteArrayOp_WideChar -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp (Just (mo_u_32ToWord platform)) b32 res args- IndexByteArrayOp_Int -> \args -> opIntoRegs $ \res -> do+ IndexByteArrayOp_Int -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp Nothing (bWord platform) res args- IndexByteArrayOp_Word -> \args -> opIntoRegs $ \res -> do+ IndexByteArrayOp_Word -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp Nothing (bWord platform) res args- IndexByteArrayOp_Addr -> \args -> opIntoRegs $ \res -> do+ IndexByteArrayOp_Addr -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp Nothing (bWord platform) res args- IndexByteArrayOp_Float -> \args -> opIntoRegs $ \res -> do+ IndexByteArrayOp_Float -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp Nothing f32 res args- IndexByteArrayOp_Double -> \args -> opIntoRegs $ \res -> do+ IndexByteArrayOp_Double -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp Nothing f64 res args- IndexByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res -> do+ IndexByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp Nothing (bWord platform) res args- IndexByteArrayOp_Int8 -> \args -> opIntoRegs $ \res -> do+ IndexByteArrayOp_Int8 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp (Just (mo_s_8ToWord platform)) b8 res args- IndexByteArrayOp_Int16 -> \args -> opIntoRegs $ \res -> do+ IndexByteArrayOp_Int16 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp (Just (mo_s_16ToWord platform)) b16 res args- IndexByteArrayOp_Int32 -> \args -> opIntoRegs $ \res -> do+ IndexByteArrayOp_Int32 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp (Just (mo_s_32ToWord platform)) b32 res args- IndexByteArrayOp_Int64 -> \args -> opIntoRegs $ \res -> do+ IndexByteArrayOp_Int64 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp Nothing b64 res args- IndexByteArrayOp_Word8 -> \args -> opIntoRegs $ \res -> do+ IndexByteArrayOp_Word8 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp (Just (mo_u_8ToWord platform)) b8 res args- IndexByteArrayOp_Word16 -> \args -> opIntoRegs $ \res -> do+ IndexByteArrayOp_Word16 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp (Just (mo_u_16ToWord platform)) b16 res args- IndexByteArrayOp_Word32 -> \args -> opIntoRegs $ \res -> do+ IndexByteArrayOp_Word32 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp (Just (mo_u_32ToWord platform)) b32 res args- IndexByteArrayOp_Word64 -> \args -> opIntoRegs $ \res -> do+ IndexByteArrayOp_Word64 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp Nothing b64 res args -- ReadXXXArray, identical to IndexXXXArray. - ReadByteArrayOp_Char -> \args -> opIntoRegs $ \res -> do+ ReadByteArrayOp_Char -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp (Just (mo_u_8ToWord platform)) b8 res args- ReadByteArrayOp_WideChar -> \args -> opIntoRegs $ \res -> do+ ReadByteArrayOp_WideChar -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp (Just (mo_u_32ToWord platform)) b32 res args- ReadByteArrayOp_Int -> \args -> opIntoRegs $ \res -> do+ ReadByteArrayOp_Int -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp Nothing (bWord platform) res args- ReadByteArrayOp_Word -> \args -> opIntoRegs $ \res -> do+ ReadByteArrayOp_Word -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp Nothing (bWord platform) res args- ReadByteArrayOp_Addr -> \args -> opIntoRegs $ \res -> do+ ReadByteArrayOp_Addr -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp Nothing (bWord platform) res args- ReadByteArrayOp_Float -> \args -> opIntoRegs $ \res -> do+ ReadByteArrayOp_Float -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp Nothing f32 res args- ReadByteArrayOp_Double -> \args -> opIntoRegs $ \res -> do+ ReadByteArrayOp_Double -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp Nothing f64 res args- ReadByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res -> do+ ReadByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp Nothing (bWord platform) res args- ReadByteArrayOp_Int8 -> \args -> opIntoRegs $ \res -> do+ ReadByteArrayOp_Int8 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp (Just (mo_s_8ToWord platform)) b8 res args- ReadByteArrayOp_Int16 -> \args -> opIntoRegs $ \res -> do+ ReadByteArrayOp_Int16 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp (Just (mo_s_16ToWord platform)) b16 res args- ReadByteArrayOp_Int32 -> \args -> opIntoRegs $ \res -> do+ ReadByteArrayOp_Int32 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp (Just (mo_s_32ToWord platform)) b32 res args- ReadByteArrayOp_Int64 -> \args -> opIntoRegs $ \res -> do+ ReadByteArrayOp_Int64 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp Nothing b64 res args- ReadByteArrayOp_Word8 -> \args -> opIntoRegs $ \res -> do+ ReadByteArrayOp_Word8 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp (Just (mo_u_8ToWord platform)) b8 res args- ReadByteArrayOp_Word16 -> \args -> opIntoRegs $ \res -> do+ ReadByteArrayOp_Word16 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp (Just (mo_u_16ToWord platform)) b16 res args- ReadByteArrayOp_Word32 -> \args -> opIntoRegs $ \res -> do+ ReadByteArrayOp_Word32 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp (Just (mo_u_32ToWord platform)) b32 res args- ReadByteArrayOp_Word64 -> \args -> opIntoRegs $ \res -> do+ ReadByteArrayOp_Word64 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp Nothing b64 res args -- IndexWord8ArrayAsXXX - IndexByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res -> do+ IndexByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs (Just (mo_u_8ToWord platform)) b8 b8 res args- IndexByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> do+ IndexByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs (Just (mo_u_32ToWord platform)) b32 b8 res args- IndexByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res -> do+ IndexByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs Nothing (bWord platform) b8 res args- IndexByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res -> do+ IndexByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs Nothing (bWord platform) b8 res args- IndexByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> do+ IndexByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs Nothing (bWord platform) b8 res args- IndexByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> do+ IndexByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs Nothing f32 b8 res args- IndexByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> do+ IndexByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs Nothing f64 b8 res args- IndexByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> do+ IndexByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs Nothing (bWord platform) b8 res args- IndexByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> do+ IndexByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs (Just (mo_s_16ToWord platform)) b16 b8 res args- IndexByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> do+ IndexByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs (Just (mo_s_32ToWord platform)) b32 b8 res args- IndexByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> do+ IndexByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs Nothing b64 b8 res args- IndexByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> do+ IndexByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs (Just (mo_u_16ToWord platform)) b16 b8 res args- IndexByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> do+ IndexByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs (Just (mo_u_32ToWord platform)) b32 b8 res args- IndexByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> do+ IndexByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs Nothing b64 b8 res args -- ReadInt8ArrayAsXXX, identical to IndexInt8ArrayAsXXX - ReadByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res -> do+ ReadByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs (Just (mo_u_8ToWord platform)) b8 b8 res args- ReadByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> do+ ReadByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs (Just (mo_u_32ToWord platform)) b32 b8 res args- ReadByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res -> do+ ReadByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs Nothing (bWord platform) b8 res args- ReadByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res -> do+ ReadByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs Nothing (bWord platform) b8 res args- ReadByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> do+ ReadByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs Nothing (bWord platform) b8 res args- ReadByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> do+ ReadByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs Nothing f32 b8 res args- ReadByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> do+ ReadByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs Nothing f64 b8 res args- ReadByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> do+ ReadByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs Nothing (bWord platform) b8 res args- ReadByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> do+ ReadByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs (Just (mo_s_16ToWord platform)) b16 b8 res args- ReadByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> do+ ReadByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs (Just (mo_s_32ToWord platform)) b32 b8 res args- ReadByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> do+ ReadByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs Nothing b64 b8 res args- ReadByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> do+ ReadByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs (Just (mo_u_16ToWord platform)) b16 b8 res args- ReadByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> do+ ReadByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs (Just (mo_u_32ToWord platform)) b32 b8 res args- ReadByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> do+ ReadByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs Nothing b64 b8 res args -- WriteXXXoffAddr - WriteOffAddrOp_Char -> \args -> opIntoRegs $ \res -> do+ WriteOffAddrOp_Char -> \args -> opIntoRegs $ \res -> doWriteOffAddrOp (Just (mo_WordTo8 platform)) b8 res args- WriteOffAddrOp_WideChar -> \args -> opIntoRegs $ \res -> do+ WriteOffAddrOp_WideChar -> \args -> opIntoRegs $ \res -> doWriteOffAddrOp (Just (mo_WordTo32 platform)) b32 res args- WriteOffAddrOp_Int -> \args -> opIntoRegs $ \res -> do+ WriteOffAddrOp_Int -> \args -> opIntoRegs $ \res -> doWriteOffAddrOp Nothing (bWord platform) res args- WriteOffAddrOp_Word -> \args -> opIntoRegs $ \res -> do+ WriteOffAddrOp_Word -> \args -> opIntoRegs $ \res -> doWriteOffAddrOp Nothing (bWord platform) res args- WriteOffAddrOp_Addr -> \args -> opIntoRegs $ \res -> do+ WriteOffAddrOp_Addr -> \args -> opIntoRegs $ \res -> doWriteOffAddrOp Nothing (bWord platform) res args- WriteOffAddrOp_Float -> \args -> opIntoRegs $ \res -> do+ WriteOffAddrOp_Float -> \args -> opIntoRegs $ \res -> doWriteOffAddrOp Nothing f32 res args- WriteOffAddrOp_Double -> \args -> opIntoRegs $ \res -> do+ WriteOffAddrOp_Double -> \args -> opIntoRegs $ \res -> doWriteOffAddrOp Nothing f64 res args- WriteOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res -> do+ WriteOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res -> doWriteOffAddrOp Nothing (bWord platform) res args- WriteOffAddrOp_Int8 -> \args -> opIntoRegs $ \res -> do+ WriteOffAddrOp_Int8 -> \args -> opIntoRegs $ \res -> doWriteOffAddrOp (Just (mo_WordTo8 platform)) b8 res args- WriteOffAddrOp_Int16 -> \args -> opIntoRegs $ \res -> do+ WriteOffAddrOp_Int16 -> \args -> opIntoRegs $ \res -> doWriteOffAddrOp (Just (mo_WordTo16 platform)) b16 res args- WriteOffAddrOp_Int32 -> \args -> opIntoRegs $ \res -> do+ WriteOffAddrOp_Int32 -> \args -> opIntoRegs $ \res -> doWriteOffAddrOp (Just (mo_WordTo32 platform)) b32 res args- WriteOffAddrOp_Int64 -> \args -> opIntoRegs $ \res -> do+ WriteOffAddrOp_Int64 -> \args -> opIntoRegs $ \res -> doWriteOffAddrOp Nothing b64 res args- WriteOffAddrOp_Word8 -> \args -> opIntoRegs $ \res -> do+ WriteOffAddrOp_Word8 -> \args -> opIntoRegs $ \res -> doWriteOffAddrOp (Just (mo_WordTo8 platform)) b8 res args- WriteOffAddrOp_Word16 -> \args -> opIntoRegs $ \res -> do+ WriteOffAddrOp_Word16 -> \args -> opIntoRegs $ \res -> doWriteOffAddrOp (Just (mo_WordTo16 platform)) b16 res args- WriteOffAddrOp_Word32 -> \args -> opIntoRegs $ \res -> do+ WriteOffAddrOp_Word32 -> \args -> opIntoRegs $ \res -> doWriteOffAddrOp (Just (mo_WordTo32 platform)) b32 res args- WriteOffAddrOp_Word64 -> \args -> opIntoRegs $ \res -> do+ WriteOffAddrOp_Word64 -> \args -> opIntoRegs $ \res -> doWriteOffAddrOp Nothing b64 res args -- WriteXXXArray - WriteByteArrayOp_Char -> \args -> opIntoRegs $ \res -> do+ WriteByteArrayOp_Char -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp (Just (mo_WordTo8 platform)) b8 res args- WriteByteArrayOp_WideChar -> \args -> opIntoRegs $ \res -> do+ WriteByteArrayOp_WideChar -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp (Just (mo_WordTo32 platform)) b32 res args- WriteByteArrayOp_Int -> \args -> opIntoRegs $ \res -> do+ WriteByteArrayOp_Int -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp Nothing (bWord platform) res args- WriteByteArrayOp_Word -> \args -> opIntoRegs $ \res -> do+ WriteByteArrayOp_Word -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp Nothing (bWord platform) res args- WriteByteArrayOp_Addr -> \args -> opIntoRegs $ \res -> do+ WriteByteArrayOp_Addr -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp Nothing (bWord platform) res args- WriteByteArrayOp_Float -> \args -> opIntoRegs $ \res -> do+ WriteByteArrayOp_Float -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp Nothing f32 res args- WriteByteArrayOp_Double -> \args -> opIntoRegs $ \res -> do+ WriteByteArrayOp_Double -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp Nothing f64 res args- WriteByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res -> do+ WriteByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp Nothing (bWord platform) res args- WriteByteArrayOp_Int8 -> \args -> opIntoRegs $ \res -> do+ WriteByteArrayOp_Int8 -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp (Just (mo_WordTo8 platform)) b8 res args- WriteByteArrayOp_Int16 -> \args -> opIntoRegs $ \res -> do+ WriteByteArrayOp_Int16 -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp (Just (mo_WordTo16 platform)) b16 res args- WriteByteArrayOp_Int32 -> \args -> opIntoRegs $ \res -> do+ WriteByteArrayOp_Int32 -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp (Just (mo_WordTo32 platform)) b32 res args- WriteByteArrayOp_Int64 -> \args -> opIntoRegs $ \res -> do+ WriteByteArrayOp_Int64 -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp Nothing b64 res args- WriteByteArrayOp_Word8 -> \args -> opIntoRegs $ \res -> do+ WriteByteArrayOp_Word8 -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp (Just (mo_WordTo8 platform)) b8 res args- WriteByteArrayOp_Word16 -> \args -> opIntoRegs $ \res -> do+ WriteByteArrayOp_Word16 -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp (Just (mo_WordTo16 platform)) b16 res args- WriteByteArrayOp_Word32 -> \args -> opIntoRegs $ \res -> do+ WriteByteArrayOp_Word32 -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp (Just (mo_WordTo32 platform)) b32 res args- WriteByteArrayOp_Word64 -> \args -> opIntoRegs $ \res -> do+ WriteByteArrayOp_Word64 -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp Nothing b64 res args -- WriteInt8ArrayAsXXX - WriteByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res -> do+ WriteByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp (Just (mo_WordTo8 platform)) b8 res args- WriteByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> do+ WriteByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp (Just (mo_WordTo32 platform)) b8 res args- WriteByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res -> do+ WriteByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp Nothing b8 res args- WriteByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res -> do+ WriteByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp Nothing b8 res args- WriteByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> do+ WriteByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp Nothing b8 res args- WriteByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> do+ WriteByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp Nothing b8 res args- WriteByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> do+ WriteByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp Nothing b8 res args- WriteByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> do+ WriteByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp Nothing b8 res args- WriteByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> do+ WriteByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp (Just (mo_WordTo16 platform)) b8 res args- WriteByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> do+ WriteByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp (Just (mo_WordTo32 platform)) b8 res args- WriteByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> do+ WriteByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp Nothing b8 res args- WriteByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> do+ WriteByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp (Just (mo_WordTo16 platform)) b8 res args- WriteByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> do+ WriteByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp (Just (mo_WordTo32 platform)) b8 res args- WriteByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> do+ WriteByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp Nothing b8 res args -- Copying and setting byte arrays- CopyByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opIntoRegs $ \[] -> do+ CopyByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opIntoRegs $ \[] -> doCopyByteArrayOp src src_off dst dst_off n- CopyMutableByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opIntoRegs $ \[] -> do+ CopyMutableByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opIntoRegs $ \[] -> doCopyMutableByteArrayOp src src_off dst dst_off n- CopyByteArrayToAddrOp -> \[src,src_off,dst,n] -> opIntoRegs $ \[] -> do+ CopyByteArrayToAddrOp -> \[src,src_off,dst,n] -> opIntoRegs $ \[] -> doCopyByteArrayToAddrOp src src_off dst n- CopyMutableByteArrayToAddrOp -> \[src,src_off,dst,n] -> opIntoRegs $ \[] -> do+ CopyMutableByteArrayToAddrOp -> \[src,src_off,dst,n] -> opIntoRegs $ \[] -> doCopyMutableByteArrayToAddrOp src src_off dst n- CopyAddrToByteArrayOp -> \[src,dst,dst_off,n] -> opIntoRegs $ \[] -> do+ CopyAddrToByteArrayOp -> \[src,dst,dst_off,n] -> opIntoRegs $ \[] -> doCopyAddrToByteArrayOp src dst dst_off n- SetByteArrayOp -> \[ba,off,len,c] -> opIntoRegs $ \[] -> do+ SetByteArrayOp -> \[ba,off,len,c] -> opIntoRegs $ \[] -> doSetByteArrayOp ba off len c -- Comparing byte arrays- CompareByteArraysOp -> \[ba1,ba1_off,ba2,ba2_off,n] -> opIntoRegs $ \[res] -> do+ CompareByteArraysOp -> \[ba1,ba1_off,ba2,ba2_off,n] -> opIntoRegs $ \[res] -> doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n - BSwap16Op -> \[w] -> opIntoRegs $ \[res] -> do+ BSwap16Op -> \[w] -> opIntoRegs $ \[res] -> emitBSwapCall res w W16- BSwap32Op -> \[w] -> opIntoRegs $ \[res] -> do+ BSwap32Op -> \[w] -> opIntoRegs $ \[res] -> emitBSwapCall res w W32- BSwap64Op -> \[w] -> opIntoRegs $ \[res] -> do+ BSwap64Op -> \[w] -> opIntoRegs $ \[res] -> emitBSwapCall res w W64- BSwapOp -> \[w] -> opIntoRegs $ \[res] -> do+ BSwapOp -> \[w] -> opIntoRegs $ \[res] -> emitBSwapCall res w (wordWidth platform) - BRev8Op -> \[w] -> opIntoRegs $ \[res] -> do+ BRev8Op -> \[w] -> opIntoRegs $ \[res] -> emitBRevCall res w W8- BRev16Op -> \[w] -> opIntoRegs $ \[res] -> do+ BRev16Op -> \[w] -> opIntoRegs $ \[res] -> emitBRevCall res w W16- BRev32Op -> \[w] -> opIntoRegs $ \[res] -> do+ BRev32Op -> \[w] -> opIntoRegs $ \[res] -> emitBRevCall res w W32- BRev64Op -> \[w] -> opIntoRegs $ \[res] -> do+ BRev64Op -> \[w] -> opIntoRegs $ \[res] -> emitBRevCall res w W64- BRevOp -> \[w] -> opIntoRegs $ \[res] -> do+ BRevOp -> \[w] -> opIntoRegs $ \[res] -> emitBRevCall res w (wordWidth platform) -- Population count- PopCnt8Op -> \[w] -> opIntoRegs $ \[res] -> do+ PopCnt8Op -> \[w] -> opIntoRegs $ \[res] -> emitPopCntCall res w W8- PopCnt16Op -> \[w] -> opIntoRegs $ \[res] -> do+ PopCnt16Op -> \[w] -> opIntoRegs $ \[res] -> emitPopCntCall res w W16- PopCnt32Op -> \[w] -> opIntoRegs $ \[res] -> do+ PopCnt32Op -> \[w] -> opIntoRegs $ \[res] -> emitPopCntCall res w W32- PopCnt64Op -> \[w] -> opIntoRegs $ \[res] -> do+ PopCnt64Op -> \[w] -> opIntoRegs $ \[res] -> emitPopCntCall res w W64- PopCntOp -> \[w] -> opIntoRegs $ \[res] -> do+ PopCntOp -> \[w] -> opIntoRegs $ \[res] -> emitPopCntCall res w (wordWidth platform) -- Parallel bit deposit- Pdep8Op -> \[src, mask] -> opIntoRegs $ \[res] -> do+ Pdep8Op -> \[src, mask] -> opIntoRegs $ \[res] -> emitPdepCall res src mask W8- Pdep16Op -> \[src, mask] -> opIntoRegs $ \[res] -> do+ Pdep16Op -> \[src, mask] -> opIntoRegs $ \[res] -> emitPdepCall res src mask W16- Pdep32Op -> \[src, mask] -> opIntoRegs $ \[res] -> do+ Pdep32Op -> \[src, mask] -> opIntoRegs $ \[res] -> emitPdepCall res src mask W32- Pdep64Op -> \[src, mask] -> opIntoRegs $ \[res] -> do+ Pdep64Op -> \[src, mask] -> opIntoRegs $ \[res] -> emitPdepCall res src mask W64- PdepOp -> \[src, mask] -> opIntoRegs $ \[res] -> do+ PdepOp -> \[src, mask] -> opIntoRegs $ \[res] -> emitPdepCall res src mask (wordWidth platform) -- Parallel bit extract- Pext8Op -> \[src, mask] -> opIntoRegs $ \[res] -> do+ Pext8Op -> \[src, mask] -> opIntoRegs $ \[res] -> emitPextCall res src mask W8- Pext16Op -> \[src, mask] -> opIntoRegs $ \[res] -> do+ Pext16Op -> \[src, mask] -> opIntoRegs $ \[res] -> emitPextCall res src mask W16- Pext32Op -> \[src, mask] -> opIntoRegs $ \[res] -> do+ Pext32Op -> \[src, mask] -> opIntoRegs $ \[res] -> emitPextCall res src mask W32- Pext64Op -> \[src, mask] -> opIntoRegs $ \[res] -> do+ Pext64Op -> \[src, mask] -> opIntoRegs $ \[res] -> emitPextCall res src mask W64- PextOp -> \[src, mask] -> opIntoRegs $ \[res] -> do+ PextOp -> \[src, mask] -> opIntoRegs $ \[res] -> emitPextCall res src mask (wordWidth platform) -- count leading zeros- Clz8Op -> \[w] -> opIntoRegs $ \[res] -> do+ Clz8Op -> \[w] -> opIntoRegs $ \[res] -> emitClzCall res w W8- Clz16Op -> \[w] -> opIntoRegs $ \[res] -> do+ Clz16Op -> \[w] -> opIntoRegs $ \[res] -> emitClzCall res w W16- Clz32Op -> \[w] -> opIntoRegs $ \[res] -> do+ Clz32Op -> \[w] -> opIntoRegs $ \[res] -> emitClzCall res w W32- Clz64Op -> \[w] -> opIntoRegs $ \[res] -> do+ Clz64Op -> \[w] -> opIntoRegs $ \[res] -> emitClzCall res w W64- ClzOp -> \[w] -> opIntoRegs $ \[res] -> do+ ClzOp -> \[w] -> opIntoRegs $ \[res] -> emitClzCall res w (wordWidth platform) -- count trailing zeros- Ctz8Op -> \[w] -> opIntoRegs $ \[res] -> do+ Ctz8Op -> \[w] -> opIntoRegs $ \[res] -> emitCtzCall res w W8- Ctz16Op -> \[w] -> opIntoRegs $ \[res] -> do+ Ctz16Op -> \[w] -> opIntoRegs $ \[res] -> emitCtzCall res w W16- Ctz32Op -> \[w] -> opIntoRegs $ \[res] -> do+ Ctz32Op -> \[w] -> opIntoRegs $ \[res] -> emitCtzCall res w W32- Ctz64Op -> \[w] -> opIntoRegs $ \[res] -> do+ Ctz64Op -> \[w] -> opIntoRegs $ \[res] -> emitCtzCall res w W64- CtzOp -> \[w] -> opIntoRegs $ \[res] -> do+ CtzOp -> \[w] -> opIntoRegs $ \[res] -> emitCtzCall res w (wordWidth platform) -- Unsigned int to floating point conversions- WordToFloatOp -> \[w] -> opIntoRegs $ \[res] -> do+ WordToFloatOp -> \[w] -> opIntoRegs $ \[res] -> emitPrimCall [res] (MO_UF_Conv W32) [w]- WordToDoubleOp -> \[w] -> opIntoRegs $ \[res] -> do+ WordToDoubleOp -> \[w] -> opIntoRegs $ \[res] -> emitPrimCall [res] (MO_UF_Conv W64) [w] -- Atomic operations@@ -850,6 +850,10 @@ emitPrimCall [res] (MO_Xchg (wordWidth platform)) [src, value] InterlockedExchange_Int -> \[src, value] -> opIntoRegs $ \[res] -> emitPrimCall [res] (MO_Xchg (wordWidth platform)) [src, value]+ AtomicCompareExchange_Int -> \[dst, expected, new] -> opIntoRegs $ \[res] ->+ emitPrimCall [res] (MO_Cmpxchg (wordWidth platform)) [dst, expected, new]+ AtomicCompareExchange_Addr -> \[dst, expected, new] -> opIntoRegs $ \[res] ->+ emitPrimCall [res] (MO_Cmpxchg (wordWidth platform)) [dst, expected, new] -- SIMD primops (VecBroadcastOp vcat n w) -> \[e] -> opIntoRegs $ \[res] -> do@@ -999,59 +1003,59 @@ ty = vecCmmCat vcat w -- Prefetch- PrefetchByteArrayOp3 -> \args -> opIntoRegs $ \[] -> do+ PrefetchByteArrayOp3 -> \args -> opIntoRegs $ \[] -> doPrefetchByteArrayOp 3 args- PrefetchMutableByteArrayOp3 -> \args -> opIntoRegs $ \[] -> do+ PrefetchMutableByteArrayOp3 -> \args -> opIntoRegs $ \[] -> doPrefetchMutableByteArrayOp 3 args- PrefetchAddrOp3 -> \args -> opIntoRegs $ \[] -> do+ PrefetchAddrOp3 -> \args -> opIntoRegs $ \[] -> doPrefetchAddrOp 3 args- PrefetchValueOp3 -> \args -> opIntoRegs $ \[] -> do+ PrefetchValueOp3 -> \args -> opIntoRegs $ \[] -> doPrefetchValueOp 3 args - PrefetchByteArrayOp2 -> \args -> opIntoRegs $ \[] -> do+ PrefetchByteArrayOp2 -> \args -> opIntoRegs $ \[] -> doPrefetchByteArrayOp 2 args- PrefetchMutableByteArrayOp2 -> \args -> opIntoRegs $ \[] -> do+ PrefetchMutableByteArrayOp2 -> \args -> opIntoRegs $ \[] -> doPrefetchMutableByteArrayOp 2 args- PrefetchAddrOp2 -> \args -> opIntoRegs $ \[] -> do+ PrefetchAddrOp2 -> \args -> opIntoRegs $ \[] -> doPrefetchAddrOp 2 args- PrefetchValueOp2 -> \args -> opIntoRegs $ \[] -> do+ PrefetchValueOp2 -> \args -> opIntoRegs $ \[] -> doPrefetchValueOp 2 args- PrefetchByteArrayOp1 -> \args -> opIntoRegs $ \[] -> do+ PrefetchByteArrayOp1 -> \args -> opIntoRegs $ \[] -> doPrefetchByteArrayOp 1 args- PrefetchMutableByteArrayOp1 -> \args -> opIntoRegs $ \[] -> do+ PrefetchMutableByteArrayOp1 -> \args -> opIntoRegs $ \[] -> doPrefetchMutableByteArrayOp 1 args- PrefetchAddrOp1 -> \args -> opIntoRegs $ \[] -> do+ PrefetchAddrOp1 -> \args -> opIntoRegs $ \[] -> doPrefetchAddrOp 1 args- PrefetchValueOp1 -> \args -> opIntoRegs $ \[] -> do+ PrefetchValueOp1 -> \args -> opIntoRegs $ \[] -> doPrefetchValueOp 1 args - PrefetchByteArrayOp0 -> \args -> opIntoRegs $ \[] -> do+ PrefetchByteArrayOp0 -> \args -> opIntoRegs $ \[] -> doPrefetchByteArrayOp 0 args- PrefetchMutableByteArrayOp0 -> \args -> opIntoRegs $ \[] -> do+ PrefetchMutableByteArrayOp0 -> \args -> opIntoRegs $ \[] -> doPrefetchMutableByteArrayOp 0 args- PrefetchAddrOp0 -> \args -> opIntoRegs $ \[] -> do+ PrefetchAddrOp0 -> \args -> opIntoRegs $ \[] -> doPrefetchAddrOp 0 args- PrefetchValueOp0 -> \args -> opIntoRegs $ \[] -> do+ PrefetchValueOp0 -> \args -> opIntoRegs $ \[] -> doPrefetchValueOp 0 args -- Atomic read-modify-write- FetchAddByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> do+ FetchAddByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> doAtomicRMW res AMO_Add mba ix (bWord platform) n- FetchSubByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> do+ FetchSubByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> doAtomicRMW res AMO_Sub mba ix (bWord platform) n- FetchAndByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> do+ FetchAndByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> doAtomicRMW res AMO_And mba ix (bWord platform) n- FetchNandByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> do+ FetchNandByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> doAtomicRMW res AMO_Nand mba ix (bWord platform) n- FetchOrByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> do+ FetchOrByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> doAtomicRMW res AMO_Or mba ix (bWord platform) n- FetchXorByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> do+ FetchXorByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> doAtomicRMW res AMO_Xor mba ix (bWord platform) n- AtomicReadByteArrayOp_Int -> \[mba, ix] -> opIntoRegs $ \[res] -> do+ AtomicReadByteArrayOp_Int -> \[mba, ix] -> opIntoRegs $ \[res] -> doAtomicReadByteArray res mba ix (bWord platform)- AtomicWriteByteArrayOp_Int -> \[mba, ix, val] -> opIntoRegs $ \[] -> do+ AtomicWriteByteArrayOp_Int -> \[mba, ix, val] -> opIntoRegs $ \[] -> doAtomicWriteByteArray mba ix (bWord platform) val- CasByteArrayOp_Int -> \[mba, ix, old, new] -> opIntoRegs $ \[res] -> do+ CasByteArrayOp_Int -> \[mba, ix, old, new] -> opIntoRegs $ \[res] -> doCasByteArray res mba ix (bWord platform) old new -- The rest just translate straightforwardly@@ -2166,7 +2170,7 @@ checkVecCompatibility :: DynFlags -> PrimOpVecCat -> Length -> Width -> FCode () checkVecCompatibility dflags vcat l w = do- when (backend dflags /= LLVM) $ do+ when (backend dflags /= LLVM) $ sorry $ unlines ["SIMD vector instructions require the LLVM back-end." ,"Please use -fllvm."] check vecWidth vcat l w@@ -2929,7 +2933,7 @@ -- | Emit a call to @memcpy@. emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()-emitMemcpyCall dst src n align = do+emitMemcpyCall dst src n align = emitPrimCall [ {-no results-} ] (MO_Memcpy (alignmentBytes align))@@ -2937,7 +2941,7 @@ -- | Emit a call to @memmove@. emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()-emitMemmoveCall dst src n align = do+emitMemmoveCall dst src n align = emitPrimCall [ {- no results -} ] (MO_Memmove (alignmentBytes align))@@ -2946,7 +2950,7 @@ -- | Emit a call to @memset@. The second argument must fit inside an -- unsigned char. emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()-emitMemsetCall dst c n align = do+emitMemsetCall dst c n align = emitPrimCall [ {- no results -} ] (MO_Memset (alignmentBytes align))@@ -2970,56 +2974,56 @@ (MO_Memcmp align) [ ptr1, ptr2, n ] - unless is32Bit $ do+ unless is32Bit $ emit $ mkAssign (CmmLocal res) (CmmMachOp (mo_s_32ToWord platform) [(CmmReg (CmmLocal cres))]) emitBSwapCall :: LocalReg -> CmmExpr -> Width -> FCode ()-emitBSwapCall res x width = do+emitBSwapCall res x width = emitPrimCall [ res ] (MO_BSwap width) [ x ] emitBRevCall :: LocalReg -> CmmExpr -> Width -> FCode ()-emitBRevCall res x width = do+emitBRevCall res x width = emitPrimCall [ res ] (MO_BRev width) [ x ] emitPopCntCall :: LocalReg -> CmmExpr -> Width -> FCode ()-emitPopCntCall res x width = do+emitPopCntCall res x width = emitPrimCall [ res ] (MO_PopCnt width) [ x ] emitPdepCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode ()-emitPdepCall res x y width = do+emitPdepCall res x y width = emitPrimCall [ res ] (MO_Pdep width) [ x, y ] emitPextCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode ()-emitPextCall res x y width = do+emitPextCall res x y width = emitPrimCall [ res ] (MO_Pext width) [ x, y ] emitClzCall :: LocalReg -> CmmExpr -> Width -> FCode ()-emitClzCall res x width = do+emitClzCall res x width = emitPrimCall [ res ] (MO_Clz width) [ x ] emitCtzCall :: LocalReg -> CmmExpr -> Width -> FCode ()-emitCtzCall res x width = do+emitCtzCall res x width = emitPrimCall [ res ] (MO_Ctz width)
compiler/GHC/StgToCmm/Prof.hs view
@@ -186,7 +186,7 @@ enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode () enterCostCentreFun ccs closure =- ifProfiling $ do+ ifProfiling $ if isCurrentCCS ccs then do platform <- getPlatform emitRtsCall rtsUnitId (fsLit "enterFunCCS")
compiler/GHC/StgToCmm/Utils.hs view
@@ -608,7 +608,7 @@ -- remembered set. emitUpdRemSetPush :: CmmExpr -- ^ value of pointer which was overwritten -> FCode ()-emitUpdRemSetPush ptr = do+emitUpdRemSetPush ptr = emitRtsCall rtsUnitId (fsLit "updateRemembSetPushClosure_")@@ -618,7 +618,7 @@ emitUpdRemSetPushThunk :: CmmExpr -- ^ the thunk -> FCode ()-emitUpdRemSetPushThunk ptr = do+emitUpdRemSetPushThunk ptr = emitRtsCall rtsUnitId (fsLit "updateRemembSetPushThunk_")
compiler/GHC/SysTools.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+ {- ----------------------------------------------------------------------------- --@@ -8,8 +11,6 @@ ----------------------------------------------------------------------------- -} -{-# LANGUAGE CPP, MultiWayIf, ScopedTypeVariables #-}- module GHC.SysTools ( -- * Initialisation initSysTools,@@ -234,29 +235,31 @@ linkDynLib :: DynFlags -> [String] -> [UnitId] -> IO () linkDynLib dflags0 o_files dep_packages = do- let -- This is a rather ugly hack to fix dynamically linked+ let platform = targetPlatform dflags0+ os = platformOS platform++ -- This is a rather ugly hack to fix dynamically linked -- GHC on Windows. If GHC is linked with -threaded, then -- it links against libHSrts_thr. But if base is linked -- against libHSrts, then both end up getting loaded, -- and things go wrong. We therefore link the libraries -- with the same RTS flags that we link GHC with.- dflags1 = if platformMisc_ghcThreaded $ platformMisc dflags0- then addWay' WayThreaded dflags0- else dflags0- dflags = if platformMisc_ghcDebugged $ platformMisc dflags1- then addWay' WayDebug dflags1- else dflags1+ dflags | OSMinGW32 <- os+ , hostWays `hasWay` WayDyn+ = dflags0 { ways = hostWays }+ | otherwise+ = dflags0 verbFlags = getVerbFlags dflags o_file = outputFile dflags - pkgs <- getPreloadUnitsAnd+ pkgs_with_rts <- getPreloadUnitsAnd (initSDocContext dflags defaultUserStyle) (unitState dflags) (mkHomeUnitFromFlags dflags) dep_packages - let pkg_lib_paths = collectLibraryPaths (ways dflags) pkgs+ let pkg_lib_paths = collectLibraryPaths (ways dflags) pkgs_with_rts let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths get_pkg_lib_path_opts l | ( osElfTarget (platformOS (targetPlatform dflags)) ||@@ -273,24 +276,26 @@ let lib_paths = libraryPaths dflags let lib_path_opts = map ("-L"++) lib_paths - -- We don't want to link our dynamic libs against the RTS package,- -- because the RTS lib comes in several flavours and we want to be+ -- In general we don't want to link our dynamic libs against the RTS+ -- package, because the RTS lib comes in several flavours and we want to be -- able to pick the flavour when a binary is linked.- -- On Windows we need to link the RTS import lib as Windows does- -- not allow undefined symbols.- -- The RTS library path is still added to the library search path- -- above in case the RTS is being explicitly linked in (see #3807).- let platform = targetPlatform dflags- os = platformOS platform- pkgs_no_rts = case os of- OSMinGW32 ->- pkgs- _ | gopt Opt_LinkRts dflags ->- pkgs- | otherwise ->- 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+ --+ -- But:+ -- * on Windows we need to link the RTS import lib as Windows does not+ -- allow undefined symbols.+ --+ -- * the RTS library path is still added to the library search path above+ -- in case the RTS is being explicitly linked in (see #3807).+ --+ -- * if -flink-rts is used, we link with the rts.+ --+ let pkgs_without_rts = filter ((/= rtsUnitId) . unitId) pkgs_with_rts+ pkgs+ | OSMinGW32 <- os = pkgs_with_rts+ | gopt Opt_LinkRts dflags = pkgs_with_rts+ | otherwise = pkgs_without_rts+ pkg_link_opts = package_hs_libs ++ extra_libs ++ other_flags+ where (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs -- probably _stub.o files -- and last temporary shared object file
compiler/GHC/SysTools/ExtraObj.hs view
@@ -25,6 +25,7 @@ import GHC.SysTools.Elf import GHC.Utils.Misc import GHC.Prelude+import qualified GHC.Data.ShortText as ST import Control.Monad import Data.Maybe@@ -57,7 +58,7 @@ -- 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")+ ++ map (FileOption "-I" . ST.unpack) (unitIncludeDirs $ unsafeLookupUnit pkgs rtsUnit) -- When compiling assembler code, we drop the usual C options, and if the@@ -78,7 +79,7 @@ -- mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath mkExtraObjToLinkIntoBinary dflags = do- when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ do+ when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ putLogMsg dflags NoReason SevInfo noSrcSpan $ withPprStyle defaultUserStyle (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$
compiler/GHC/SysTools/Info.hs view
@@ -119,9 +119,9 @@ let platform = targetPlatform dflags os = platformOS platform (pgm,args0) = pgm_l dflags- args1 = map Option (getOpts dflags opt_l)- args2 = args0 ++ args1- args3 = filter notNull (map showOpt args2)+ args1 = map Option (getOpts dflags opt_l)+ args2 = args0 ++ args1+ args3 = filter notNull (map showOpt args2) -- Try to grab the info from the process output. parseLinkerInfo stdo _stde _exitc@@ -142,68 +142,67 @@ return (GnuGold [Option "-Wl,--no-as-needed"]) | any ("LLD" `isPrefixOf`) stdo =- return (LlvmLLD $ map Option [- -- see Note [ELF needed shared libs]- "-Wl,--no-as-needed"])+ return (LlvmLLD $ map Option [ --see Note [ELF needed shared libs]+ "-Wl,--no-as-needed"]) -- Unknown linker. | otherwise = fail "invalid --version output, or linker is unsupported" -- Process the executable call- info <- catchIO (do- case os of- OSSolaris2 ->- -- Solaris uses its own Solaris linker. Even all- -- GNU C are recommended to configure with Solaris- -- linker instead of using GNU binutils linker. Also- -- all GCC distributed with Solaris follows this rule- -- precisely so we assume here, the Solaris linker is- -- used.- return $ SolarisLD []- OSAIX ->- -- IBM AIX uses its own non-binutils linker as well- return $ AixLD []- OSDarwin ->- -- Darwin has neither GNU Gold or GNU LD, but a strange linker- -- that doesn't support --version. We can just assume that's- -- what we're using.- return $ DarwinLD []- OSMinGW32 ->- -- GHC doesn't support anything but GNU ld on Windows anyway.- -- Process creation is also fairly expensive on win32, so- -- we short-circuit here.- return $ GnuLD $ map Option- [ -- Reduce ld memory usage- "-Wl,--hash-size=31"- , "-Wl,--reduce-memory-overheads"- -- Emit gcc stack checks- -- Note [Windows stack usage]- , "-fstack-check"- -- Force static linking of libGCC- -- Note [Windows static libGCC]- , "-static-libgcc" ]- _ -> do- -- In practice, we use the compiler as the linker here. Pass- -- -Wl,--version to get linker version info.- (exitc, stdo, stde) <- readProcessEnvWithExitCode pgm- (["-Wl,--version"] ++ args3)- c_locale_env- -- Split the output by lines to make certain kinds- -- of processing easier. In particular, 'clang' and 'gcc'- -- have slightly different outputs for '-Wl,--version', but- -- it's still easy to figure out.- parseLinkerInfo (lines stdo) (lines stde) exitc- )- (\err -> do- debugTraceMsg dflags 2- (text "Error (figuring out linker information):" <+>- text (show err))- errorMsg dflags $ hang (text "Warning:") 9 $- text "Couldn't figure out linker information!" $$- text "Make sure you're using GNU ld, GNU gold" <+>- text "or the built in OS X linker, etc."- return UnknownLD)- return info+ catchIO (+ case os of+ OSSolaris2 ->+ -- Solaris uses its own Solaris linker. Even all+ -- GNU C are recommended to configure with Solaris+ -- linker instead of using GNU binutils linker. Also+ -- all GCC distributed with Solaris follows this rule+ -- precisely so we assume here, the Solaris linker is+ -- used.+ return $ SolarisLD []+ OSAIX ->+ -- IBM AIX uses its own non-binutils linker as well+ return $ AixLD []+ OSDarwin ->+ -- Darwin has neither GNU Gold or GNU LD, but a strange linker+ -- that doesn't support --version. We can just assume that's+ -- what we're using.+ return $ DarwinLD []+ OSMinGW32 ->+ -- GHC doesn't support anything but GNU ld on Windows anyway.+ -- Process creation is also fairly expensive on win32, so+ -- we short-circuit here.+ return $ GnuLD $ map Option+ [ -- Reduce ld memory usage+ "-Wl,--hash-size=31"+ , "-Wl,--reduce-memory-overheads"+ -- Emit gcc stack checks+ -- Note [Windows stack usage]+ , "-fstack-check"+ -- Force static linking of libGCC+ -- Note [Windows static libGCC]+ , "-static-libgcc" ]+ _ -> do+ -- In practice, we use the compiler as the linker here. Pass+ -- -Wl,--version to get linker version info.+ (exitc, stdo, stde) <- readProcessEnvWithExitCode pgm+ (["-Wl,--version"] ++ args3)+ c_locale_env+ -- Split the output by lines to make certain kinds+ -- of processing easier. In particular, 'clang' and 'gcc'+ -- have slightly different outputs for '-Wl,--version', but+ -- it's still easy to figure out.+ parseLinkerInfo (lines stdo) (lines stde) exitc+ )+ (\err -> do+ debugTraceMsg dflags 2+ (text "Error (figuring out linker information):" <+>+ text (show err))+ errorMsg dflags $ hang (text "Warning:") 9 $+ text "Couldn't figure out linker information!" $$+ text "Make sure you're using GNU ld, GNU gold" <+>+ text "or the built in OS X linker, etc."+ return UnknownLD+ ) -- Grab compiler info and cache it in DynFlags. getCompilerInfo :: DynFlags -> IO CompilerInfo@@ -244,19 +243,19 @@ | otherwise = fail $ "invalid -v output, or compiler is unsupported: " ++ unlines stde -- Process the executable call- info <- catchIO (do- (exitc, stdo, stde) <-- readProcessEnvWithExitCode pgm ["-v"] c_locale_env- -- Split the output by lines to make certain kinds- -- of processing easier.- parseCompilerInfo (lines stdo) (lines stde) exitc- )- (\err -> do- debugTraceMsg dflags 2- (text "Error (figuring out C compiler information):" <+>- text (show err))- errorMsg dflags $ hang (text "Warning:") 9 $- text "Couldn't figure out C compiler information!" $$- text "Make sure you're using GNU gcc, or clang"- return UnknownCC)- return info+ catchIO (do+ (exitc, stdo, stde) <-+ readProcessEnvWithExitCode pgm ["-v"] c_locale_env+ -- Split the output by lines to make certain kinds+ -- of processing easier.+ parseCompilerInfo (lines stdo) (lines stde) exitc+ )+ (\err -> do+ debugTraceMsg dflags 2+ (text "Error (figuring out C compiler information):" <+>+ text (show err))+ errorMsg dflags $ hang (text "Warning:") 9 $+ text "Couldn't figure out C compiler information!" $$+ text "Make sure you're using GNU gcc, or clang"+ return UnknownCC+ )
compiler/GHC/SysTools/Process.hs view
@@ -203,7 +203,7 @@ :: DynFlags -> (String->String) -> String -> String -> [Option] -> Maybe FilePath -> Maybe [(String,String)] -> IO () -runSomethingFiltered dflags filter_fn phase_name pgm args mb_cwd mb_env = do+runSomethingFiltered dflags filter_fn phase_name pgm args mb_cwd mb_env = runSomethingWith dflags phase_name pgm args $ \real_args -> do r <- builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env return (r,())@@ -325,12 +325,12 @@ loop (l:ls) in_err = case in_err of Just err@(BuildError srcLoc msg)- | leading_whitespace l -> do+ | leading_whitespace l -> loop ls (Just (BuildError srcLoc (msg $$ text l))) | otherwise -> do writeChan chan err checkError l ls- Nothing -> do+ Nothing -> checkError l ls _ -> panic "readerProc/loop"
compiler/GHC/SysTools/Tasks.hs view
@@ -9,26 +9,26 @@ ----------------------------------------------------------------------------- module GHC.SysTools.Tasks where -import GHC.Utils.Exception as Exception-import GHC.Utils.Error-import GHC.Driver.Types-import GHC.Driver.Session-import GHC.Utils.Outputable-import GHC.Platform-import GHC.Utils.Misc--import Data.List--import System.IO-import System.Process import GHC.Prelude+import GHC.Platform+import GHC.ForeignSrcLang import GHC.CmmToLlvm.Base (LlvmVersion, llvmVersionStr, supportedLlvmVersion, parseLlvmVersion) import GHC.SysTools.Process import GHC.SysTools.Info +import GHC.Driver.Session++import GHC.Utils.Exception as Exception+import GHC.Utils.Error+import GHC.Utils.Outputable+import GHC.Utils.Misc++import Data.List import Control.Monad (join, forM, filterM)+import System.IO+import System.Process import System.Directory (doesFileExist) import System.FilePath ((</>)) @@ -191,9 +191,8 @@ args1 = map Option (getOpts dflags opt_a) args2 = args0 ++ args1 ++ args mb_env <- getGccEnv args2- catch (do- runSomethingFiltered dflags id "Clang (Assembler)" clang args2 Nothing mb_env- )+ catch+ (runSomethingFiltered dflags id "Clang (Assembler)" clang args2 Nothing mb_env) (\(err :: SomeException) -> do errorMsg dflags $ text ("Error running clang! you need clang installed to use the" ++
compiler/GHC/Tc/Deriv.hs view
@@ -26,11 +26,10 @@ import GHC.Core.Predicate import GHC.Tc.Deriv.Infer import GHC.Tc.Deriv.Utils-import GHC.Tc.Validity( allDistinctTyVars ) import GHC.Tc.TyCl.Class( instDeclCtxt3, tcATDefault ) import GHC.Tc.Utils.Env import GHC.Tc.Deriv.Generate-import GHC.Tc.Validity( checkValidInstHead )+import GHC.Tc.Validity( allDistinctTyVars, checkValidInstHead ) import GHC.Core.InstEnv import GHC.Tc.Utils.Instantiate import GHC.Core.FamInstEnv@@ -2049,8 +2048,7 @@ , dit_rep_tc_args = rep_tc_args } , dsm_stock_gen_fn = gen_fn }- -> do (binds, faminsts, field_names) <- gen_fn loc rep_tc rep_tc_args inst_tys- pure (binds, [], faminsts, field_names)+ -> gen_fn loc rep_tc rep_tc_args inst_tys -- Try DeriveAnyClass DerivSpecAnyClass -> do
compiler/GHC/Tc/Deriv/Generate.hs view
@@ -46,8 +46,10 @@ import GHC.Hs import GHC.Types.Name.Reader import GHC.Types.Basic+import GHC.Types.Fixity import GHC.Core.DataCon import GHC.Types.Name+import GHC.Types.SourceText import GHC.Driver.Session import GHC.Builtin.Utils
compiler/GHC/Tc/Deriv/Generics.hs view
@@ -1,14 +1,15 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- (c) The University of Glasgow 2011 -} -{-# LANGUAGE CPP, ScopedTypeVariables, TupleSections #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- -- | The deriving code for the Generic class module GHC.Tc.Deriv.Generics (canDoGenerics@@ -36,13 +37,16 @@ import GHC.Iface.Env ( newGlobalBinder ) import GHC.Types.Name hiding ( varName ) import GHC.Types.Name.Reader+import GHC.Types.Fixity.Env+import GHC.Types.SourceText+import GHC.Types.Fixity import GHC.Types.Basic import GHC.Builtin.Types.Prim import GHC.Builtin.Types import GHC.Builtin.Names import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad-import GHC.Driver.Types+import GHC.Driver.Session import GHC.Utils.Error( Validity(..), andValid ) import GHC.Types.SrcLoc import GHC.Data.Bag@@ -75,10 +79,12 @@ -} gen_Generic_binds :: GenericKind -> TyCon -> [Type]- -> TcM (LHsBinds GhcPs, FamInst)+ -> TcM (LHsBinds GhcPs, [LSig GhcPs], FamInst) gen_Generic_binds gk tc inst_tys = do+ dflags <- getDynFlags repTyInsts <- tc_mkRepFamInsts gk tc inst_tys- return (mkBindsRep gk tc, repTyInsts)+ let (binds, sigs) = mkBindsRep dflags gk tc+ return (binds, sigs, repTyInsts) {- ************************************************************************@@ -331,12 +337,33 @@ -- Bindings for the Generic instance-mkBindsRep :: GenericKind -> TyCon -> LHsBinds GhcPs-mkBindsRep gk tycon =- unitBag (mkRdrFunBind (L loc from01_RDR) [from_eqn])- `unionBags`- unitBag (mkRdrFunBind (L loc to01_RDR) [to_eqn])+mkBindsRep :: DynFlags -> GenericKind -> TyCon -> (LHsBinds GhcPs, [LSig GhcPs])+mkBindsRep dflags gk tycon = (binds, sigs) where+ binds = unitBag (mkRdrFunBind (L loc from01_RDR) [from_eqn])+ `unionBags`+ unitBag (mkRdrFunBind (L loc to01_RDR) [to_eqn])++ -- See Note [Generics performance tricks]+ sigs = if gopt Opt_InlineGenericsAggressively dflags+ || (gopt Opt_InlineGenerics dflags && inlining_useful)+ then [inline1 from01_RDR, inline1 to01_RDR]+ else []+ where+ inlining_useful+ | cons <= 1 = True+ | cons <= 4 = max_fields <= 5+ | cons <= 8 = max_fields <= 2+ | cons <= 16 = max_fields <= 1+ | cons <= 24 = max_fields == 0+ | otherwise = False+ where+ cons = length datacons+ max_fields = maximum $ map dataConSourceArity datacons++ inline1 f = L loc . InlineSig noExtField (L loc f)+ $ alwaysInlinePragma { inl_act = ActiveAfter NoSourceText 1 }+ -- The topmost M1 (the datatype metadata) has the exact same type -- across all cases of a from/to definition, and can be factored out -- to save some allocations during typechecking.@@ -1038,4 +1065,48 @@ A simple change, but one that pays off, since it goes turns an O(n) amount of coercions to an O(1) amount.++Note [Generics performance tricks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Generics-based algorithms tend to rely on GHC optimizing away the intermediate+representation for optimal performance. However, the default unfolding threshold+is usually too small for GHC to do that.++The recommended approach thus far was to increase unfolding threshold, but this+makes GHC inline more aggressively in general, whereas it should only be more+aggresive with generics-based code.++The solution is to use a heuristic that'll annotate Generic class methods with+INLINE[1] pragmas (the explicit phase is used to give users phase control as+they can annotate their functions with INLINE[2] or INLINE[0] if appropriate).++The current heuristic was chosen by looking at how annotating Generic methods+INLINE[1] helps with optimal code generation for several types of generic+algorithms:++* Round trip through the generic representation.++* Generation of NFData instances.++* Generation of field lenses.++The experimentation was done by picking data types having N constructors with M+fields each and using their derived Generic instances to generate code with the+above algorithms.++The results are threshold values for N and M (contained in+`mkBindsRep.inlining_useful`) for which inlining is beneficial, i.e. it usually+leads to performance improvements at both compile time (the simplifier has to do+more work, but then there's much less code left for subsequent phases to work+with) and run time (the generic representation of a data type is optimized+away).++The T11068 test case, which includes the algorithms mentioned above, tests that+the generic representations of several data types optimize away using the+threshold values in `mkBindsRep.inlining_useful`.++If one uses threshold values higher what is found in+`mkBindsRep.inlining_useful`, then annotating Generic class methods with INLINE+pragmas tends to be at best useless and at worst lead to code size blowup+without runtime performance improvements. -}
compiler/GHC/Tc/Deriv/Infer.hs view
@@ -368,8 +368,7 @@ ; return (mkThetaOrigin (mkDerivOrigin wildcard) TypeLevel meth_tvs dm_tvs meth_theta (tau_eq:dm_theta)) } - ; theta_origins <- lift $ mapM do_one_meth gen_dms- ; return theta_origins }+ ; lift $ mapM do_one_meth gen_dms } -- Like 'inferConstraints', but used only for @GeneralizedNewtypeDeriving@ and -- @DerivingVia@. Since both strategies generate code involving 'coerce', the@@ -464,8 +463,7 @@ Note [Simplifying the instance context]. In the functor-like case, we may need to unify some kind variables with * in-order for the generated instance to be well-kinded. An example from-#10524:+order for the generated instance to be well-kinded. An example from #10524: newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1) = Compose (f (g a)) deriving Functor
compiler/GHC/Tc/Deriv/Utils.hs view
@@ -30,12 +30,13 @@ import GHC.Core.DataCon import GHC.Driver.Session import GHC.Utils.Error-import GHC.Driver.Types (lookupFixity, mi_fix)+import GHC.Types.Fixity.Env (lookupFixity) import GHC.Hs import GHC.Tc.Utils.Instantiate import GHC.Core.InstEnv import GHC.Iface.Load (loadInterfaceForName) import GHC.Unit.Module (getModule)+import GHC.Unit.Module.ModIface (mi_fix) import GHC.Types.Name import GHC.Utils.Outputable import GHC.Utils.Panic@@ -222,19 +223,22 @@ SrcSpan -> TyCon -- dit_rep_tc -> [Type] -- dit_rep_tc_args -> [Type] -- inst_tys- -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])- -- ^ This function returns three things:+ -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name])+ -- ^ This function returns four things: -- -- 1. @LHsBinds GhcPs@: The derived instance's function bindings -- (e.g., @compare (T x) (T y) = compare x y@) --- -- 2. @BagDerivStuff@: Auxiliary bindings needed to support the derived+ -- 2. @[LSig GhcPs]@: A list of instance specific signatures/pragmas.+ -- Most likely INLINE pragmas for class methods.+ --+ -- 3. @BagDerivStuff@: Auxiliary bindings needed to support the derived -- instance. As examples, derived 'Generic' instances require -- associated type family instances, and derived 'Eq' and 'Ord' -- instances require top-level @con2tag@ functions. -- See @Note [Auxiliary binders]@ in "GHC.Tc.Deriv.Generate". --- -- 3. @[Name]@: A list of Names for which @-Wunused-binds@ should be+ -- 4. @[Name]@: A list of Names for which @-Wunused-binds@ should be -- suppressed. This is used to suppress unused warnings for record -- selectors when deriving 'Read', 'Show', or 'Generic'. -- See @Note [Deriving and unused record selectors]@.@@ -427,7 +431,7 @@ data OriginativeDerivStatus = CanDeriveStock -- Stock class, can derive (SrcSpan -> TyCon -> [Type] -> [Type]- -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))+ -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name])) | StockClassError SDoc -- Stock class, but can't do it | CanDeriveAnyClass -- See Note [Deriving any class] | NonDerivableClass SDoc -- Cannot derive with either stock or anyclass@@ -566,7 +570,7 @@ -> TyCon -> [Type] -> [Type]- -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))+ -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name])) hasStockDeriving clas = assocMaybe gen_list (getUnique clas) where@@ -575,7 +579,7 @@ -> TyCon -> [Type] -> [Type]- -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))]+ -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]))] gen_list = [ (eqClassKey, simpleM gen_Eq_binds) , (ordClassKey, simpleM gen_Ord_binds) , (enumClassKey, simpleM gen_Enum_binds)@@ -593,7 +597,7 @@ simple gen_fn loc tc tc_args _ = let (binds, deriv_stuff) = gen_fn loc tc tc_args- in return (binds, deriv_stuff, [])+ 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@@ -601,18 +605,18 @@ -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate. simpleM gen_fn loc tc tc_args _ = do { (binds, deriv_stuff) <- gen_fn loc tc tc_args- ; return (binds, deriv_stuff, []) }+ ; return (binds, [], deriv_stuff, []) } read_or_show gen_fn loc tc tc_args _ = do { fix_env <- getDataConFixityFun tc ; let (binds, deriv_stuff) = gen_fn fix_env loc tc tc_args field_names = all_field_names tc- ; return (binds, deriv_stuff, field_names) }+ ; return (binds, [], deriv_stuff, field_names) } generic gen_fn _ tc _ inst_tys- = do { (binds, faminst) <- gen_fn tc inst_tys+ = do { (binds, sigs, faminst) <- gen_fn tc inst_tys ; let field_names = all_field_names tc- ; return (binds, unitBag (DerivFamInst faminst), field_names) }+ ; return (binds, sigs, unitBag (DerivFamInst faminst), field_names) } -- See Note [Deriving and unused record selectors] all_field_names = map flSelector . concatMap dataConFieldLabels@@ -1113,8 +1117,7 @@ data T a b = C (Show a) b => MkT b Here, the existential context (C (Show a) b) does technically mention the last-type variable b. But this is OK, because expanding the type synonym C would-give us the context (Show a), which doesn't mention b. Therefore, we must make-sure to expand type synonyms before performing this check. Not doing so led to-#13813.+type variable b. But this is OK, because expanding the type synonym C would give+us the context (Show a), which doesn't mention b. Therefore, we must make sure+to expand type synonyms before performing this check. Not doing so led to #13813. -}
compiler/GHC/Tc/Errors.hs view
@@ -1,7 +1,6 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
compiler/GHC/Tc/Errors/Hole.hs view
@@ -27,6 +27,7 @@ import GHC.Types.Id import GHC.Types.Var.Set import GHC.Types.Var.Env+import GHC.Types.TyThing import GHC.Data.Bag import GHC.Core.ConLike ( ConLike(..) ) import GHC.Utils.Misc@@ -50,7 +51,7 @@ import GHC.HsToCore.Docs ( extractDocs ) import qualified Data.Map as Map import GHC.Hs.Doc ( unpackHDS, DeclDocMap(..) )-import GHC.Driver.Types ( ModIface_(..) )+import GHC.Unit.Module.ModIface ( ModIface_(..) ) import GHC.Iface.Load ( loadInterfaceForNameMaybe ) import GHC.Builtin.Utils (knownKeyNames)@@ -601,7 +602,7 @@ ; traceTc "findingValidHoleFitsFor }" empty ; return (tidy_env, vMsg $$ refMsg) } where- -- We extract the type, the tcLevel and the types free variables+ -- We extract the type, the TcLevel and the types free variables -- from the constraint. hole_fvs :: FV hole_fvs = tyCoFVsOfType hole_ty
compiler/GHC/Tc/Gen/Annotation.hs view
@@ -12,18 +12,23 @@ import GHC.Prelude +import GHC.Driver.Session+import GHC.Driver.Env+ import {-# SOURCE #-} GHC.Tc.Gen.Splice ( runAnnotation )+import GHC.Tc.Utils.Monad+ import GHC.Unit.Module-import GHC.Driver.Session-import Control.Monad ( when ) import GHC.Hs++import GHC.Utils.Outputable+ import GHC.Types.Name import GHC.Types.Annotations-import GHC.Tc.Utils.Monad import GHC.Types.SrcLoc-import GHC.Utils.Outputable-import GHC.Driver.Types++import Control.Monad ( when ) -- Some platforms don't support the interpreter, and compilation on those -- platforms shouldn't fail just due to annotations
compiler/GHC/Tc/Gen/App.hs view
@@ -1,16 +1,19 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- % (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies, DataKinds, GADTs, TypeApplications #-}-{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- module GHC.Tc.Gen.App ( tcApp , tcInferSigma@@ -196,7 +199,7 @@ The "list of arguments" is [HsExprArg], described in Note [HsExprArg]. in GHC.Tc.Gen.Head -2. Use tcInferAppHead to infer the type of the fuction,+2. Use tcInferAppHead to infer the type of the function, as an (uninstantiated) TcSigmaType There are special cases for HsVar, HsRecFld, and ExprWithTySig@@ -588,7 +591,7 @@ data A k :: k -> Type -- A :: forall k -> k -> Type type KindOf (a :: k) = k -- KindOf :: forall k. k -> Type- a = (undefind :: KindOf A) @Int+ a = (undefined :: KindOf A) @Int With ImpredicativeTypes (thin ice, I know), we instantiate KindOf at type (forall k -> k -> Type), so@@ -645,8 +648,8 @@ (checkExpectedKind zonks as it goes). So we must zonk inner_ty as well, to guarantee consistency between zonk(tv)-and inner_ty. Otherwise we can build an ill-kinded type. An example was-#14158, where we had:+and inner_ty. Otherwise we can build an ill-kinded type. An example was #14158,+where we had: id :: forall k. forall (cat :: k -> k -> *). forall (a :: k). cat a a and we had the visible type application id @(->)
compiler/GHC/Tc/Gen/Arrow.hs view
@@ -1,13 +1,13 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -}--{-# LANGUAGE RankNTypes, TupleSections #-}-{-# LANGUAGE TypeFamilies #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -- | Typecheck arrow notation module GHC.Tc.Gen.Arrow ( tcProc ) where
compiler/GHC/Tc/Gen/Bind.hs view
@@ -1,14 +1,15 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}- module GHC.Tc.Gen.Bind ( tcLocalBinds , tcTopBinds@@ -48,6 +49,7 @@ import GHC.Core.Type (mkStrLitTy, tidyOpenType, mkCastTy) import GHC.Builtin.Types.Prim import GHC.Builtin.Types( mkBoxedTupleTy )+import GHC.Types.SourceText import GHC.Types.Id import GHC.Types.Var as Var import GHC.Types.Var.Set
compiler/GHC/Tc/Gen/Export.hs view
@@ -1,9 +1,7 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-} module GHC.Tc.Gen.Export (tcRnExports, exports_from_avail) where @@ -11,7 +9,6 @@ import GHC.Hs import GHC.Builtin.Names-import GHC.Types.Name.Reader import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcType@@ -19,29 +16,32 @@ import GHC.Rename.Env import GHC.Rename.Unbound ( reportUnboundName ) import GHC.Utils.Error-import GHC.Types.Id-import GHC.Types.Id.Info import GHC.Unit.Module-import GHC.Types.Name-import GHC.Types.Name.Env-import GHC.Types.Name.Set-import GHC.Types.Avail+import GHC.Unit.Module.Imported import GHC.Core.TyCon-import GHC.Types.SrcLoc as SrcLoc-import GHC.Driver.Types import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.PatSyn import GHC.Data.Maybe-import GHC.Types.Unique.Set import GHC.Utils.Misc (capitalise) import GHC.Data.FastString (fsLit) +import GHC.Types.Unique.Set+import GHC.Types.SrcLoc as SrcLoc+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Name.Set+import GHC.Types.Avail+import GHC.Types.SourceFile+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.TyThing+import GHC.Types.Name.Reader+ import Control.Monad import GHC.Driver.Session-import GHC.Rename.Doc ( rnHsDoc ) import GHC.Parser.PostProcess ( setRdrNameSpace ) import Data.Either ( partitionEithers ) @@ -323,9 +323,8 @@ , new_exports))) } exports_from_item acc@(ExportAccum occs mods) (L loc ie)- | isDoc ie- = do new_ie <- lookup_doc_ie ie- return (Just (acc, (L loc new_ie, [])))+ | Just new_ie <- lookup_doc_ie ie+ = return (Just (acc, (L loc new_ie, []))) | otherwise = do (new_ie, avail) <- lookup_ie ie@@ -406,13 +405,11 @@ return (L l name, non_flds, flds) -------------- lookup_doc_ie :: IE GhcPs -> RnM (IE GhcRn)- lookup_doc_ie (IEGroup _ lev doc) = do rn_doc <- rnHsDoc doc- return (IEGroup noExtField lev rn_doc)- lookup_doc_ie (IEDoc _ doc) = do rn_doc <- rnHsDoc doc- return (IEDoc noExtField rn_doc)- lookup_doc_ie (IEDocNamed _ str) = return (IEDocNamed noExtField str)- lookup_doc_ie _ = panic "lookup_doc_ie" -- Other cases covered earlier+ lookup_doc_ie :: IE GhcPs -> Maybe (IE GhcRn)+ lookup_doc_ie (IEGroup _ lev doc) = Just (IEGroup noExtField lev doc)+ lookup_doc_ie (IEDoc _ doc) = Just (IEDoc noExtField doc)+ lookup_doc_ie (IEDocNamed _ str) = Just (IEDocNamed noExtField str)+ lookup_doc_ie _ = Nothing -- In an export item M.T(A,B,C), we want to treat the uses of -- A,B,C as if they were M.A, M.B, M.C@@ -431,12 +428,6 @@ where n = gre_name gre -isDoc :: IE GhcPs -> Bool-isDoc (IEDoc {}) = True-isDoc (IEDocNamed {}) = True-isDoc (IEGroup {}) = True-isDoc _ = False- -- Renaming and typechecking of exports happens after everything else has -- been typechecked. @@ -589,7 +580,7 @@ -- -- Note: [Types of TyCon] ----- This check appears to be overlly complicated, Richard asked why it+-- This check appears to be overly complicated, Richard asked why it -- is not simply just `isAlgTyCon`. The answer for this is that -- a classTyCon is also an `AlgTyCon` which we explicitly want to disallow. -- (It is either a newtype or data depending on the number of methods)
compiler/GHC/Tc/Gen/Expr.hs view
@@ -1,3 +1,13 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+ -- in module GHC.Hs.Extension+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- % (c) The University of Glasgow 2006@@ -5,14 +15,6 @@ -} -{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies, DataKinds, TypeApplications #-}-{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]- -- in module GHC.Hs.Extension--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- module GHC.Tc.Gen.Expr ( tcCheckPolyExpr, tcCheckPolyExprNC, tcCheckMonoExpr, tcCheckMonoExprNC, tcMonoExpr, tcMonoExprNC,@@ -30,10 +32,12 @@ import {-# SOURCE #-} GHC.Tc.Gen.Splice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket ) import GHC.Hs+import GHC.Rename.Utils import GHC.Tc.Utils.Zonk import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Unify import GHC.Types.Basic+import GHC.Types.SourceText import GHC.Core.Multiplicity import GHC.Core.UsageEnv import GHC.Tc.Utils.Instantiate@@ -99,7 +103,7 @@ -- 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.+-- to do so themselves. tcCheckPolyExpr expr res_ty = tcPolyExpr expr (mkCheckExpType res_ty) tcCheckPolyExprNC expr res_ty = tcPolyExprNC expr (mkCheckExpType res_ty)@@ -509,8 +513,7 @@ where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody } tcExpr (HsDo _ do_or_lc stmts) res_ty- = do { expr' <- tcDoStmts do_or_lc stmts res_ty- ; return expr' }+ = tcDoStmts do_or_lc stmts res_ty tcExpr (HsProc x pat cmd) res_ty = do { (pat', cmd', coi) <- tcProc pat cmd res_ty@@ -1033,7 +1036,9 @@ ---------------- tcTupArgs :: [LHsTupArg GhcRn] -> [TcSigmaType] -> TcM [LHsTupArg GhcTc] tcTupArgs args tys- = ASSERT( equalLength args tys ) mapM go (args `zip` tys)+ = do MASSERT( equalLength args tys )+ checkTupSize (length args)+ mapM go (args `zip` tys) where go (L l (Missing {}), arg_ty) = do { mult <- newFlexiTyVarTy multiplicityTy ; return (L l (Missing (Scaled mult arg_ty))) }@@ -1685,7 +1690,7 @@ checkClosed type_env n = checkLoop type_env (unitNameSet n) n checkLoop :: TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason- checkLoop type_env visited n = do+ checkLoop type_env visited n = -- The @visited@ set is an accumulating parameter that contains the set of -- visited nodes, so we avoid repeating cycles in the traversal. case lookupNameEnv type_env n of
compiler/GHC/Tc/Gen/Foreign.hs view
@@ -58,6 +58,7 @@ import GHC.Types.Name.Reader import GHC.Core.DataCon import GHC.Core.TyCon+import GHC.Core.TyCon.RecWalk import GHC.Tc.Utils.TcType import GHC.Builtin.Names import GHC.Driver.Session
compiler/GHC/Tc/Gen/Head.hs view
@@ -1,16 +1,20 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- % (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies, DataKinds, GADTs, TypeApplications #-}-{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- module GHC.Tc.Gen.Head ( HsExprArg(..), EValArg(..), TcPass(..), Rebuilder , splitHsApps@@ -326,7 +330,7 @@ -- See Note [Application chains and heads] in GHC.Tc.Gen.App -- We get back a /SigmaType/ because we have special cases for -- * A bare identifier (just look it up)--- This case also covers a record selectro HsRecFld+-- This case also covers a record selector HsRecFld -- * An expression with a type signature (e :: ty) -- See Note [Application chains and heads] in GHC.Tc.Gen.App --@@ -593,9 +597,9 @@ where lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt) lookupParent gre = do { id <- tcLookupId (gre_name gre)- ; if isRecordSelector id- then return (recordSelectorTyCon id, gre)- else failWithTc (notSelector (gre_name gre)) }+ ; case recordSelectorTyCon_maybe id of+ Just rstc -> return (rstc, gre)+ Nothing -> failWithTc (notSelector (gre_name gre)) } fieldNotInType :: RecSelParent -> RdrName -> SDoc@@ -751,6 +755,7 @@ tc_infer_id :: Name -> TcM (HsExpr GhcTc, TcSigmaType) tc_infer_id id_name = do { thing <- tcLookup id_name+ ; global_env <- getGlobalRdrEnv ; case thing of ATcId { tct_id = id } -> do { check_local_id occ id@@ -768,9 +773,31 @@ | otherwise -> nonBidirectionalErr id_name + AGlobal (ATyCon ty_con)+ -> fail_tycon global_env ty_con++ ATyVar name _+ -> failWithTc $+ text "Illegal term-level use of the type variable"+ <+> quotes (ppr name)+ $$ nest 2 (text "bound at" <+> ppr (getSrcLoc name))++ ATcTyCon ty_con+ -> fail_tycon global_env ty_con+ _ -> failWithTc $ ppr thing <+> text "used where a value identifier was expected" } where+ fail_tycon global_env ty_con =+ let pprov = case lookupGRE_Name global_env (tyConName ty_con) of+ Just gre -> nest 2 (pprNameProvenance gre)+ Nothing -> empty+ in failWithTc (term_level_tycons ty_con $$ pprov)++ term_level_tycons ty_con+ = text "Illegal term-level use of the type constructor"+ <+> quotes (ppr (tyConName ty_con))+ occ = nameOccName id_name return_id id = return (HsVar noExtField (noLoc id), idType id)@@ -1089,8 +1116,8 @@ than supplied arguments. Previously, GHC computed the number of argument types through tcSplitSigmaTy.-This is incorrect in the face of nested foralls, however! This caused Trac-#13311, for instance:+This is incorrect in the face of nested foralls, however!+This caused Ticket #13311, for instance: f :: forall a. (Monoid a) => forall b. (Monoid b) => Maybe a -> Maybe b @@ -1140,4 +1167,3 @@ exprCtxt :: HsExpr GhcRn -> SDoc exprCtxt expr = hang (text "In the expression:") 2 (ppr (stripParensHsExpr expr))-
compiler/GHC/Tc/Gen/HsType.hs view
@@ -1,17 +1,17 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE CPP, TupleSections, MultiWayIf, RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- -- | Typechecking user-specified @MonoTypes@ module GHC.Tc.Gen.HsType ( -- Type signatures@@ -71,12 +71,12 @@ import GHC.Prelude import GHC.Hs+import GHC.Rename.Utils 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@@ -86,7 +86,8 @@ import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr import GHC.Tc.Utils.TcType-import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBindersN, tcInstInvisibleTyBinder )+import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBinders, tcInstInvisibleTyBindersN,+ tcInstInvisibleTyBinder ) import GHC.Core.Type import GHC.Builtin.Types.Prim import GHC.Types.Name.Env@@ -103,8 +104,6 @@ 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@@ -116,6 +115,7 @@ import GHC.Builtin.Names hiding ( wildCardName ) import GHC.Driver.Session import qualified GHC.LanguageExtensions as LangExt+import GHC.Parser.Annotation import GHC.Data.Maybe import GHC.Data.Bag( unitBag )@@ -1041,15 +1041,12 @@ = 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 (HsFunTy _ mult ty1 ty2) exp_kind+ = 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+ = tc_fun_type mode (HsUnrestrictedArrow NormalSyntax) ty1 ty2 exp_kind --------- Foralls tc_hs_type mode forall@(HsForAllTy { hst_tele = tele, hst_body = ty }) exp_kind@@ -1135,16 +1132,8 @@ ; 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-#if __GLASGOW_HASKELL__ <= 810- _ -> panic "tc_hs_type HsTupleTy"-#endif+tc_hs_type mode rn_ty@(HsTupleTy _ HsUnboxedTuple tys) exp_kind+ = tc_tuple rn_ty mode UnboxedTuple tys exp_kind tc_hs_type mode rn_ty@(HsSumTy _ hs_tys) exp_kind = do { let arity = length hs_tys@@ -1175,6 +1164,7 @@ ; let kind_con = tupleTyCon Boxed arity ty_con = promotedTupleDataCon Boxed arity tup_k = mkTyConApp kind_con ks+ ; checkTupSize arity ; checkExpectedKind rn_ty (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind } where arity = length tys@@ -1195,8 +1185,8 @@ --------- Literals tc_hs_type _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind- = do { checkWiredInTyCon typeNatKindCon- ; checkExpectedKind rn_ty (mkNumLitTy n) typeNatKind exp_kind }+ = do { checkWiredInTyCon naturalTyCon+ ; checkExpectedKind rn_ty (mkNumLitTy n) naturalTy exp_kind } tc_hs_type _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind = do { checkWiredInTyCon typeSymbolKindCon@@ -1329,33 +1319,28 @@ -- 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- -> let tycon = cTupleTyCon arity in- check_expected_kind (mkTyConApp tycon tau_tys) constraintKind+ -> do let tycon = cTupleTyCon arity+ checkCTupSize arity+ check_expected_kind (mkTyConApp tycon tau_tys) constraintKind BoxedTuple -> do let tycon = tupleTyCon Boxed arity+ checkTupSize arity checkWiredInTyCon tycon check_expected_kind (mkTyConApp tycon tau_tys) liftedTypeKind- UnboxedTuple ->+ UnboxedTuple -> do 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+ res_kind = unboxedTupleKind tau_reps+ checkTupSize arity 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1908,12 +1893,12 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider these examples -#11554:+Ticket #11554: data P (x :: k) = Q data A :: Type where MkA :: forall (a :: A). P a -> A -#12174+Ticket #12174 data V a data T = forall (a :: T). MkT (V a) @@ -3745,7 +3730,7 @@ * GHC.Tc.Errors.mkHoleError finally reports the error. -An annoying difficulty happens if there are more than 62 inferred+An annoying difficulty happens if there are more than 64 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
compiler/GHC/Tc/Gen/Match.hs view
@@ -1,19 +1,18 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE CPP #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE RecordWildCards #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- -- | Typecheck some @Matches@ module GHC.Tc.Gen.Match ( tcMatchesFun@@ -41,8 +40,6 @@ , tcCheckMonoExpr, tcCheckMonoExprNC , tcCheckPolyExpr ) -import GHC.Types.Basic (LexicalFixity(..))-import GHC.Hs import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Gen.Pat@@ -52,21 +49,27 @@ import GHC.Tc.Gen.Bind import GHC.Tc.Utils.Unify import GHC.Tc.Types.Origin+import GHC.Tc.Types.Evidence+ import GHC.Core.Multiplicity import GHC.Core.UsageEnv-import GHC.Types.Name-import GHC.Builtin.Types-import GHC.Types.Id import GHC.Core.TyCon+-- Create chunkified tuple tybes for monad comprehensions+import GHC.Core.Make++import GHC.Hs++import GHC.Builtin.Types import GHC.Builtin.Types.Prim-import GHC.Tc.Types.Evidence+ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc-import GHC.Types.SrcLoc --- Create chunkified tuple tybes for monad comprehensions-import GHC.Core.Make+import GHC.Types.Fixity (LexicalFixity(..))+import GHC.Types.Name+import GHC.Types.Id+import GHC.Types.SrcLoc import Control.Monad import Control.Arrow ( second )
compiler/GHC/Tc/Gen/Pat.hs view
@@ -1,18 +1,17 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998---}- {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++-}+ -- | Typechecking patterns module GHC.Tc.Gen.Pat ( tcLetPat@@ -33,6 +32,7 @@ import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcSyntaxOpGen, tcInferRho ) import GHC.Hs+import GHC.Rename.Utils import GHC.Tc.Utils.Zonk import GHC.Tc.Gen.Sig( TcPragEnv, lookupPragEnv, addInlinePrags ) import GHC.Tc.Utils.Monad@@ -510,6 +510,7 @@ tc = tupleTyCon boxity arity -- NB: tupleTyCon does not flatten 1-tuples -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make+ ; checkTupSize arity ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) penv (scaledThing pat_ty) -- Unboxed tuples have RuntimeRep vars, which we discard:
compiler/GHC/Tc/Gen/Rule.hs view
@@ -1,11 +1,10 @@+{-# LANGUAGE TypeFamilies #-}+ {- (c) The University of Glasgow 2006 (c) The AQUA Project, Glasgow University, 1993-1998 -}--{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TypeFamilies #-} -- | Typechecking rewrite rules module GHC.Tc.Gen.Rule ( tcRules ) where
compiler/GHC/Tc/Gen/Splice.hs view
@@ -1,26 +1,22 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- -- | Template Haskell splices module GHC.Tc.Gen.Splice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket,@@ -38,89 +34,98 @@ import GHC.Prelude +import GHC.Driver.Plugins+import GHC.Driver.Main+import GHC.Driver.Session+import GHC.Driver.Env+import GHC.Driver.Hooks+ import GHC.Hs-import GHC.Types.Annotations-import GHC.Driver.Finder-import GHC.Types.Name+ import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType-import GHC.Core.Multiplicity--import GHC.Utils.Outputable import GHC.Tc.Gen.Expr-import GHC.Types.SrcLoc-import GHC.Builtin.Names.TH import GHC.Tc.Utils.Unify import GHC.Tc.Utils.Env import GHC.Tc.Types.Origin+import GHC.Tc.Types.Evidence+import GHC.Tc.Utils.Zonk+import GHC.Tc.Solver+import GHC.Tc.Utils.TcMType+import GHC.Tc.Gen.HsType+import GHC.Tc.Instance.Family+import GHC.Tc.Utils.Instantiate++import GHC.Core.Multiplicity import GHC.Core.Coercion( etaExpandCoAxBranch )-import GHC.SysTools.FileCleanup ( newTempName, TempFileLifetime(..) )+import GHC.Core.Type as Type+import GHC.Core.TyCo.Rep as TyCoRep+import GHC.Core.FamInstEnv+import GHC.Core.InstEnv as InstEnv -import Control.Monad+import GHC.Builtin.Names.TH+import GHC.Builtin.Names+import GHC.Builtin.Types +import GHC.ThToHs+import GHC.HsToCore.Expr+import GHC.HsToCore.Monad+import GHC.IfaceToCore+import GHC.Iface.Load+ import GHCi.Message import GHCi.RemoteTypes import GHC.Runtime.Interpreter import GHC.Runtime.Interpreter.Types-import GHC.Driver.Main- -- These imports are the reason that GHC.Tc.Gen.Splice- -- is very high up the module hierarchy+ import GHC.Rename.Splice( traceSplice, SpliceInfo(..))-import GHC.Types.Name.Reader-import GHC.Driver.Types-import GHC.ThToHs import GHC.Rename.Expr import GHC.Rename.Env import GHC.Rename.Utils ( HsDocContext(..) ) import GHC.Rename.Fixity ( lookupFixityRn_help ) import GHC.Rename.HsType-import GHC.Tc.Utils.Zonk-import GHC.Tc.Solver-import GHC.Core.Type as Type-import GHC.Types.Name.Set-import GHC.Tc.Utils.TcMType-import GHC.Tc.Gen.HsType-import GHC.IfaceToCore-import GHC.Core.TyCo.Rep as TyCoRep-import GHC.Tc.Instance.Family-import GHC.Core.FamInstEnv-import GHC.Core.InstEnv as InstEnv-import GHC.Tc.Utils.Instantiate-import GHC.Types.Name.Env-import GHC.Builtin.Names-import GHC.Builtin.Types-import GHC.Types.Name.Occurrence as OccName-import GHC.Driver.Hooks-import GHC.Types.Var-import GHC.Unit.Module-import GHC.Iface.Load+ import GHC.Core.Class import GHC.Core.TyCon import GHC.Core.Coercion.Axiom import GHC.Core.PatSyn import GHC.Core.ConLike import GHC.Core.DataCon as DataCon-import GHC.Tc.Types.Evidence++import GHC.Types.SrcLoc+import GHC.Types.Name.Env+import GHC.Types.Name.Set+import GHC.Types.Name.Reader+import GHC.Types.Name.Occurrence as OccName+import GHC.Types.Var import GHC.Types.Id import GHC.Types.Id.Info-import GHC.HsToCore.Expr-import GHC.HsToCore.Monad+import GHC.Types.Unique+import GHC.Types.Var.Set+import GHC.Types.Meta+import GHC.Types.Basic hiding( SuccessFlag(..) )+import GHC.Types.Fixity as Hs+import GHC.Types.Annotations+import GHC.Types.Name import GHC.Serialized++import GHC.Unit.Finder+import GHC.Unit.Module+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.Deps+ import GHC.Utils.Error import GHC.Utils.Misc-import GHC.Types.Unique-import GHC.Types.Var.Set-import Data.List ( find )-import Data.Maybe-import GHC.Data.FastString-import GHC.Types.Basic as BasicTypes hiding( SuccessFlag(..) )-import GHC.Data.Maybe( MaybeErr(..) )-import GHC.Driver.Session import GHC.Utils.Panic as Panic import GHC.Utils.Lexeme-import qualified GHC.Data.EnumSet as EnumSet-import GHC.Driver.Plugins+import GHC.Utils.Outputable++import GHC.SysTools.FileCleanup ( newTempName, TempFileLifetime(..) )+ import GHC.Data.Bag+import GHC.Data.FastString+import GHC.Data.Maybe( MaybeErr(..) )+import qualified GHC.Data.EnumSet as EnumSet import qualified Language.Haskell.TH as TH -- THSyntax gives access to internal functions and data types@@ -132,9 +137,12 @@ import Unsafe.Coerce ( unsafeCoerce ) #endif +import Control.Monad import Control.Exception import Data.Binary import Data.Binary.Get+import Data.List ( find )+import Data.Maybe import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB import Data.Dynamic ( fromDynamic, toDyn )@@ -192,6 +200,8 @@ -- Throw away the typechecked expression but return its type. -- We'll typecheck it again when we splice it in somewhere ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var wrapper)) $+ tcScalingUsage Many $+ -- Scale by Many, TH lifting is currently nonlinear (#18465) tcInferRhoNC expr -- NC for no context; tcBracket does that ; let rep = getRuntimeRep expr_ty@@ -289,7 +299,8 @@ = do { meta_ty <- tcMetaTy meta_ty_name -- Expected type of splice, e.g. m Exp ; let expected_type = mkAppTy m_var meta_ty- ; expr' <- tcCheckPolyExpr expr expected_type+ ; expr' <- tcScalingUsage Many $ tcCheckPolyExpr expr expected_type+ -- Scale by Many, TH lifting is currently nonlinear (#18465) ; return (PendingTcSplice splice_name expr') } where meta_ty_name = case flavour of@@ -554,7 +565,7 @@ (-fenable-th-splice-warnings). There are multiple reasons: * It's not clear that the user that compiles a splice is the author of the code- that produces the warning. Think of the situation where she just splices in+ that produces the warning. Think of the situation where they just splice in code from a third-party library that produces incomplete pattern matches. In this scenario, the user isn't even able to fix that warning. * Gathering information for producing the warnings (pattern-match check@@ -570,8 +581,8 @@ consistently (#17270). In the future we could offer the Origin as part of the TH AST. That would enable us to give quotes from the current module get FromSource origin, and/or third library authors to tag certain parts of-generated code as FromSource to enable warnings. That effort is tracked in-#14838.+generated code as FromSource to enable warnings.+That effort is tracked in #14838. -} {-@@ -2296,10 +2307,10 @@ = do { (found, fix) <- lookupFixityRn_help name ; return (if found then Just (conv_fix fix) else Nothing) } where- conv_fix (BasicTypes.Fixity _ i d) = TH.Fixity i (conv_dir d)- conv_dir BasicTypes.InfixR = TH.InfixR- conv_dir BasicTypes.InfixL = TH.InfixL- conv_dir BasicTypes.InfixN = TH.InfixN+ conv_fix (Hs.Fixity _ i d) = TH.Fixity i (conv_dir d)+ conv_dir Hs.InfixR = TH.InfixR+ conv_dir Hs.InfixL = TH.InfixL+ conv_dir Hs.InfixN = TH.InfixN reifyUnpackedness :: DataCon.SrcUnpackedness -> TH.SourceUnpackedness reifyUnpackedness NoSrcUnpack = TH.NoSourceUnpackedness
compiler/GHC/Tc/Instance/Class.hs view
@@ -13,37 +13,41 @@ import GHC.Prelude +import GHC.Driver.Session++ import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType-import GHC.Tc.Utils.Instantiate( tcInstType )+import GHC.Tc.Utils.Instantiate(instDFunType, tcInstType) import GHC.Tc.Instance.Typeable import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Evidence-import GHC.Core.Predicate-import GHC.Rename.Env( addUsedGRE )-import GHC.Types.Name.Reader( lookupGRE_FieldLabel )-import GHC.Core.InstEnv-import GHC.Tc.Utils.Instantiate( instDFunType ) import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst )+import GHC.Rename.Env( addUsedGRE ) import GHC.Builtin.Types import GHC.Builtin.Types.Prim( eqPrimTyCon, eqReprPrimTyCon ) import GHC.Builtin.Names +import GHC.Types.Name.Reader( lookupGRE_FieldLabel )+import GHC.Types.SafeHaskell+import GHC.Types.Name ( Name, pprDefinedAt )+import GHC.Types.Var.Env ( VarEnv ) import GHC.Types.Id++import GHC.Core.Predicate+import GHC.Core.InstEnv import GHC.Core.Type import GHC.Core.Make ( mkStringExprFS, mkNaturalExpr )--import GHC.Types.Name ( Name, pprDefinedAt )-import GHC.Types.Var.Env ( VarEnv ) import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.Class-import GHC.Driver.Session+ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc( splitAtList, fstOf3 )+ import Data.Maybe {- *******************************************************************@@ -297,7 +301,7 @@ The reason we don't use this directly in the class is that it is simpler and more efficient to pass around a Natural rather than an entire function,-especially when the `KnowNat` evidence is packaged up in an existential.+especially when the `KnownNat` evidence is packaged up in an existential. The story for kind `Symbol` is analogous: * class KnownSymbol@@ -418,7 +422,7 @@ | isJust (tcSplitPredFunTy_maybe t) = return NoInstance -- Qualified type -- Now cases that do work- | k `eqType` typeNatKind = doTyLit knownNatClassName t+ | k `eqType` naturalTy = doTyLit knownNatClassName t | k `eqType` typeSymbolKind = doTyLit knownSymbolClassName t | tcIsConstraintKind t = doTyConApp clas t constraintKindTyCon [] | Just (mult,arg,ret) <- splitFunTy_maybe t = doFunTy clas t mult arg ret@@ -548,7 +552,7 @@ instance KnownNat n => Typeable (n :: Nat) where typeRep = typeNatTypeRep @n where- Data.Typeable.Internals.typeNatTypeRep :: KnownNat a => TypeRep a+ Data.Typeable.Internal.typeNatTypeRep :: KnownNat a => TypeRep a Ultimately typeNatTypeRep uses 'natSing' from KnownNat to get a runtime value 'n'; it turns it into a string with 'show' and uses
compiler/GHC/Tc/Instance/Family.hs view
@@ -14,33 +14,46 @@ import GHC.Prelude -import GHC.Driver.Types+import GHC.Driver.Session+import GHC.Driver.Env+ import GHC.Core.FamInstEnv import GHC.Core.InstEnv( roughMatchTcs ) import GHC.Core.Coercion-import GHC.Tc.Types.Evidence-import GHC.Iface.Load-import GHC.Tc.Utils.Monad-import GHC.Tc.Utils.Instantiate( freshenTyVarBndrs, freshenCoVarBndrsX )-import GHC.Types.SrcLoc as SrcLoc import GHC.Core.TyCon-import GHC.Tc.Utils.TcType import GHC.Core.Coercion.Axiom-import GHC.Driver.Session-import GHC.Unit.Module-import GHC.Utils.Outputable-import GHC.Utils.Misc-import GHC.Types.Name.Reader import GHC.Core.DataCon ( dataConName )-import GHC.Data.Maybe import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs import GHC.Core.TyCo.Ppr ( pprWithExplicitKindsWhen )++import GHC.Iface.Load++import GHC.Tc.Types.Evidence+import GHC.Tc.Utils.Monad+import GHC.Tc.Utils.Instantiate( freshenTyVarBndrs, freshenCoVarBndrsX )+import GHC.Tc.Utils.TcType++import GHC.Unit.External+import GHC.Unit.Module+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.Deps+import GHC.Unit.Home.ModInfo++import GHC.Types.SrcLoc as SrcLoc+import GHC.Types.Name.Reader import GHC.Types.Name-import GHC.Utils.Panic import GHC.Types.Var.Set++import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Utils.Panic import GHC.Utils.FV+ import GHC.Data.Bag( Bag, unionBags, unitBag )+import GHC.Data.Maybe+ import Control.Monad import Data.List ( sortBy ) import Data.List.NonEmpty ( NonEmpty(..) )@@ -215,7 +228,7 @@ For every other pair of family instance modules we import (directly or indirectly), we check that they are consistent now. (So that we can be-certain that the modules in our `GHC.Driver.Types.dep_finsts' are consistent.)+certain that the modules in our `GHC.Driver.Env.dep_finsts' are consistent.) There is some fancy footwork regarding hs-boot module loops, see Note [Don't check hs-boot type family instances too early]
compiler/GHC/Tc/Instance/Typeable.hs view
@@ -15,14 +15,15 @@ import GHC.Prelude import GHC.Platform -import GHC.Types.Basic ( Boxity(..), neverInlinePragma, SourceText(..) )+import GHC.Types.Basic ( Boxity(..), neverInlinePragma )+import GHC.Types.SourceText ( SourceText(..) ) import GHC.Iface.Env( newGlobalBinder ) import GHC.Core.TyCo.Rep( Type(..), TyLit(..) ) import GHC.Tc.Utils.Env import GHC.Tc.Types.Evidence ( mkWpTyApps ) import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType-import GHC.Driver.Types ( lookupId )+import GHC.Types.TyThing ( lookupId ) import GHC.Builtin.Names import GHC.Builtin.Types.Prim ( primTyCons ) import GHC.Builtin.Types@@ -350,7 +351,7 @@ -- Note [Built-in syntax and the OrigNameCache] in "GHC.Iface.Env" for more. ghcPrimTypeableTyCons :: [TyCon] ghcPrimTypeableTyCons = concat- [ [ runtimeRepTyCon, vecCountTyCon, vecElemTyCon, funTyCon ]+ [ [ runtimeRepTyCon, vecCountTyCon, vecElemTyCon ] , map (tupleTyCon Unboxed) [0..mAX_TUPLE_SIZE] , map sumTyCon [2..mAX_SUM_SIZE] , primTyCons
compiler/GHC/Tc/Module.hs view
@@ -1,21 +1,19 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998---}- {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++-}+ -- | Typechecking a whole module -- -- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/type-checker@@ -50,28 +48,16 @@ import GHC.Prelude +import GHC.Driver.Env+import GHC.Driver.Plugins+import GHC.Driver.Session++import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR (..) ) import {-# SOURCE #-} GHC.Tc.Gen.Splice ( finishTH, runRemoteModFinalizers )-import GHC.Rename.Splice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) )-import GHC.Iface.Env ( externaliseName ) import GHC.Tc.Gen.HsType import GHC.Tc.Validity( checkValidType ) import GHC.Tc.Gen.Match import GHC.Tc.Utils.Unify( checkConstraints )-import GHC.Rename.HsType-import GHC.Rename.Expr-import GHC.Rename.Utils ( HsDocContext(..) )-import GHC.Rename.Fixity ( lookupFixityRn )-import GHC.Builtin.Types ( unitTy, mkListTy )-import GHC.Driver.Plugins-import GHC.Driver.Session-import GHC.Hs-import GHC.Iface.Syntax ( ShowSub(..), showToHeader )-import GHC.Iface.Type ( ShowForAllFlag(..) )-import GHC.Core.PatSyn ( pprPatSynType )-import GHC.Core.Predicate ( classMethodTy )-import GHC.Builtin.Names-import GHC.Builtin.Utils-import GHC.Types.Name.Reader import GHC.Tc.Utils.Zonk import GHC.Tc.Gen.Expr import GHC.Tc.Errors( reportAllUnsolved )@@ -81,24 +67,14 @@ import GHC.Tc.Types.Evidence import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin-import qualified GHC.Data.BooleanFormula as BF-import GHC.Core.Ppr.TyThing ( pprTyThingInContext )-import GHC.Core.FVs ( orphNamesOfFamInst ) import GHC.Tc.Instance.Family-import GHC.Core.InstEnv-import GHC.Core.FamInstEnv- ( FamInst, pprFamInst, famInstsRepTyCons- , famInstEnvElts, extendFamInstEnvList, normaliseType ) import GHC.Tc.Gen.Annotation import GHC.Tc.Gen.Bind-import GHC.Iface.Make ( coAxiomToIfaceDecl )-import GHC.Parser.Header ( mkPrelImports ) import GHC.Tc.Gen.Default import GHC.Tc.Utils.Env import GHC.Tc.Gen.Rule import GHC.Tc.Gen.Foreign import GHC.Tc.TyCl.Instance-import GHC.IfaceToCore import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Instantiate (tcGetInsts)@@ -106,50 +82,97 @@ import GHC.Tc.TyCl import GHC.Tc.Instance.Typeable ( mkTypeableBinds ) import GHC.Tc.Utils.Backpack-import GHC.Iface.Load++import GHC.Rename.Splice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) )+import GHC.Rename.HsType+import GHC.Rename.Expr+import GHC.Rename.Utils ( HsDocContext(..) )+import GHC.Rename.Fixity ( lookupFixityRn ) import GHC.Rename.Names import GHC.Rename.Env import GHC.Rename.Module++import GHC.Iface.Syntax ( ShowSub(..), showToHeader )+import GHC.Iface.Type ( ShowForAllFlag(..) )+import GHC.Iface.Env ( externaliseName )+import GHC.Iface.Make ( coAxiomToIfaceDecl )+import GHC.Iface.Load++import GHC.Builtin.Types ( unitTy, mkListTy )+import GHC.Builtin.Names+import GHC.Builtin.Utils++import GHC.Hs+import GHC.Hs.Dump++import GHC.Core.PatSyn ( pprPatSynType )+import GHC.Core.Predicate ( classMethodTy )+import GHC.Core.FVs ( orphNamesOfFamInst )+import GHC.Core.InstEnv+import GHC.Core.TyCon+import GHC.Core.ConLike+import GHC.Core.DataCon+import GHC.Core.Type+import GHC.Core.Class+import GHC.Core.Coercion.Axiom+import GHC.Core.FamInstEnv+ ( FamInst, pprFamInst, famInstsRepTyCons+ , famInstEnvElts, extendFamInstEnvList, normaliseType )++import GHC.Parser.Header ( mkPrelImports )++import GHC.IfaceToCore++import GHC.Runtime.Context+ import GHC.Utils.Error+import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc++import GHC.Types.Name.Reader+import GHC.Types.Fixity.Env import GHC.Types.Id as Id import GHC.Types.Id.Info( IdDetails(..) ) import GHC.Types.Var.Env-import GHC.Unit+import GHC.Types.TypeEnv import GHC.Types.Unique.FM import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Avail-import GHC.Core.TyCon-import GHC.Types.SrcLoc-import GHC.Driver.Types-import GHC.Data.List.SetOps-import GHC.Utils.Outputable as Outputable-import GHC.Utils.Panic-import GHC.Core.ConLike-import GHC.Core.DataCon-import GHC.Core.Type-import GHC.Core.Class import GHC.Types.Basic hiding( SuccessFlag(..) )-import GHC.Core.Coercion.Axiom import GHC.Types.Annotations-import Data.List ( find, sortBy, sort )-import Data.Ord+import GHC.Types.SrcLoc+import GHC.Types.SourceText+import GHC.Types.SourceFile+import GHC.Types.TyThing.Ppr ( pprTyThingInContext )+import qualified GHC.LanguageExtensions as LangExt++import GHC.Unit.External+import GHC.Unit.Types+import GHC.Unit.State+import GHC.Unit.Home+import GHC.Unit.Module+import GHC.Unit.Module.Warnings+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.Deps+ import GHC.Data.FastString import GHC.Data.Maybe-import GHC.Utils.Misc+import GHC.Data.List.SetOps import GHC.Data.Bag-import qualified GHC.LanguageExtensions as LangExt+import qualified GHC.Data.BooleanFormula as BF++import Data.List ( find, sortBy, sort )+import Data.Ord import Data.Data ( Data )-import GHC.Hs.Dump import qualified Data.Set as S- import Control.DeepSeq import Control.Monad -import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR (..) )-- #include "GhclibHsVersions.h" {-@@ -184,7 +207,7 @@ where hsc_src = ms_hsc_src mod_sum dflags = hsc_dflags hsc_env- home_unit = mkHomeUnitFromFlags dflags+ home_unit = hsc_home_unit hsc_env err_msg = mkPlainErrMsg dflags loc $ text "Module does not have a RealSrcSpan:" <+> ppr this_mod @@ -194,7 +217,7 @@ = (mkHomeModule home_unit mod, mod_loc) | otherwise -- 'module M where' is omitted- = (mAIN, srcLocSpan (srcSpanStart loc))+ = (mkHomeModule home_unit mAIN_NAME, srcLocSpan (srcSpanStart loc)) @@ -301,7 +324,7 @@ tcg_env <- return (tcg_env { tcg_doc_hdr = maybe_doc_hdr }) ; -- Report unused names- -- Do this /after/ typeinference, so that when reporting+ -- Do this /after/ type inference, so that when reporting -- a function with no type signature we can give the -- inferred type reportUnusedNames tcg_env hsc_src@@ -2101,7 +2124,7 @@ traceTc "tcs 1" empty ; this_mod <- getModule ; global_ids <- mapM (externaliseAndTidyId this_mod) zonked_ids ;- -- Note [Interactively-bound Ids in GHCi] in GHC.Driver.Types+ -- Note [Interactively-bound Ids in GHCi] in GHC.Driver.Env {- --------------------------------------------- At one stage I removed any shadowed bindings from the type_env;@@ -2172,7 +2195,7 @@ -- -- By 'lift' and 'environment we mean that the code is changed to -- execute properly in an IO monad. See Note [Interactively-bound Ids--- in GHCi] in GHC.Driver.Types for more details. We do this lifting by trying+-- in GHCi] in GHC.Driver.Env for more details. We do this lifting by trying -- different ways ('plans') of lifting the code into the IO monad and -- type checking each plan until one succeeds. tcUserStmt :: GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv)@@ -2455,7 +2478,7 @@ { hst_tele = mkHsForAllInvisTele [noLoc $ UserTyVar noExtField SpecifiedSpec (noLoc a_tv)] , hst_xforall = noExtField- , hst_body = nlHsFunTy HsUnrestrictedArrow ghciM ioM }+ , hst_body = nlHsFunTy ghciM ioM } stepTy :: LHsSigWcType GhcRn stepTy = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs step_ty)@@ -2829,10 +2852,10 @@ -- This is so that we can accurately report the instances for -- something loadUnqualIfaces hsc_env ictxt- = initIfaceTcRn $ do+ = initIfaceTcRn $ mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods)) where- home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)+ home_unit = hsc_home_unit hsc_env unqual_mods = [ nameModule name | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt)@@ -3021,7 +3044,7 @@ (solvers,stops) <- unzip `fmap` mapM (startPlugin ev_binds_var) plugins -- This ensures that tcPluginStop is called even if a type -- error occurs during compilation (Fix of #10078)- eitherRes <- tryM $ do+ eitherRes <- tryM $ updGblEnv (\e -> e { tcg_tc_plugins = solvers }) m mapM_ (flip runTcPluginM ev_binds_var) stops case eitherRes of@@ -3043,7 +3066,7 @@ plugins -> do (plugins,stops) <- unzip `fmap` mapM startPlugin plugins -- This ensures that hfPluginStop is called even if a type -- error occurs during compilation.- eitherRes <- tryM $ do+ eitherRes <- tryM $ updGblEnv (\e -> e { tcg_hf_plugins = plugins }) m sequence_ stops case eitherRes of
compiler/GHC/Tc/Module.hs-boot view
@@ -1,7 +1,7 @@ module GHC.Tc.Module where import GHC.Prelude-import GHC.Core.Type(TyThing)+import GHC.Types.TyThing(TyThing) import GHC.Tc.Types (TcM) import GHC.Utils.Outputable (SDoc) import GHC.Types.Name (Name)
compiler/GHC/Tc/Plugin.hs view
@@ -10,7 +10,7 @@ unsafeTcPluginTcM, -- * Finding Modules and Names- FindResult(..),+ Finder.FindResult(..), findImportedModule, lookupOrig, @@ -52,13 +52,13 @@ import GHC.Prelude -import qualified GHC.Tc.Utils.Monad as TcM+import qualified GHC.Tc.Utils.Monad as TcM import qualified GHC.Tc.Solver.Monad as TcS-import qualified GHC.Tc.Utils.Env as TcM+import qualified GHC.Tc.Utils.Env as TcM import qualified GHC.Tc.Utils.TcMType as TcM import qualified GHC.Tc.Instance.Family as TcM import qualified GHC.Iface.Env as IfaceEnv-import qualified GHC.Driver.Finder as Finder+import qualified GHC.Unit.Finder as Finder import GHC.Core.FamInstEnv ( FamInstEnv ) import GHC.Tc.Utils.Monad ( TcGblEnv, TcLclEnv, TcPluginM@@ -73,10 +73,11 @@ import GHC.Unit.Module import GHC.Types.Name+import GHC.Types.TyThing import GHC.Core.TyCon import GHC.Core.DataCon import GHC.Core.Class-import GHC.Driver.Types+import GHC.Driver.Env import GHC.Utils.Outputable import GHC.Core.Type import GHC.Core.Coercion ( BlockSubstFlag(..) )@@ -95,7 +96,7 @@ tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b) -findImportedModule :: ModuleName -> Maybe FastString -> TcPluginM FindResult+findImportedModule :: ModuleName -> Maybe FastString -> TcPluginM Finder.FindResult findImportedModule mod_name mb_pkg = do hsc_env <- getTopEnv tcPluginIO $ Finder.findImportedModule hsc_env mod_name mb_pkg
compiler/GHC/Tc/Solver.hs view
@@ -1831,7 +1831,6 @@ ; return (floated_eqs, res_implic) } - where -- TcLevels must be strictly increasing (see (ImplicInv) in -- Note [TcLevel and untouchable type variables] in GHC.Tc.Utils.TcType), -- and in fact I think they should always increase one level at a time.@@ -2245,8 +2244,6 @@ float_wc trapping_tvs (WC { wc_simple = simples, wc_impl = implics }) = filterBag (is_floatable trapping_tvs) simples `unionBags` concatMapBag (float_implic trapping_tvs) implics- where- float_implic :: TcTyCoVarSet -> Implication -> Cts float_implic trapping_tvs imp | float_past_equalities || ic_no_eqs imp@@ -2317,8 +2314,7 @@ when defaulting actually happens, and one that was never documented. Moreover (#12923), the more complex rule is sometimes NOT what you want. So I simply removed the extra code to implement the-contamination stuff. There was zero effect on the testsuite (not even-#8155).+contamination stuff. There was zero effect on the testsuite (not even #8155). ------ End of historical note ----------- @@ -2543,6 +2539,9 @@ is_float_eq_candidate ct | pred <- ctPred ct , EqPred NomEq ty1 ty2 <- classifyPredType pred+ , case ct of+ CIrredCan {} -> False -- See Note [Do not float blocked constraints]+ _ -> True -- See #18855 = float_eq ty1 ty2 || float_eq ty2 ty1 | otherwise = False@@ -2553,7 +2552,26 @@ && (not (isTyVarTyVar tv1) || isTyVarTy ty2) Nothing -> False -{- Note [Float equalities from under a skolem binding]+{- Note [Do not float blocked constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As #18855 showed, we must not float an equality that is blocked.+Consider+ forall a[4]. [W] co1: alpha[4] ~ Maybe (a[4] |> bco)+ [W] co2: alpha[4] ~ Maybe (beta[4] |> bco])+ [W] bco: kappa[2] ~ Type++Now co1, co2 are blocked by bco. We will eventually float out bco+and solve it at level 2. But the danger is that we will *also*+float out co2, and that is bad bad bad. Because we'll promote alpha+and beta to level 2, and then fail to unify the promoted beta+with the skolem a[4].++Solution: don't float out blocked equalities. Remember: we only want+to float out if we can solve; see Note [Which equalities to float].++(Future plan: kill floating altogether.)++Note [Float equalities from under a skolem binding] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Which of the simple equalities can we float out? Obviously, only ones that don't mention the skolem-bound variables. But that is
compiler/GHC/Tc/Solver/Canonical.hs view
@@ -1035,7 +1035,9 @@ = canTyConApp ev eq_rel tc1 tys1 tc2 tys2 can_eq_nc' _flat _rdr_env _envs ev eq_rel- s1@(ForAllTy {}) _ s2@(ForAllTy {}) _+ s1@(ForAllTy (Bndr _ vis1) _) _+ s2@(ForAllTy (Bndr _ vis2) _) _+ | vis1 `sameVis` vis2 -- Note [ForAllTy and typechecker equality] = can_eq_nc_forall ev eq_rel s1 s2 -- See Note [Canonicalising type applications] about why we require flat types@@ -1071,6 +1073,63 @@ that is not necessarily insoluble! Maybe 'a' will turn out to be a newtype. So we want to make it a potentially-soluble Irred not an insoluble one. Missing this point is what caused #15431++Note [ForAllTy and typechecker equality]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Should GHC type-check the following program (adapted from #15740)?++ {-# LANGUAGE PolyKinds, ... #-}+ data D a+ type family F :: forall k. k -> Type+ type instance F = D++Due to the way F is declared, any instance of F must have a right-hand side+whose kind is equal to `forall k. k -> Type`. The kind of D is+`forall {k}. k -> Type`, which is very close, but technically uses distinct+Core:++ -----------------------------------------------------------+ | Source Haskell | Core |+ -----------------------------------------------------------+ | forall k. <...> | ForAllTy (Bndr k Specified) (<...>) |+ | forall {k}. <...> | ForAllTy (Bndr k Inferred) (<...>) |+ -----------------------------------------------------------++We could deem these kinds to be unequal, but that would imply rejecting+programs like the one above. Whether a kind variable binder ends up being+specified or inferred can be somewhat subtle, however, especially for kinds+that aren't explicitly written out in the source code (like in D above).+For now, we decide to not make the specified/inferred status of an invisible+type variable binder affect GHC's notion of typechecker equality+(see Note [Typechecker equality vs definitional equality] in+GHC.Tc.Utils.TcType). That is, we have the following:++ --------------------------------------------------+ | Type 1 | Type 2 | Equal? |+ --------------------|-----------------------------+ | forall k. <...> | forall k. <...> | Yes |+ | | forall {k}. <...> | Yes |+ | | forall k -> <...> | No |+ --------------------------------------------------+ | forall {k}. <...> | forall k. <...> | Yes |+ | | forall {k}. <...> | Yes |+ | | forall k -> <...> | No |+ --------------------------------------------------+ | forall k -> <...> | forall k. <...> | No |+ | | forall {k}. <...> | No |+ | | forall k -> <...> | Yes |+ --------------------------------------------------++We implement this nuance by using the GHC.Types.Var.sameVis function in+GHC.Tc.Solver.Canonical.canEqNC and GHC.Tc.Utils.TcType.tcEqType, which+respect typechecker equality. sameVis puts both forms of invisible type+variable binders into the same equivalence class.++Note that we do /not/ use sameVis in GHC.Core.Type.eqType, which implements+/definitional/ equality, a slighty more coarse-grained notion of equality+(see Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep) that does+not consider the ArgFlag of ForAllTys at all. That is, eqType would equate all+of forall k. <...>, forall {k}. <...>, and forall k -> <...>. -} ---------------------------------
compiler/GHC/Tc/Solver/Flatten.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE CPP, DeriveFunctor, ViewPatterns, BangPatterns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -1204,9 +1206,11 @@ flatten_one (CastTy ty g) = do { (xi, co) <- flatten_one ty ; (g', _) <- flatten_co g- ; role <- getRole- ; return (mkCastTy xi g', castCoercionKind co role xi ty g' g) }+ ; return (mkCastTy xi g', castCoercionKind1 co role xi ty g') }+ -- It makes a /big/ difference to call castCoercionKind1 not+ -- the more general castCoercionKind2.+ -- See Note [castCoercionKind1] in GHC.Core.Coercion flatten_one (CoercionTy co) = first mkCoercionTy <$> flatten_co co
compiler/GHC/Tc/Solver/Interact.hs view
@@ -15,23 +15,21 @@ infinity, IntWithInf, intGtLimit ) import GHC.Tc.Solver.Canonical import GHC.Tc.Solver.Flatten-import GHC.Tc.Utils.Unify( canSolveByUnification )+import GHC.Tc.Utils.Unify ( canSolveByUnification ) import GHC.Types.Var.Set import GHC.Core.Type as Type import GHC.Core.Coercion ( BlockSubstFlag(..) ) import GHC.Core.InstEnv ( DFunInstType )-import GHC.Core.Coercion.Axiom ( sfInteractTop, sfInteractInert ) import GHC.Types.Var import GHC.Tc.Utils.TcType-import GHC.Builtin.Names ( coercibleTyConKey,- heqTyConKey, eqTyConKey, ipClassKey )-import GHC.Core.Coercion.Axiom ( TypeEqn, CoAxiom(..), CoAxBranch(..), fromBranches )+import GHC.Builtin.Names ( coercibleTyConKey, heqTyConKey, eqTyConKey, ipClassKey )+import GHC.Core.Coercion.Axiom ( CoAxBranch (..), CoAxiom (..), TypeEqn, fromBranches, sfInteractInert, sfInteractTop ) import GHC.Core.Class import GHC.Core.TyCon import GHC.Tc.Instance.FunDeps import GHC.Tc.Instance.Family-import GHC.Tc.Instance.Class( InstanceWhat(..), safeOverlap )+import GHC.Tc.Instance.Class ( InstanceWhat(..), safeOverlap ) import GHC.Core.FamInstEnv import GHC.Core.Unify ( tcUnifyTyWithTFs, ruleMatchTyKiX ) @@ -88,7 +86,7 @@ - If (ContinueWith ct) is returned by a stage, we feed 'ct' on to the next stage in the pipeline. 4. If the element has survived (i.e. ContinueWith x) the last stage- then we add him in the inerts and jump back to Step 1.+ then we add it in the inerts and jump back to Step 1. If in Step 1 no such element exists, we have exceeded our context-stack depth and will simply fail.@@ -939,7 +937,7 @@ The following four modules produce a program whose output would change depending on whether we apply this optimization when IncoherentInstances is in effect: -#########+========= {-# LANGUAGE MultiParamTypeClasses #-} module A where @@ -949,8 +947,9 @@ class A a => C a b where m :: b -> a -> a -#########- {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+=========+ {-# LANGUAGE FlexibleInstances #-}+ {-# LANGUAGE MultiParamTypeClasses #-} module B where import A@@ -961,9 +960,11 @@ instance C a [b] where m _ = id -#########- {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}- {-# LANGUAGE IncoherentInstances #-}+=========+ {-# LANGUAGE FlexibleContexts #-}+ {-# LANGUAGE FlexibleInstances #-}+ {-# LANGUAGE IncoherentInstances #-}+ {-# LANGUAGE MultiParamTypeClasses #-} module C where import A@@ -977,7 +978,7 @@ intC :: C Int a => a -> Int -> Int intC _ x = int x -#########+========= module Main where import A@@ -1668,7 +1669,7 @@ Original wanted: (a ~ alpha), (alpha ~ Int) We spontaneously solve the first wanted, without changing the order! given : a ~ alpha [having unified alpha := a]-Now the second wanted comes along, but he cannot rewrite the given, so we simply continue.+Now the second wanted comes along, but it cannot rewrite the given, so we simply continue. At the end we spontaneously solve that guy, *reunifying* [alpha := Int] We avoid this problem by orienting the resulting given so that the unification@@ -2606,7 +2607,7 @@ The same reasoning applies to -* (~~) heqTyCOn+* (~~) heqTyCon * (~) eqTyCon * Coercible coercibleTyCon
compiler/GHC/Tc/Solver/Monad.hs view
@@ -129,7 +129,7 @@ import GHC.Prelude -import GHC.Driver.Types+import GHC.Driver.Env import qualified GHC.Tc.Utils.Instantiate as TcM import GHC.Core.InstEnv@@ -155,6 +155,7 @@ import GHC.Tc.Errors ( solverDepthErrorTcS ) import GHC.Types.Name+import GHC.Types.TyThing import GHC.Unit.Module ( HasModule, getModule ) import GHC.Types.Name.Reader ( GlobalRdrEnv, GlobalRdrElt ) import qualified GHC.Rename.Env as TcM@@ -174,6 +175,7 @@ import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.DFM+import GHC.Core.TyCon.Env import GHC.Data.Maybe import GHC.Core.Map@@ -1299,7 +1301,7 @@ Note [Examples of how Derived shadows helps completeness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-#10009, a very nasty example:+Ticket #10009, a very nasty example: f :: (UnF (F b) ~ b) => F b -> () @@ -2640,7 +2642,7 @@ delFunEq m tc tys = delTcApp m (getUnique tc) tys -------------------------------type ExactFunEqMap a = UniqFM TyCon (ListMap TypeMap a)+type ExactFunEqMap a = TyConEnv (ListMap TypeMap a) emptyExactFunEqs :: ExactFunEqMap a emptyExactFunEqs = emptyUFM@@ -3614,8 +3616,7 @@ newDerivedNC :: CtLoc -> TcPredType -> TcS CtEvidence newDerivedNC loc pred- = do { -- checkReductionDepth loc pred- ; return (CtDerived { ctev_pred = pred, ctev_loc = loc }) }+ = return $ CtDerived { ctev_pred = pred, ctev_loc = loc } -- --------- Check done in GHC.Tc.Solver.Interact.selectNewWorkItem???? --------- -- | Checks if the depth of the given location is too much. Fails if
compiler/GHC/Tc/TyCl.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE CPP, TupleSections, ScopedTypeVariables, MultiWayIf #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -27,8 +28,11 @@ import GHC.Prelude +import GHC.Driver.Env+import GHC.Driver.Session+ import GHC.Hs-import GHC.Driver.Types+ import GHC.Tc.TyCl.Build import GHC.Tc.Solver( pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX , reportUnsolvedEqualities )@@ -43,14 +47,17 @@ import GHC.Tc.Gen.HsType import GHC.Tc.Instance.Class( AssocInstInfo(..) ) import GHC.Tc.Utils.TcMType-import GHC.Builtin.Types ( unitTy, makeRecoveryTyCon ) import GHC.Tc.Utils.TcType-import GHC.Core.Multiplicity-import GHC.Rename.Env( lookupConstructorFields ) import GHC.Tc.Instance.Family+import GHC.Tc.Types.Origin++import GHC.Builtin.Types (oneDataConTy, unitTy, makeRecoveryTyCon )++import GHC.Rename.Env( lookupConstructorFields )++import GHC.Core.Multiplicity import GHC.Core.FamInstEnv import GHC.Core.Coercion-import GHC.Tc.Types.Origin import GHC.Core.Type import GHC.Core.TyCo.Rep -- for checkValidRoles import GHC.Core.TyCo.Ppr( pprTyVars )@@ -58,27 +65,31 @@ import GHC.Core.Coercion.Axiom import GHC.Core.TyCon import GHC.Core.DataCon+import GHC.Core.Unify+ import GHC.Types.Id import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set-import GHC.Data.FastString-import GHC.Unit import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Data.Maybe-import GHC.Core.Unify-import GHC.Utils.Misc import GHC.Types.SrcLoc-import GHC.Data.List.SetOps-import GHC.Driver.Session+import GHC.Types.SourceFile import GHC.Types.Unique import GHC.Types.Basic import qualified GHC.LanguageExtensions as LangExt +import GHC.Data.FastString+import GHC.Data.Maybe+import GHC.Data.List.SetOps++import GHC.Unit++import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc+ import Control.Monad import Data.Function ( on ) import Data.Functor.Identity@@ -173,7 +184,7 @@ -- Step 1.5: Make sure we don't have any type synonym cycles ; traceTc "Starting synonym cycle check" (ppr tyclss)- ; home_unit <- mkHomeUnitFromFlags <$> getDynFlags+ ; home_unit <- hsc_home_unit <$> getTopEnv ; checkSynCycles (homeUnitAsUnit home_unit) tyclss tyclds ; traceTc "Done synonym cycle check" (ppr tyclss) @@ -667,7 +678,8 @@ -- NB: the environment extension overrides the tycon -- promotion-errors bindings -- See Note [Type environment evolution]- ; tcExtendKindEnvWithTyCons mono_tcs $+ ; checkNoErrs $+ tcExtendKindEnvWithTyCons mono_tcs $ mapM_ kcLTyClDecl kindless_decls ; return mono_tcs }@@ -941,7 +953,7 @@ Much of the debate is memorialized in #15743. Here is our design choice. When inferring the ordering of variables-for a TyCl declaration (that is, for those variables that he user+for a TyCl declaration (that is, for those variables that the user has not specified the order with an explicit `forall`), we use the following order: @@ -1562,7 +1574,7 @@ ------------------- --- Type check the types of the arguments to a data constructor.+-- Kind-check the types of the arguments to a data constructor. -- This includes doing kind unification if the type is a newtype. -- See Note [Implementation of UnliftedNewtypes] for why we need -- the first two arguments.@@ -1575,6 +1587,21 @@ -- See Note [Implementation of UnliftedNewtypes], STEP 2 } +-- Kind-check the types of arguments to a Haskell98 data constructor.+kcConH98Args :: NewOrData -> Kind -> HsConDeclH98Details GhcRn -> TcM ()+kcConH98Args new_or_data res_kind con_args = case con_args of+ PrefixCon tys -> kcConArgTys new_or_data res_kind tys+ InfixCon ty1 ty2 -> kcConArgTys new_or_data res_kind [ty1, ty2]+ RecCon (L _ flds) -> kcConArgTys new_or_data res_kind $+ map (hsLinear . cd_fld_type . unLoc) flds++-- Kind-check the types of arguments to a GADT data constructor.+kcConGADTArgs :: NewOrData -> Kind -> HsConDeclGADTDetails GhcRn -> TcM ()+kcConGADTArgs new_or_data res_kind con_args = case con_args of+ PrefixConGADT tys -> kcConArgTys new_or_data res_kind tys+ RecConGADT (L _ flds) -> kcConArgTys new_or_data res_kind $+ map (hsLinear . cd_fld_type . unLoc) flds+ kcConDecls :: NewOrData -> Kind -- The result kind signature -> [LConDecl GhcRn] -- The data constructors@@ -1603,14 +1630,14 @@ discardResult $ bindExplicitTKBndrs_Tv ex_tvs $ do { _ <- tcHsMbContext ex_ctxt- ; kcConArgTys new_or_data res_kind (hsConDeclArgTys args)+ ; kcConH98Args new_or_data res_kind args -- We don't need to check the telescope here, -- because that's done in tcConDecl } kcConDecl new_or_data res_kind (ConDeclGADT { con_names = names, con_qvars = explicit_tkv_nms, con_mb_cxt = cxt- , con_args = args, con_res_ty = res_ty, con_g_ext = implicit_tkv_nms })+ , con_g_args = args, con_res_ty = res_ty, con_g_ext = implicit_tkv_nms }) = -- Even though the GADT-style data constructor's type is closed, -- we must still kind-check the type, because that may influence -- the inferred kind of the /type/ constructor. Example:@@ -1624,7 +1651,7 @@ bindExplicitTKBndrs_Tv explicit_tkv_nms $ -- Why "_Tv"? See Note [Kind-checking for GADTs] do { _ <- tcHsMbContext cxt- ; kcConArgTys new_or_data res_kind (hsConDeclArgTys args)+ ; kcConGADTArgs new_or_data res_kind args ; _ <- tcHsOpenType res_ty ; return () } @@ -3195,7 +3222,7 @@ bindExplicitTKBndrs_Skol explicit_tkv_nms $ do { ctxt <- tcHsMbContext hs_ctxt ; let exp_kind = getArgExpKind new_or_data res_kind- ; btys <- tcConArgs exp_kind hs_args+ ; btys <- tcConH98Args exp_kind hs_args ; field_lbls <- lookupConstructorFields name ; let (arg_tys, stricts) = unzip btys ; return (ctxt, arg_tys, field_lbls, stricts)@@ -3265,7 +3292,7 @@ (ConDeclGADT { con_g_ext = implicit_tkv_nms , con_names = names , con_qvars = explicit_tkv_nms- , con_mb_cxt = cxt, con_args = hs_args+ , con_mb_cxt = cxt, con_g_args = hs_args , con_res_ty = hs_res_ty }) = addErrCtxt (dataConCtxtName names) $ do { traceTc "tcConDecl 1 gadt" (ppr names)@@ -3282,7 +3309,7 @@ -- See Note [Datatype return kinds] ; let exp_kind = getArgExpKind new_or_data res_kind - ; btys <- tcConArgs exp_kind hs_args+ ; btys <- tcConGADTArgs exp_kind hs_args ; let (arg_tys, stricts) = unzip btys ; field_lbls <- lookupConstructorFields name ; return (ctxt, arg_tys, res_ty, field_lbls, stricts)@@ -3361,48 +3388,50 @@ getArgExpKind DataType _ = OpenKind tcConIsInfixH98 :: Name- -> HsConDetails a b+ -> HsConDeclH98Details GhcRn -> TcM Bool tcConIsInfixH98 _ details = case details of- InfixCon {} -> return True- _ -> return False+ InfixCon{} -> return True+ RecCon{} -> return False+ PrefixCon{} -> return False tcConIsInfixGADT :: Name- -> HsConDetails (HsScaled GhcRn (LHsType GhcRn)) r+ -> HsConDeclGADTDetails GhcRn -> TcM Bool tcConIsInfixGADT con details = case details of- InfixCon {} -> return True- RecCon {} -> return False- PrefixCon arg_tys -- See Note [Infix GADT constructors]+ RecConGADT{} -> return False+ PrefixConGADT arg_tys -- See Note [Infix GADT constructors] | isSymOcc (getOccName con) , [_ty1,_ty2] <- map hsScaledThing arg_tys -> do { fix_env <- getFixityEnv ; return (con `elemNameEnv` fix_env) } | otherwise -> return False -tcConArgs :: ContextKind -- expected kind of arguments- -- always OpenKind for datatypes, but unlifted newtypes- -- might have a specific kind- -> HsConDeclDetails GhcRn- -> TcM [(Scaled TcType, HsSrcBang)]-tcConArgs exp_kind (PrefixCon btys)+tcConH98Args :: ContextKind -- expected kind of arguments+ -- always OpenKind for datatypes, but unlifted newtypes+ -- might have a specific kind+ -> HsConDeclH98Details GhcRn+ -> TcM [(Scaled TcType, HsSrcBang)]+tcConH98Args exp_kind (PrefixCon btys) = mapM (tcConArg exp_kind) btys-tcConArgs exp_kind (InfixCon bty1 bty2)+tcConH98Args exp_kind (InfixCon bty1 bty2) = do { bty1' <- tcConArg exp_kind bty1 ; bty2' <- tcConArg exp_kind bty2 ; return [bty1', bty2'] }-tcConArgs exp_kind (RecCon fields)- = mapM (tcConArg exp_kind) btys- where- -- We need a one-to-one mapping from field_names to btys- combined = map (\(L _ f) -> (cd_fld_names f,hsLinear (cd_fld_type f)))- (unLoc fields)- explode (ns,ty) = zip ns (repeat ty)- exploded = concatMap explode combined- (_,btys) = unzip exploded+tcConH98Args exp_kind (RecCon fields)+ = tcRecConDeclFields exp_kind fields +tcConGADTArgs :: ContextKind -- expected kind of arguments+ -- always OpenKind for datatypes, but unlifted newtypes+ -- might have a specific kind+ -> HsConDeclGADTDetails GhcRn+ -> TcM [(Scaled TcType, HsSrcBang)]+tcConGADTArgs exp_kind (PrefixConGADT btys)+ = mapM (tcConArg exp_kind) btys+tcConGADTArgs exp_kind (RecConGADT fields)+ = tcRecConDeclFields exp_kind fields tcConArg :: ContextKind -- expected kind for args; always OpenKind for datatypes, -- but might be an unlifted type with UnliftedNewtypes@@ -3410,11 +3439,40 @@ tcConArg exp_kind (HsScaled w bty) = do { traceTc "tcConArg 1" (ppr bty) ; arg_ty <- tcCheckLHsType (getBangType bty) exp_kind- ; w' <- tcMult w+ ; w' <- tcDataConMult w ; traceTc "tcConArg 2" (ppr bty) ; return (Scaled w' arg_ty, getBangStrictness bty) } +tcRecConDeclFields :: ContextKind+ -> Located [LConDeclField GhcRn]+ -> TcM [(Scaled TcType, HsSrcBang)]+tcRecConDeclFields exp_kind fields+ = mapM (tcConArg exp_kind) btys+ where+ -- We need a one-to-one mapping from field_names to btys+ combined = map (\(L _ f) -> (cd_fld_names f,hsLinear (cd_fld_type f)))+ (unLoc fields)+ explode (ns,ty) = zip ns (repeat ty)+ exploded = concatMap explode combined+ (_,btys) = unzip exploded++tcDataConMult :: HsArrow GhcRn -> TcM Mult+tcDataConMult arr@(HsUnrestrictedArrow _) = do+ -- See Note [Function arrows in GADT constructors]+ linearEnabled <- xoptM LangExt.LinearTypes+ if linearEnabled then tcMult arr else return oneDataConTy+tcDataConMult arr = tcMult arr+ {-+Note [Function arrows in GADT constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the absence of -XLinearTypes, we always interpret function arrows+in GADT constructor types as linear, even if the user wrote an+unrestricted arrow. See the "Without -XLinearTypes" section of the+linear types GHC proposal (#111). We opt to do this in the+typechecker, and not in an earlier pass, to ensure that the AST+matches what the user wrote (#18791).+ Note [Infix GADT constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We do not currently have syntax to declare an infix constructor in GADT syntax,@@ -4078,6 +4136,36 @@ -- Check that UNPACK pragmas and bangs work out -- E.g. reject data T = MkT {-# UNPACK #-} Int -- No "!" -- data T = MkT {-# UNPACK #-} !a -- Can't unpack+ ; hsc_env <- getTopEnv+ ; let check_bang :: HsSrcBang -> HsImplBang -> Int -> TcM ()+ check_bang bang rep_bang n+ | HsSrcBang _ _ SrcLazy <- bang+ , not (xopt LangExt.StrictData dflags)+ = addErrTc (bad_bang n (text "Lazy annotation (~) without StrictData"))++ | HsSrcBang _ want_unpack strict_mark <- bang+ , isSrcUnpacked want_unpack, not (is_strict strict_mark)+ = addWarnTc NoReason (bad_bang n (text "UNPACK pragma lacks '!'"))++ | HsSrcBang _ want_unpack _ <- bang+ , isSrcUnpacked want_unpack+ , case rep_bang of { HsUnpack {} -> False; _ -> True }+ -- If not optimising, we don't unpack (rep_bang is never+ -- HsUnpack), so don't complain! This happens, e.g., in Haddock.+ -- See dataConSrcToImplBang.+ , not (gopt Opt_OmitInterfacePragmas dflags)+ -- When typechecking an indefinite package in Backpack, we+ -- may attempt to UNPACK an abstract type. The test here will+ -- conclude that this is unusable, but it might become usable+ -- when we actually fill in the abstract type. As such, don't+ -- warn in this case (it gives users the wrong idea about whether+ -- or not UNPACK on abstract types is supported; it is!)+ , isHomeUnitDefinite (hsc_home_unit hsc_env)+ = addWarnTc NoReason (bad_bang n (text "Ignoring unusable UNPACK pragma"))++ | otherwise+ = return ()+ ; zipWith3M_ check_bang (dataConSrcBangs con) (dataConImplBangs con) [1..] -- Check the dcUserTyVarBinders invariant@@ -4109,36 +4197,9 @@ } where ctxt = ConArgCtxt (dataConName con)-- check_bang :: HsSrcBang -> HsImplBang -> Int -> TcM ()- check_bang (HsSrcBang _ _ SrcLazy) _ n- | not (xopt LangExt.StrictData dflags)- = addErrTc- (bad_bang n (text "Lazy annotation (~) without StrictData"))- check_bang (HsSrcBang _ want_unpack strict_mark) rep_bang n- | isSrcUnpacked want_unpack, not is_strict- = addWarnTc NoReason (bad_bang n (text "UNPACK pragma lacks '!'"))- | isSrcUnpacked want_unpack- , case rep_bang of { HsUnpack {} -> False; _ -> True }- -- If not optimising, we don't unpack (rep_bang is never- -- HsUnpack), so don't complain! This happens, e.g., in Haddock.- -- See dataConSrcToImplBang.- , not (gopt Opt_OmitInterfacePragmas dflags)- -- When typechecking an indefinite package in Backpack, we- -- may attempt to UNPACK an abstract type. The test here will- -- conclude that this is unusable, but it might become usable- -- when we actually fill in the abstract type. As such, don't- -- warn in this case (it gives users the wrong idea about whether- -- or not UNPACK on abstract types is supported; it is!)- , isHomeUnitDefinite (mkHomeUnitFromFlags dflags)- = addWarnTc NoReason (bad_bang n (text "Ignoring unusable UNPACK pragma"))- where- is_strict = case strict_mark of- NoSrcStrict -> xopt LangExt.StrictData dflags- bang -> isSrcStrict bang-- check_bang _ _ _- = return ()+ is_strict = \case+ NoSrcStrict -> xopt LangExt.StrictData dflags+ bang -> isSrcStrict bang bad_bang n herald = hang herald 2 (text "on the" <+> speakNth n
compiler/GHC/Tc/TyCl/Build.hs view
@@ -34,6 +34,7 @@ import GHC.Core.TyCon import GHC.Core.Type import GHC.Types.Id+import GHC.Types.SourceText import GHC.Tc.Utils.TcType import GHC.Core.Multiplicity
compiler/GHC/Tc/TyCl/Class.hs view
@@ -45,7 +45,6 @@ import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Monad-import GHC.Driver.Phases (HscSource(..)) import GHC.Tc.TyCl.Build( TcMethInfo ) import GHC.Core.Class import GHC.Core.Coercion ( pprCoAxiom )@@ -58,6 +57,7 @@ import GHC.Types.Name.Set import GHC.Types.Var import GHC.Types.Var.Env+import GHC.Types.SourceFile (HscSource(..)) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Types.SrcLoc@@ -550,8 +550,10 @@ = do { warn <- woptM Opt_WarnMissingMethods ; traceTc "warn" (ppr name <+> ppr warn) ; hsc_src <- fmap tcg_src getGblEnv- -- Warn only if -Wmissing-methods AND not a signature- ; warnTc (Reason Opt_WarnMissingMethods) (warn && hsc_src /= HsigFile)+ -- hs-boot and signatures never need to provide complete "definitions"+ -- of any sort, as they aren't really defining anything, but just+ -- constraining items which are defined elsewhere.+ ; warnTc (Reason Opt_WarnMissingMethods) (warn && hsc_src == HsSrcFile) (text "No explicit" <+> text "associated type" <+> text "or default declaration for" <+> quotes (ppr name)) }
compiler/GHC/Tc/TyCl/Instance.hs view
@@ -67,11 +67,13 @@ import GHC.Types.Var.Set import GHC.Data.Bag import GHC.Types.Basic+import GHC.Types.Fixity import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Utils.Error import GHC.Data.FastString import GHC.Types.Id+import GHC.Types.SourceText import GHC.Data.List.SetOps import GHC.Types.Name import GHC.Types.Name.Set@@ -512,9 +514,18 @@ -- Check for missing associated types and build them -- from their defaults (if available)+ ; is_boot <- tcIsHsBootOrSig+ ; let atItems = classATItems clas ; tf_insts2 <- mapM (tcATDefault loc mini_subst defined_ats)- (classATItems clas)-+ (if is_boot then [] else atItems)+ -- Don't default type family instances, but rather omit, in hsig/hs-boot.+ -- Since hsig/hs-boot files are essentially large binders we want omission+ -- of the definition to result in no restriction, rather than for example+ -- attempting to "pattern match" with the invisible defaults and generate+ -- equalities. Without further handling, this would just result in a panic+ -- anyway.+ -- See https://github.com/ghc-proposals/ghc-proposals/pull/320 for+ -- additional discussion. ; return (df_stuff, tf_insts1 ++ concat tf_insts2) } @@ -539,8 +550,8 @@ all_insts = tyfam_insts ++ datafam_insts -- In hs-boot files there should be no bindings- ; is_boot <- tcIsHsBootOrSig ; let no_binds = isEmptyLHsBinds binds && null uprags+ ; is_boot <- tcIsHsBootOrSig ; failIfTc (is_boot && not no_binds) badBootDeclErr ; return ( [inst_info], all_insts, deriv_infos ) }
compiler/GHC/Tc/TyCl/PatSyn.hs view
@@ -1,16 +1,15 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998---}- {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++-}+ -- | Typechecking pattern synonym declarations module GHC.Tc.TyCl.PatSyn ( tcPatSynDecl@@ -32,9 +31,9 @@ import GHC.Tc.Utils.Zonk import GHC.Builtin.Types.Prim import GHC.Types.Name+import GHC.Types.Name.Set import GHC.Types.SrcLoc import GHC.Core.PatSyn-import GHC.Types.Name.Set import GHC.Utils.Panic import GHC.Utils.Outputable import GHC.Data.FastString@@ -423,14 +422,22 @@ ; 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', (map scaledThing arg_tys))+ (args', map scaledThing arg_tys) pat_ty rec_fields } where tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr GhcTc)+ -- Look up the variable actually bound by lpat+ -- and check that it has the expected type 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+ = setSrcSpan (nameSrcSpan arg_name) $+ -- Set the SrcSpan to be the binding site of the Id (#18856)+ -- e.g. pattern P :: Int -> Maybe (Int,Bool)+ -- pattern P x = Just (x,True)+ -- Before unifying x's actual type with its expected type, in tc_arg, set+ -- location to x's binding site in lpat, namely the 'x' in Just (x,True).+ -- Else the error message location is wherever tcCheckPat finished,+ -- namely the right-hand corner of the pattern+ do { arg_id <- tcLookupId arg_name ; wrap <- tcSubTypeSigma GenSigCtxt (idType arg_id) (substTyUnchecked subst arg_ty)@@ -806,7 +813,6 @@ builder_id' = modifyIdInfo (`setLevityInfoWithType` pat_ty) builder_id ; return (Just (builder_id', need_dummy_arg)) }- where tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc)
compiler/GHC/Tc/TyCl/Utils.hs view
@@ -1,16 +1,15 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1999---}- {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1999++-}+ -- | Analysis functions over data types. Specifically, detecting recursive types. -- -- This stuff is only used for source-code decls; it's recorded in interface@@ -35,39 +34,49 @@ import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Gen.Bind( tcValBinds )+import GHC.Tc.Utils.TcType++import GHC.Builtin.Types( unitTy )+import GHC.Builtin.Uniques ( mkBuiltinUnique )++import GHC.Hs+ 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 ) import GHC.Core.Make( rEC_SEL_ERROR_ID )-import GHC.Hs import GHC.Core.Class import GHC.Core.Type-import GHC.Driver.Types import GHC.Core.TyCon import GHC.Core.ConLike import GHC.Core.DataCon-import GHC.Types.Name-import GHC.Types.Name.Env-import GHC.Types.Name.Set hiding (unitFV)-import GHC.Types.Name.Reader ( mkVarUnqual )-import GHC.Types.Id-import GHC.Types.Id.Info-import GHC.Types.Var.Env-import GHC.Types.Var.Set+import GHC.Core.TyCon.Set import GHC.Core.Coercion ( ltRole )-import GHC.Types.Basic-import GHC.Types.SrcLoc-import GHC.Builtin.Uniques ( mkBuiltinUnique )+ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc+import GHC.Utils.FV as FV+ import GHC.Data.Maybe import GHC.Data.Bag import GHC.Data.FastString-import GHC.Utils.FV as FV+ import GHC.Unit.Module++import GHC.Types.Basic+import GHC.Types.SrcLoc+import GHC.Types.SourceFile+import GHC.Types.SourceText+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Name.Reader ( mkVarUnqual )+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Unique.Set+import GHC.Types.TyThing import qualified GHC.LanguageExtensions as LangExt import Control.Monad@@ -156,7 +165,11 @@ runSynCycleM :: SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState) } deriving (Functor) -type SynCycleState = NameSet+-- TODO: TyConSet is implemented as IntMap over uniques.+-- But we could get away with something based on IntSet+-- since we only check membershib, but never extract the+-- elements.+type SynCycleState = TyConSet instance Applicative SynCycleM where pure x = SynCycleM $ \state -> Right (x, state)@@ -174,12 +187,12 @@ -- | Test if a 'Name' is acyclic, short-circuiting if we've -- seen it already.-checkNameIsAcyclic :: Name -> SynCycleM () -> SynCycleM ()-checkNameIsAcyclic n m = SynCycleM $ \s ->- if n `elemNameSet` s+checkTyConIsAcyclic :: TyCon -> SynCycleM () -> SynCycleM ()+checkTyConIsAcyclic tc m = SynCycleM $ \s ->+ if tc `elemTyConSet` s then Right ((), s) -- short circuit else case runSynCycleM m s of- Right ((), s') -> Right ((), extendNameSet s' n)+ Right ((), s') -> Right ((), extendTyConSet s' tc) Left err -> Left err -- | Checks if any of the passed in 'TyCon's have cycles.@@ -188,8 +201,8 @@ -- the corresponding @LTyClDecl Name@ for each 'TyCon', so we -- can give better error messages. checkSynCycles :: Unit -> [TyCon] -> [LTyClDecl GhcRn] -> TcM ()-checkSynCycles this_uid tcs tyclds = do- case runSynCycleM (mapM_ (go emptyNameSet []) tcs) emptyNameSet of+checkSynCycles this_uid tcs tyclds =+ case runSynCycleM (mapM_ (go emptyTyConSet []) tcs) emptyTyConSet of Left (loc, err) -> setSrcSpan loc $ failWithTc err Right _ -> return () where@@ -198,15 +211,15 @@ -- Short circuit if we've already seen this Name and concluded -- it was acyclic.- go :: NameSet -> [TyCon] -> TyCon -> SynCycleM ()+ go :: TyConSet -> [TyCon] -> TyCon -> SynCycleM () go so_far seen_tcs tc =- checkNameIsAcyclic (tyConName tc) $ go' so_far seen_tcs tc+ checkTyConIsAcyclic tc $ go' so_far seen_tcs tc -- Expand type synonyms, complaining if you find the same -- type synonym a second time.- go' :: NameSet -> [TyCon] -> TyCon -> SynCycleM ()+ go' :: TyConSet -> [TyCon] -> TyCon -> SynCycleM () go' so_far seen_tcs tc- | n `elemNameSet` so_far+ | tc `elemTyConSet` so_far = failSynCycleM (getSrcSpan (head seen_tcs)) $ sep [ text "Cycle in type synonym declarations:" , nest 2 (vcat (map ppr_decl seen_tcs)) ]@@ -221,7 +234,7 @@ isInteractiveModule mod) = return () | Just ty <- synTyConRhs_maybe tc =- go_ty (extendNameSet so_far (tyConName tc)) (tc:seen_tcs) ty+ go_ty (extendTyConSet so_far tc) (tc:seen_tcs) ty | otherwise = return () where n = tyConName tc@@ -234,7 +247,7 @@ where n = tyConName tc - go_ty :: NameSet -> [TyCon] -> Type -> SynCycleM ()+ go_ty :: TyConSet -> [TyCon] -> Type -> SynCycleM () go_ty so_far seen_tcs ty = mapM_ (go so_far seen_tcs) (synonymTyConsOfType ty) @@ -284,11 +297,13 @@ Each step expands superclasses one layer, and clearly does not terminate. -} +type ClassSet = UniqSet Class+ checkClassCycles :: Class -> Maybe SDoc -- Nothing <=> ok -- Just err <=> possible cycle error checkClassCycles cls- = do { (definite_cycle, err) <- go (unitNameSet (getName cls))+ = do { (definite_cycle, err) <- go (unitUniqSet cls) cls (mkTyVarTys (classTyVars cls)) ; let herald | definite_cycle = text "Superclass cycle for" | otherwise = text "Potential superclass cycle for"@@ -304,12 +319,12 @@ -- NB: this code duplicates TcType.transSuperClasses, but -- with more error message generation clobber -- Make sure the two stay in sync.- go :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc)+ go :: ClassSet -> Class -> [Type] -> Maybe (Bool, SDoc) go so_far cls tys = firstJusts $ map (go_pred so_far) $ immSuperClasses cls tys - go_pred :: NameSet -> PredType -> Maybe (Bool, SDoc)+ go_pred :: ClassSet -> PredType -> Maybe (Bool, SDoc) -- Nothing <=> ok -- Just (True, err) <=> definite cycle -- Just (False, err) <=> possible cycle@@ -322,7 +337,7 @@ | otherwise = Nothing - go_tc :: NameSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, SDoc)+ go_tc :: ClassSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, SDoc) go_tc so_far pred tc tys | isFamilyTyCon tc = Just (False, hang (text "one of whose superclass constraints is headed by a type family:")@@ -332,18 +347,16 @@ | otherwise -- Equality predicate, for example = Nothing - go_cls :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc)+ go_cls :: ClassSet -> Class -> [Type] -> Maybe (Bool, SDoc) go_cls so_far cls tys- | cls_nm `elemNameSet` so_far+ | cls `elementOfUniqSet` so_far = Just (True, text "one of whose superclasses is" <+> quotes (ppr cls)) | isCTupleClass cls = go so_far cls tys | otherwise- = do { (b,err) <- go (so_far `extendNameSet` cls_nm) cls tys+ = do { (b,err) <- go (so_far `addOneToUniqSet` cls) cls tys ; return (b, text "one of whose superclasses is" <+> quotes (ppr cls) $$ err) }- where- cls_nm = getName cls {- ************************************************************************@@ -580,8 +593,8 @@ irDataCon datacon = setRoleInferenceVars univ_tvs $ irExTyVars ex_tvs $ \ ex_var_set ->- mapM_ (irType ex_var_set)- (map tyVarKind ex_tvs ++ eqSpecPreds eq_spec ++ theta ++ (map scaledThing arg_tys))+ do mapM_ (irType ex_var_set) (eqSpecPreds eq_spec ++ theta ++ map scaledThing arg_tys)+ mapM_ (markNominal ex_var_set) (map tyVarKind ex_tvs ++ map scaledMult arg_tys) -- Field multiplicities are nominal (#18799) -- See Note [Role-checking data constructor arguments] where (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty)@@ -762,8 +775,7 @@ do { traceTc "tcAddTyCons" $ vcat [ text "tycons" <+> ppr tyclss , text "implicits" <+> ppr implicit_things ]- ; gbl_env <- tcRecSelBinds (mkRecSelBinds tyclss)- ; return gbl_env }+ ; tcRecSelBinds (mkRecSelBinds tyclss) } where implicit_things = concatMap implicitTyConThings tyclss def_meth_ids = mkDefaultMethodIds tyclss
compiler/GHC/Tc/Types/EvTerm.hs view
@@ -6,19 +6,25 @@ import GHC.Prelude -import GHC.Data.FastString+import GHC.Driver.Session++import GHC.Tc.Types.Evidence++import GHC.Unit++import GHC.Builtin.Names+ import GHC.Core.Type import GHC.Core import GHC.Core.Make-import GHC.Types.Literal ( Literal(..) )-import GHC.Tc.Types.Evidence-import GHC.Driver.Types-import GHC.Driver.Session-import GHC.Types.Name-import GHC.Unit import GHC.Core.Utils-import GHC.Builtin.Names++import GHC.Types.Literal ( Literal(..) ) import GHC.Types.SrcLoc+import GHC.Types.Name+import GHC.Types.TyThing++import GHC.Data.FastString -- Used with Opt_DeferTypeErrors -- See Note [Deferring coercion errors to runtime]
compiler/GHC/Tc/Utils/Backpack.hs view
@@ -1,9 +1,7 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-} module GHC.Tc.Utils.Backpack ( findExtraSigImports',@@ -20,58 +18,75 @@ import GHC.Prelude -import GHC.Types.Basic (defaultFixity, TypeOrKind(..))-import GHC.Unit-import GHC.Tc.Gen.Export+import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Ppr-import GHC.Hs++import GHC.Types.Basic (TypeOrKind(..))+import GHC.Types.Fixity (defaultFixity)+import GHC.Types.Fixity.Env+import GHC.Types.TypeEnv import GHC.Types.Name.Reader-import GHC.Tc.Utils.Monad+import GHC.Types.Id+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Name.Set+import GHC.Types.Avail+import GHC.Types.SrcLoc+import GHC.Types.SourceFile+import GHC.Types.Var+import GHC.Types.Unique.DSet+import GHC.Types.Name.Shape++import GHC.Unit+import GHC.Unit.State+import GHC.Unit.Finder+import GHC.Unit.Module.Warnings+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.Imported+import GHC.Unit.Module.Deps++import GHC.Tc.Gen.Export import GHC.Tc.TyCl.Utils-import GHC.Core.InstEnv-import GHC.Core.FamInstEnv+import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Instantiate-import GHC.IfaceToCore import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType import GHC.Tc.Solver import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin-import GHC.Iface.Load-import GHC.Rename.Names-import GHC.Utils.Error-import GHC.Types.Id-import GHC.Types.Name-import GHC.Types.Name.Env-import GHC.Types.Name.Set-import GHC.Types.Avail-import GHC.Types.SrcLoc-import GHC.Driver.Types-import GHC.Utils.Outputable-import GHC.Utils.Panic++import GHC.Hs++import GHC.Core.InstEnv+import GHC.Core.FamInstEnv import GHC.Core.Type import GHC.Core.Multiplicity-import GHC.Data.FastString-import GHC.Rename.Fixity ( lookupFixityRn )-import GHC.Data.Maybe-import GHC.Tc.Utils.Env-import GHC.Types.Var++import GHC.IfaceToCore+import GHC.Iface.Load+import GHC.Iface.Rename import GHC.Iface.Syntax-import GHC.Builtin.Names-import qualified Data.Map as Map -import GHC.Driver.Finder-import GHC.Types.Unique.DSet-import GHC.Types.Name.Shape+import GHC.Rename.Names+import GHC.Rename.Fixity ( lookupFixityRn )++import GHC.Tc.Utils.Env import GHC.Tc.Errors import GHC.Tc.Utils.Unify-import GHC.Iface.Rename+ import GHC.Utils.Misc-import GHC.Unit.State+import GHC.Utils.Error+import GHC.Utils.Outputable+import GHC.Utils.Panic +import GHC.Data.FastString+import GHC.Data.Maybe+ import Control.Monad import Data.List (find)+import qualified Data.Map as Map import {-# SOURCE #-} GHC.Tc.Module @@ -314,8 +329,7 @@ Found _ mod | not (isHomeModule home_unit mod) -> return (uniqDSetToList (moduleFreeHoles mod)) _ -> return []- where dflags = hsc_dflags hsc_env- home_unit = mkHomeUnitFromFlags dflags+ where home_unit = hsc_home_unit hsc_env -- | Given a 'Unit', make sure it is well typed. This is because -- unit IDs come from Cabal, which does not know if things are well-typed or@@ -346,7 +360,7 @@ initTc hsc_env HsigFile -- bogus False- mAIN -- bogus+ (mainModIs dflags) (realSrcLocSpan (mkRealSrcLoc (fsLit loc_str) 0 0)) -- bogus $ checkUnit uid where@@ -539,7 +553,7 @@ inner_mod = tcg_semantic_mod tcg_env mod_name = moduleName (tcg_mod tcg_env) unit_state = unitState dflags- home_unit = mkHomeUnitFromFlags dflags+ home_unit = hsc_home_unit hsc_env -- STEP 1: Figure out all of the external signature interfaces -- we are going to merge in.@@ -831,6 +845,7 @@ -- we hope that we get lucky / the overlapping instances never -- get used, but it is not a very good situation to be in. --+ hsc_env <- getTopEnv let merge_inst (insts, inst_env) inst | memberInstEnv inst_env inst -- test DFun Type equality = (insts, inst_env)@@ -845,8 +860,9 @@ -- in the listing. We don't want it because a module is NOT -- supposed to include itself in its dep_orphs/dep_finsts. See #13214 iface' = iface { mi_final_exts = (mi_final_exts iface){ mi_orphan = False, mi_finsts = False } }+ home_unit = hsc_home_unit hsc_env avails = plusImportAvails (tcg_imports tcg_env) $- calculateAvails dflags iface' False NotBoot ImportedBySystem+ calculateAvails home_unit iface' False NotBoot ImportedBySystem return tcg_env { tcg_inst_env = inst_env, tcg_insts = insts,@@ -913,7 +929,9 @@ checkImplements :: Module -> InstantiatedModule -> TcRn TcGblEnv checkImplements impl_mod req_mod@(Module uid mod_name) = do dflags <- getDynFlags+ hsc_env <- getTopEnv let unit_state = unitState dflags+ home_unit = hsc_home_unit hsc_env addErrCtxt (impl_msg unit_state impl_mod req_mod) $ do let insts = instUnitInsts uid @@ -934,7 +952,7 @@ loadModuleInterfaces (text "Loading orphan modules (from implementor of hsig)") (dep_orphs (mi_deps impl_iface)) - let avails = calculateAvails dflags+ let avails = calculateAvails home_unit impl_iface False{- safe -} NotBoot ImportedBySystem fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f) | (occ, f) <- mi_fixities impl_iface@@ -998,11 +1016,11 @@ -- checking that the implementation matches the signature. instantiateSignature :: TcRn TcGblEnv instantiateSignature = do+ hsc_env <- getTopEnv tcg_env <- getGblEnv- dflags <- getDynFlags let outer_mod = tcg_mod tcg_env inner_mod = tcg_semantic_mod tcg_env- home_unit = mkHomeUnitFromFlags dflags+ home_unit = hsc_home_unit hsc_env -- TODO: setup the local RdrEnv so the error messages look a little better. -- But this information isn't stored anywhere. Should we RETYPECHECK -- the local one just to get the information? Hmm...
compiler/GHC/Tc/Utils/Env.hs view
@@ -74,21 +74,27 @@ import GHC.Prelude +import GHC.Driver.Env+import GHC.Driver.Session++import GHC.Builtin.Names+import GHC.Builtin.Types++import GHC.Runtime.Context+ import GHC.Hs+ import GHC.Iface.Env+import GHC.Iface.Load+ 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-import GHC.Types.Id-import GHC.Types.Var-import GHC.Types.Name.Reader++import GHC.Core.UsageEnv import GHC.Core.InstEnv import GHC.Core.DataCon ( DataCon ) import GHC.Core.PatSyn ( PatSyn )@@ -97,26 +103,35 @@ import GHC.Core.Type import GHC.Core.Coercion.Axiom import GHC.Core.Class-import GHC.Types.Name-import GHC.Types.Name.Set-import GHC.Types.Name.Env-import GHC.Types.Var.Env-import GHC.Driver.Types-import GHC.Driver.Session-import GHC.Types.SrcLoc-import GHC.Types.Basic hiding( SuccessFlag(..) )+ import GHC.Unit.Module import GHC.Unit.Home+import GHC.Unit.External+ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Encoding+import GHC.Utils.Error+import GHC.Utils.Misc ( HasDebugCallStack )+ import GHC.Data.FastString import GHC.Data.Bag import GHC.Data.List.SetOps-import GHC.Utils.Error import GHC.Data.Maybe( MaybeErr(..), orElse )++import GHC.Types.SrcLoc+import GHC.Types.Basic hiding( SuccessFlag(..) )+import GHC.Types.TypeEnv+import GHC.Types.SourceFile+import GHC.Types.Name+import GHC.Types.Name.Set+import GHC.Types.Name.Env+import GHC.Types.Id+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Name.Reader+import GHC.Types.TyThing import qualified GHC.LanguageExtensions as LangExt-import GHC.Utils.Misc ( HasDebugCallStack ) import Data.IORef import Data.List (intercalate)@@ -146,8 +161,7 @@ lookupGlobal_maybe hsc_env name = do { -- Try local envt let mod = icInteractiveModule (hsc_IC hsc_env)- dflags = hsc_dflags hsc_env- home_unit = mkHomeUnitFromFlags dflags+ home_unit = hsc_home_unit hsc_env tcg_semantic_mod = homeModuleInstantiation home_unit mod ; if nameIsLocalOrFrom tcg_semantic_mod name@@ -162,7 +176,7 @@ lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing) -- Returns (Failed err) if we can't find the interface file for the thing lookupImported_maybe hsc_env name- = do { mb_thing <- lookupTypeHscEnv hsc_env name+ = do { mb_thing <- lookupType hsc_env name ; case mb_thing of Just thing -> return (Succeeded thing) Nothing -> importDecl_maybe hsc_env name@@ -506,13 +520,14 @@ tcExtendNameTyVarEnv binds thing_inside -- this should be used only for explicitly mentioned scoped variables. -- thus, no coercion variables- = do { tc_extend_local_env NotTopLevel- [(name, ATyVar name tv) | (name, tv) <- binds] $- tcExtendBinderStack tv_binds $- thing_inside }+ = tc_extend_local_env NotTopLevel names $+ tcExtendBinderStack tv_binds $+ thing_inside where tv_binds :: [TcBinder] tv_binds = [TcTvBndr name tv | (name,tv) <- binds]++ names = [(name, ATyVar name tv) | (name, tv) <- binds] isTypeClosedLetBndr :: Id -> Bool -- See Note [Bindings with closed types] in GHC.Tc.Types
compiler/GHC/Tc/Utils/Instantiate.hs view
@@ -1,87 +1,92 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE CPP, MultiWayIf, TupleSections #-}-{-# LANGUAGE FlexibleContexts #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- module GHC.Tc.Utils.Instantiate (- topSkolemise,- topInstantiate, instantiateSigma,- instCall, instDFunType, instStupidTheta, instTyVarsWith,- newWanted, newWanteds,+ topSkolemise,+ topInstantiate, instantiateSigma,+ instCall, instDFunType, instStupidTheta, instTyVarsWith,+ newWanted, newWanteds, - tcInstType, tcInstTypeBndrs,- tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarsAt,- tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX,+ tcInstType, tcInstTypeBndrs,+ tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarsAt,+ tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX, - freshenTyVarBndrs, freshenCoVarBndrsX,+ freshenTyVarBndrs, freshenCoVarBndrsX, - tcInstInvisibleTyBindersN, tcInstInvisibleTyBinders, tcInstInvisibleTyBinder,+ tcInstInvisibleTyBindersN, tcInstInvisibleTyBinders, tcInstInvisibleTyBinder, - newOverloadedLit, mkOverLit,+ newOverloadedLit, mkOverLit, - newClsInst,- tcGetInsts, tcGetInstEnvs, getOverlapFlag,- tcExtendLocalInstEnv,- instCallConstraints, newMethodFromName,- tcSyntaxName,+ newClsInst,+ tcGetInsts, tcGetInstEnvs, getOverlapFlag,+ tcExtendLocalInstEnv,+ instCallConstraints, newMethodFromName,+ tcSyntaxName, - -- Simple functions over evidence variables- tyCoVarsOfWC,- tyCoVarsOfCt, tyCoVarsOfCts,- ) where+ -- Simple functions over evidence variables+ tyCoVarsOfWC,+ tyCoVarsOfCt, tyCoVarsOfCts,+ ) where #include "GhclibHsVersions.h" import GHC.Prelude -import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcCheckPolyExpr, tcSyntaxOp )-import {-# SOURCE #-} GHC.Tc.Utils.Unify( unifyType, unifyKind )+import GHC.Driver.Session -import GHC.Types.Basic ( IntegralLit(..), SourceText(..) )+import GHC.Builtin.Types ( heqDataCon, eqDataCon, integerTyConName )+import GHC.Builtin.Names+ import GHC.Hs++import GHC.Core.InstEnv+import GHC.Core.Predicate+import GHC.Core ( Expr(..), isOrphan ) -- For the Coercion constructor+import GHC.Core.Type+import GHC.Core.Multiplicity+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Ppr ( debugPprType )+import GHC.Core.Class( Class )+import GHC.Core.DataCon++import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcCheckPolyExpr, tcSyntaxOp )+import {-# SOURCE #-} GHC.Tc.Utils.Unify( unifyType, unifyKind ) import GHC.Tc.Utils.Zonk import GHC.Tc.Utils.Monad import GHC.Tc.Types.Constraint-import GHC.Core.Predicate import GHC.Tc.Types.Origin import GHC.Tc.Utils.Env import GHC.Tc.Types.Evidence-import GHC.Core.InstEnv-import GHC.Builtin.Types ( heqDataCon, eqDataCon, 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-import GHC.Driver.Types-import GHC.Core.Class( Class )+ import GHC.Types.Id.Make( mkDictFunId )-import GHC.Core( Expr(..) ) -- For the Coercion constructor+import GHC.Types.Basic ( TypeOrKind(..) )+import GHC.Types.SourceText+import GHC.Types.SrcLoc as SrcLoc+import GHC.Types.Var.Env+import GHC.Types.Var.Set import GHC.Types.Id import GHC.Types.Name import GHC.Types.Var-import GHC.Core.DataCon-import GHC.Types.Var.Env-import GHC.Types.Var.Set-import GHC.Builtin.Names-import GHC.Types.SrcLoc as SrcLoc-import GHC.Driver.Session+import qualified GHC.LanguageExtensions as LangExt+ import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Outputable-import GHC.Types.Basic ( TypeOrKind(..) )-import qualified GHC.LanguageExtensions as LangExt+ import GHC.Unit.State+import GHC.Unit.External import Data.List ( sortBy, mapAccumL ) import Control.Monad( unless )
compiler/GHC/Tc/Utils/Monad.hs view
@@ -1,15 +1,17 @@-{--(c) The University of Glasgow 2006---}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE CPP, ExplicitForAll, FlexibleInstances, BangPatterns #-}-{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}-{-# LANGUAGE ViewPatterns #-} +{-+(c) The University of Glasgow 2006 +-}+ -- | Functions for working with the typechecker environment (setters, -- getters...). module GHC.Tc.Utils.Monad(@@ -149,47 +151,61 @@ import GHC.Prelude -import GHC.Driver.Ppr +import GHC.Builtin.Names+ import GHC.Tc.Types -- Re-export all-import GHC.Data.IOEnv -- Re-export all import GHC.Tc.Types.Constraint import GHC.Tc.Types.Evidence import GHC.Tc.Types.Origin+import GHC.Tc.Utils.TcType import GHC.Hs hiding (LIE)-import GHC.Driver.Types+ import GHC.Unit-import GHC.Types.Name.Reader-import GHC.Types.Name+import GHC.Unit.External+import GHC.Unit.Module.Warnings+import GHC.Unit.Home.ModInfo+ import GHC.Core.UsageEnv import GHC.Core.Multiplicity-import GHC.Core.Type--import GHC.Tc.Utils.TcType import GHC.Core.InstEnv import GHC.Core.FamInstEnv-import GHC.Builtin.Names +import GHC.Driver.Env+import GHC.Driver.Ppr+import GHC.Driver.Session++import GHC.Runtime.Context++import GHC.Data.IOEnv -- Re-export all+import GHC.Data.Bag+import GHC.Data.FastString+import GHC.Data.Maybe++import GHC.Utils.Outputable as Outputable+import GHC.Utils.Error+import GHC.Utils.Panic+import GHC.Utils.Misc++import GHC.Types.Fixity.Env+import GHC.Types.Name.Reader+import GHC.Types.Name+import GHC.Types.SafeHaskell import GHC.Types.Id+import GHC.Types.TypeEnv import GHC.Types.Var.Set import GHC.Types.Var.Env-import GHC.Utils.Error import GHC.Types.SrcLoc import GHC.Types.Name.Env import GHC.Types.Name.Set-import GHC.Data.Bag-import GHC.Utils.Outputable as Outputable+import GHC.Types.Name.Ppr import GHC.Types.Unique (uniqFromMask) import GHC.Types.Unique.Supply-import GHC.Driver.Session-import GHC.Data.FastString-import GHC.Utils.Panic-import GHC.Utils.Misc import GHC.Types.Annotations import GHC.Types.Basic( TopLevelFlag, TypeOrKind(..) )-import GHC.Data.Maybe import GHC.Types.CostCentre.State+import GHC.Types.SourceFile import qualified GHC.LanguageExtensions as LangExt @@ -242,7 +258,7 @@ th_remote_state_var <- newIORef Nothing ; let { dflags = hsc_dflags hsc_env ;- home_unit = mkHomeUnitFromFlags dflags ;+ home_unit = hsc_home_unit hsc_env ; maybe_rn_syntax :: forall a. a -> Maybe a ; maybe_rn_syntax empty_val@@ -730,14 +746,14 @@ formatTraceMsg herald doc = hang (text herald) 2 doc traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()-traceOptTcRn flag doc = do+traceOptTcRn flag doc = whenDOptM flag $ dumpTcRn False (dumpOptionsFromFlag flag) "" FormatText doc {-# INLINE traceOptTcRn #-} -- see Note [INLINE conditional tracing utilities] -- | Dump if the given 'DumpFlag' is set. dumpOptTcRn :: DumpFlag -> String -> DumpFormat -> SDoc -> TcRn ()-dumpOptTcRn flag title fmt doc = do+dumpOptTcRn flag title fmt doc = whenDOptM flag $ dumpTcRn False (dumpOptionsFromFlag flag) title fmt doc {-# INLINE dumpOptTcRn #-} -- see Note [INLINE conditional tracing utilities]@@ -774,8 +790,9 @@ getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified getPrintUnqualified dflags = do { rdr_env <- getGlobalRdrEnv+ ; hsc_env <- getTopEnv ; let unit_state = unitState dflags- ; let home_unit = mkHomeUnitFromFlags dflags+ ; let home_unit = hsc_home_unit hsc_env ; return $ mkPrintUnqualified unit_state home_unit rdr_env } -- | Like logInfoTcRn, but for user consumption@@ -1967,9 +1984,9 @@ initIfaceTcRn :: IfG a -> TcRn a initIfaceTcRn thing_inside = do { tcg_env <- getGblEnv- ; dflags <- getDynFlags+ ; hsc_env <- getTopEnv ; let !mod = tcg_semantic_mod tcg_env- home_unit = mkHomeUnitFromFlags dflags+ home_unit = hsc_home_unit hsc_env -- When we are instantiating a signature, we DEFINITELY -- do not want to knot tie. is_instantiate = isHomeUnitInstantiating home_unit@@ -2036,43 +2053,43 @@ ; failM } ---------------------forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)--- Run thing_inside in an interleaved thread.++-- | Run thing_inside in an interleaved thread. -- It shares everything with the parent thread, so this is DANGEROUS. -- -- It returns Nothing if the computation fails -- -- It's used for lazily type-checking interface--- signatures, which is pretty benign-+-- signatures, which is pretty benign.+--+-- See Note [Masking exceptions in forkM_maybe]+forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a) forkM_maybe doc thing_inside- = do { -- see Note [Masking exceptions in forkM_maybe]- ; unsafeInterleaveM $ uninterruptibleMaskM_ $- do { traceIf (text "Starting fork {" <+> doc)- ; mb_res <- tryM $- updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $- thing_inside- ; case mb_res of- Right r -> do { traceIf (text "} ending fork" <+> doc)- ; return (Just r) }- Left exn -> do {-- -- Bleat about errors in the forked thread, if -ddump-if-trace is on- -- Otherwise we silently discard errors. Errors can legitimately- -- happen when compiling interface signatures (see tcInterfaceSigs)- whenDOptM Opt_D_dump_if_trace $ do- dflags <- getDynFlags- let msg = hang (text "forkM failed:" <+> doc)- 2 (text (show exn))- liftIO $ putLogMsg dflags- NoReason- SevFatal- noSrcSpan- $ withPprStyle defaultErrStyle msg+ = unsafeInterleaveM $ uninterruptibleMaskM_ $+ do { traceIf (text "Starting fork {" <+> doc)+ ; mb_res <- tryM $+ updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $+ thing_inside+ ; case mb_res of+ Right r -> do { traceIf (text "} ending fork" <+> doc)+ ; return (Just r) }+ Left exn -> do {+ -- Bleat about errors in the forked thread, if -ddump-if-trace is on+ -- Otherwise we silently discard errors. Errors can legitimately+ -- happen when compiling interface signatures (see tcInterfaceSigs)+ whenDOptM Opt_D_dump_if_trace $ do+ dflags <- getDynFlags+ let msg = hang (text "forkM failed:" <+> doc)+ 2 (text (show exn))+ liftIO $ putLogMsg dflags+ NoReason+ SevFatal+ noSrcSpan+ $ withPprStyle defaultErrStyle msg - ; traceIf (text "} ending fork (badly)" <+> doc)- ; return Nothing }- }}+ ; traceIf (text "} ending fork (badly)" <+> doc)+ ; return Nothing }+ } forkM :: SDoc -> IfL a -> IfL a forkM doc thing_inside
compiler/GHC/Tc/Utils/TcMType.hs view
@@ -1,13 +1,14 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TupleSections #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE CPP, TupleSections, MultiWayIf, PatternSynonyms, BangPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- -- | Monadic type operations -- -- This module contains monadic operations over types that contain mutable type@@ -998,7 +999,6 @@ -- 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 )
compiler/GHC/Tc/Utils/Unify.hs view
@@ -1,15 +1,16 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998- -} -{-# LANGUAGE CPP, DeriveFunctor, MultiWayIf, TupleSections,- ScopedTypeVariables #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- -- | Type subsumption and unification module GHC.Tc.Utils.Unify ( -- Full-blown subsumption@@ -1320,7 +1321,7 @@ This is particularly helpful when checking (* ~ *), because * is now a type synonym. -Note [Deferred Unification]+Note [Deferred unification] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ We may encounter a unification ty1 ~ ty2 that cannot be performed syntactically, and yet its consistency is undetermined. Previously, there was no way to still
compiler/GHC/Tc/Utils/Zonk.hs view
@@ -1,16 +1,15 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ {- (c) The University of Glasgow 2006 (c) The AQUA Project, Glasgow University, 1996-1998 -} -{-# LANGUAGE CPP, TupleSections #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- -- | Specialisations of the @HsSyn@ syntax for the typechecker -- -- This module is an extension of @HsSyn@ syntax, for use in the type checker.@@ -48,43 +47,52 @@ import GHC.Prelude +import GHC.Platform++import GHC.Builtin.Types+import GHC.Builtin.Types.Prim+import GHC.Builtin.Names+ import GHC.Hs-import GHC.Types.Id-import GHC.Types.Id.Info-import GHC.Core.Predicate++import {-# SOURCE #-} GHC.Tc.Gen.Splice (runTopSplice) import GHC.Tc.Utils.Monad-import GHC.Builtin.Names import GHC.Tc.TyCl.Build ( TcMethInfo, MethInfo ) import GHC.Tc.Utils.TcType import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.Env ( tcLookupGlobalOnly ) import GHC.Tc.Types.Evidence+ import GHC.Core.TyCo.Ppr ( pprTyVar )-import GHC.Builtin.Types.Prim import GHC.Core.TyCon-import GHC.Builtin.Types import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.ConLike import GHC.Core.DataCon-import GHC.Driver.Types++import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Utils.Panic++import GHC.Core.Multiplicity+import GHC.Core+import GHC.Core.Predicate+ import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Var import GHC.Types.Var.Env-import GHC.Platform+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.TypeEnv+import GHC.Types.SourceText import GHC.Types.Basic-import GHC.Data.Maybe import GHC.Types.SrcLoc-import GHC.Data.Bag-import GHC.Utils.Outputable-import GHC.Utils.Misc-import GHC.Utils.Panic import GHC.Types.Unique.FM-import GHC.Core.Multiplicity-import GHC.Core+import GHC.Types.TyThing -import {-# SOURCE #-} GHC.Tc.Gen.Splice (runTopSplice)+import GHC.Data.Maybe+import GHC.Data.Bag import Control.Monad import Data.List ( partition )
compiler/GHC/Tc/Validity.hs view
@@ -1,13 +1,13 @@+{-# LANGUAGE CPP #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE CPP, TupleSections, ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- module GHC.Tc.Validity ( Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType, checkValidTheta,@@ -525,9 +525,7 @@ -- GHCi's :kind command accepts both types and kinds -- | Returns 'True' if the supplied 'UserTypeCtxt' is unambiguously not the--- context for a kind of a type, where the arbitrary use of constraints is--- currently disallowed.--- (See @Note [Constraints in kinds]@ in "GHC.Core.TyCo.Rep".)+-- context for a kind of a type. -- If the 'UserTypeCtxt' can refer to both types and kinds, this function -- conservatively returns 'True'. --@@ -535,13 +533,26 @@ -- @Show a => a -> a@ in @type Foo :: Show a => a -> a@. On the other hand, the -- same type in @foo :: Show a => a -> a@ is unambiguously the type of a term, -- not the kind of a type, so it is permitted.-allConstraintsAllowed :: UserTypeCtxt -> Bool-allConstraintsAllowed ctxt = case typeOrKindCtxt ctxt of+typeLevelUserTypeCtxt :: UserTypeCtxt -> Bool+typeLevelUserTypeCtxt ctxt = case typeOrKindCtxt ctxt of OnlyTypeCtxt -> True OnlyKindCtxt -> False BothTypeAndKindCtxt -> True -- | Returns 'True' if the supplied 'UserTypeCtxt' is unambiguously not the+-- context for a kind of a type, where the arbitrary use of constraints is+-- currently disallowed.+-- (See @Note [Constraints in kinds]@ in "GHC.Core.TyCo.Rep".)+allConstraintsAllowed :: UserTypeCtxt -> Bool+allConstraintsAllowed = typeLevelUserTypeCtxt++-- | Returns 'True' if the supplied 'UserTypeCtxt' is unambiguously not the+-- context for a kind of a type, where all function arrows currently+-- must be unrestricted.+linearityAllowed :: UserTypeCtxt -> Bool+linearityAllowed = typeLevelUserTypeCtxt++-- | Returns 'True' if the supplied 'UserTypeCtxt' is unambiguously not the -- context for the type of a term, where visible, dependent quantification is -- currently disallowed. If the 'UserTypeCtxt' can refer to both types and -- kinds, this function conservatively returns 'True'.@@ -744,8 +755,12 @@ (theta, tau) = tcSplitPhiTy phi (env', tvbs') = tidyTyCoVarBinders env tvbs -check_type (ve@ValidityEnv{ve_rank = rank}) (FunTy _ _ arg_ty res_ty)- = do { check_type (ve{ve_rank = arg_rank}) arg_ty+check_type (ve@ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt+ , ve_rank = rank })+ ty@(FunTy _ mult arg_ty res_ty)+ = do { failIfTcM (not (linearityAllowed ctxt) && not (isManyDataConTy mult))+ (linearFunKindErr env ty)+ ; check_type (ve{ve_rank = arg_rank}) arg_ty ; check_type (ve{ve_rank = res_rank}) res_ty } where (arg_rank, res_rank) = funArgResRank rank@@ -992,6 +1007,11 @@ text "in the type of a term:") 2 (ppr_tidy env ty) , text "(GHC does not yet support this)" ] )++-- | Reject uses of linear function arrows in kinds.+linearFunKindErr :: TidyEnv -> Type -> (TidyEnv, SDoc)+linearFunKindErr env ty =+ (env, text "Illegal linear function in a kind:" <+> ppr_tidy env ty) {- Note [Liberal type synonyms]
compiler/GHC/ThToHs.hs view
@@ -1,3 +1,16 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -6,19 +19,6 @@ This module converts Template Haskell syntax into Hs syntax -} -{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE LambdaCase #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- module GHC.ThToHs ( convertToHsExpr , convertToPat@@ -42,8 +42,10 @@ import qualified GHC.Core.Coercion as Coercion ( Role(..) ) import GHC.Builtin.Types import GHC.Types.Basic as Hs+import GHC.Types.Fixity as Hs import GHC.Types.ForeignCall import GHC.Types.Unique+import GHC.Types.SourceText import GHC.Utils.Error import GHC.Data.Bag import GHC.Utils.Lexeme@@ -51,6 +53,7 @@ import GHC.Data.FastString import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic+import GHC.Parser.Annotation import qualified Data.ByteString as BS import Control.Monad( unless, ap )@@ -619,7 +622,7 @@ = do { c' <- mapM cNameL c ; args <- mapM cvt_arg strtys ; ty' <- cvtType ty- ; returnL $ mk_gadt_decl c' (PrefixCon $ map hsLinear args) ty'}+ ; returnL $ mk_gadt_decl c' (PrefixConGADT $ map hsLinear args) ty'} cvtConstr (RecGadtC [] _varstrtys _ty) = failWith (text "RecGadtC must have at least one constructor name")@@ -628,9 +631,9 @@ = do { c' <- mapM cNameL c ; ty' <- cvtType ty ; rec_flds <- mapM cvt_id_arg varstrtys- ; returnL $ mk_gadt_decl c' (RecCon $ noLoc rec_flds) ty' }+ ; returnL $ mk_gadt_decl c' (RecConGADT $ noLoc rec_flds) ty' } -mk_gadt_decl :: [Located RdrName] -> HsConDeclDetails GhcPs -> LHsType GhcPs+mk_gadt_decl :: [Located RdrName] -> HsConDeclGADTDetails GhcPs -> LHsType GhcPs -> ConDecl GhcPs mk_gadt_decl names args res_ty = ConDeclGADT { con_g_ext = noExtField@@ -638,7 +641,7 @@ , con_forall = noLoc False , con_qvars = [] , con_mb_cxt = Nothing- , con_args = args+ , con_g_args = args , con_res_ty = res_ty , con_doc = Nothing } @@ -761,7 +764,7 @@ ; let (inline', dflt,srcText) = case inline of Just inline1 -> (cvtInline inline1, dfltActivation inline1, src inline1)- Nothing -> (NoUserInline, AlwaysActive,+ Nothing -> (NoUserInlinePrag, AlwaysActive, "{-# SPECIALISE") ; let ip = InlinePragma { inl_src = SourceText srcText , inl_inline = inline'@@ -1016,7 +1019,7 @@ -- constructor names - see #14627. { s' <- vcName s ; return $ HsVar noExtField (noLoc s') }- cvt (LabelE s) = do { return $ HsOverLabel noExtField Nothing (fsLit s) }+ cvt (LabelE s) = return $ HsOverLabel noExtField Nothing (fsLit s) cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noExtField n' } {- | #16895 Ensure an infix expression's operator is a variable/constructor.@@ -1471,7 +1474,7 @@ _ -> return $ parenthesizeHsType sigPrec x' let y'' = parenthesizeHsType sigPrec y'- returnL (HsFunTy noExtField HsUnrestrictedArrow x'' y'')+ returnL (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x'' y'') | otherwise -> mk_apps (HsTyVar noExtField NotPromoted (noLoc (getRdrName unrestrictedFunTyCon)))@@ -1494,7 +1497,7 @@ tys' ListT | Just normals <- m_normals- , [x'] <- normals -> do+ , [x'] <- normals -> returnL (HsListTy noExtField x') | otherwise -> mk_apps@@ -1581,8 +1584,7 @@ -- in Language.Haskell.TH.Syntax | Just normals <- m_normals , [ty1, L _ (HsExplicitListTy _ ip tys2)] <- normals- -> do- returnL (HsExplicitListTy noExtField ip (ty1:tys2))+ -> returnL (HsExplicitListTy noExtField ip (ty1:tys2)) | otherwise -> mk_apps (HsTyVar noExtField IsPromoted (noLoc (getRdrName consDataCon)))@@ -1623,9 +1625,9 @@ 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+ | n == oneDataConName -> HsLinearArrow NormalSyntax+ | n == manyDataConName -> HsUnrestrictedArrow NormalSyntax+ _ -> HsExplicitMult NormalSyntax 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@@ -1689,7 +1691,7 @@ 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+See (among other closed issues) https://gitlab.haskell.org/ghc/ghc/issues/14289 -} -- ---------------------------------------------------------------------
compiler/GHC/Types/Name/Shape.hs view
@@ -15,19 +15,22 @@ import GHC.Prelude -import GHC.Utils.Outputable-import GHC.Driver.Types+import GHC.Driver.Env+ import GHC.Unit.Module+ import GHC.Types.Unique.FM import GHC.Types.Avail import GHC.Types.FieldLabel- import GHC.Types.Name import GHC.Types.Name.Env+ import GHC.Tc.Utils.Monad+import GHC.Iface.Env++import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic-import GHC.Iface.Env import Control.Monad
+ compiler/GHC/Types/TyThing/Ppr.hs view
@@ -0,0 +1,211 @@+-----------------------------------------------------------------------------+--+-- Pretty-printing TyThings+--+-- (c) The GHC Team 2005+--+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+module GHC.Types.TyThing.Ppr (+ pprTyThing,+ pprTyThingInContext,+ pprTyThingLoc,+ pprTyThingInContextLoc,+ pprTyThingHdr,+ pprTypeForUser,+ pprFamInst+ ) where++#include "GhclibHsVersions.h"++import GHC.Prelude++import GHC.Driver.Ppr (warnPprTrace)++import GHC.Types.TyThing ( TyThing(..), tyThingParent_maybe )+import GHC.Types.Name+import GHC.Types.Var.Env( emptyTidyEnv )++import GHC.Core.Type ( Type, ArgFlag(..), mkTyVarBinders, tidyOpenType )+import GHC.Core.Coercion.Axiom ( coAxiomTyCon )+import GHC.Core.FamInstEnv( FamInst(..), FamFlavor(..) )+import GHC.Core.TyCo.Ppr ( pprUserForAll, pprTypeApp, pprSigmaType )++import GHC.Iface.Syntax ( ShowSub(..), ShowHowMuch(..), AltPpr(..)+ , showToHeader, pprIfaceDecl )+import GHC.Iface.Make ( tyThingToIfaceDecl )++import GHC.Utils.Outputable++-- -----------------------------------------------------------------------------+-- Pretty-printing entities that we get from the GHC API++{- Note [Pretty printing via Iface syntax]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Our general plan for pretty-printing+ - Types+ - TyCons+ - Classes+ - Pattern synonyms+ ...etc...++is to convert them to Iface syntax, and pretty-print that. For example+ - pprType converts a Type to an IfaceType, and pretty prints that.+ - pprTyThing converts the TyThing to an IfaceDecl,+ and pretty prints that.++So Iface syntax plays a dual role:+ - it's the internal version of an interface files+ - it's used for pretty-printing++Why do this?++* A significant reason is that we need to be able+ to pretty-print Iface syntax (to display Foo.hi), and it was a+ pain to duplicate masses of pretty-printing goop, esp for+ Type and IfaceType.++* When pretty-printing (a type, say), we want to tidy (with+ tidyType) to avoids having (forall a a. blah) where the two+ a's have different uniques.++ Alas, for type constructors, TyCon, tidying does not work well,+ because a TyCon includes DataCons which include Types, which mention+ TyCons. And tidying can't tidy a mutually recursive data structure+ graph, only trees.++* Interface files contains fast-strings, not uniques, so the very same+ tidying must take place when we convert to IfaceDecl. E.g.+ GHC.Iface.Make.tyThingToIfaceDecl which converts a TyThing (i.e. TyCon,+ Class etc) to an IfaceDecl.++ Bottom line: IfaceDecls are already 'tidy', so it's straightforward+ to print them.++* An alternative I once explored was to ensure that TyCons get type+ variables with distinct print-names. That's ok for type variables+ but less easy for kind variables. Processing data type declarations+ is already so complicated that I don't think it's sensible to add+ the extra requirement that it generates only "pretty" types and+ kinds.++Consequences:++- Iface syntax (and IfaceType) must contain enough information to+ print nicely. Hence, for example, the IfaceAppArgs type, which+ allows us to suppress invisible kind arguments in types+ (see Note [Suppressing invisible arguments] in GHC.Iface.Type)++- In a few places we have info that is used only for pretty-printing,+ and is totally ignored when turning Iface syntax back into Core+ (in GHC.IfaceToCore). For example, IfaceClosedSynFamilyTyCon+ stores a [IfaceAxBranch] that is used only for pretty-printing.++- See Note [Free tyvars in IfaceType] in GHC.Iface.Type++See #7730, #8776 for details -}++--------------------+-- | Pretty-prints a 'FamInst' (type/data family instance) with its defining location.+pprFamInst :: FamInst -> SDoc+-- * For data instances we go via pprTyThing of the representational TyCon,+-- because there is already much cleverness associated with printing+-- data type declarations that I don't want to duplicate+-- * For type instances we print directly here; there is no TyCon+-- to give to pprTyThing+--+-- FamInstEnv.pprFamInst does a more quick-and-dirty job for internal purposes++pprFamInst (FamInst { fi_flavor = DataFamilyInst rep_tc })+ = pprTyThingInContextLoc (ATyCon rep_tc)++pprFamInst (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom+ , fi_tvs = tvs, fi_tys = lhs_tys, fi_rhs = rhs })+ = showWithLoc (pprDefinedAt (getName axiom)) $+ hang (text "type instance"+ <+> pprUserForAll (mkTyVarBinders Specified tvs)+ -- See Note [Printing foralls in type family instances]+ -- in GHC.Iface.Type+ <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys)+ 2 (equals <+> ppr rhs)++----------------------------+-- | Pretty-prints a 'TyThing' with its defining location.+pprTyThingLoc :: TyThing -> SDoc+pprTyThingLoc tyThing+ = showWithLoc (pprDefinedAt (getName tyThing))+ (pprTyThing showToHeader tyThing)++-- | Pretty-prints the 'TyThing' header. For functions and data constructors+-- the function is equivalent to 'pprTyThing' but for type constructors+-- and classes it prints only the header part of the declaration.+pprTyThingHdr :: TyThing -> SDoc+pprTyThingHdr = pprTyThing showToHeader++-- | Pretty-prints a 'TyThing' in context: that is, if the entity+-- is a data constructor, record selector, or class method, then+-- the entity's parent declaration is pretty-printed with irrelevant+-- parts omitted.+pprTyThingInContext :: ShowSub -> TyThing -> SDoc+pprTyThingInContext show_sub thing+ = go [] thing+ where+ go ss thing+ = case tyThingParent_maybe thing of+ Just parent ->+ go (getOccName thing : ss) parent+ Nothing ->+ pprTyThing+ (show_sub { ss_how_much = ShowSome ss (AltPpr Nothing) })+ thing++-- | Like 'pprTyThingInContext', but adds the defining location.+pprTyThingInContextLoc :: TyThing -> SDoc+pprTyThingInContextLoc tyThing+ = showWithLoc (pprDefinedAt (getName tyThing))+ (pprTyThingInContext showToHeader tyThing)++-- | Pretty-prints a 'TyThing'.+pprTyThing :: ShowSub -> TyThing -> SDoc+-- We pretty-print 'TyThing' via 'IfaceDecl'+-- See Note [Pretty-printing TyThings]+pprTyThing ss ty_thing+ = sdocOption sdocLinearTypes $ \show_linear_types ->+ pprIfaceDecl ss' (tyThingToIfaceDecl show_linear_types ty_thing)+ where+ ss' = case ss_how_much ss of+ ShowHeader (AltPpr Nothing) -> ss { ss_how_much = ShowHeader ppr' }+ ShowSome xs (AltPpr Nothing) -> ss { ss_how_much = ShowSome xs ppr' }+ _ -> ss++ ppr' = AltPpr $ ppr_bndr $ getName ty_thing++ ppr_bndr :: Name -> Maybe (OccName -> SDoc)+ ppr_bndr name+ | isBuiltInSyntax name+ = Nothing+ | otherwise+ = case nameModule_maybe name of+ Just mod -> Just $ \occ -> getPprStyle $ \sty ->+ pprModulePrefix sty mod occ <> ppr occ+ Nothing -> WARN( True, ppr name ) Nothing+ -- Nothing is unexpected here; TyThings have External names++pprTypeForUser :: Type -> SDoc+-- The type is tidied+pprTypeForUser ty+ = pprSigmaType tidy_ty+ where+ (_, tidy_ty) = tidyOpenType emptyTidyEnv ty+ -- Often the types/kinds we print in ghci are fully generalised+ -- and have no free variables, but it turns out that we sometimes+ -- print un-generalised kinds (eg when doing :k T), so it's+ -- better to use tidyOpenType here++showWithLoc :: SDoc -> SDoc -> SDoc+showWithLoc loc doc+ = hang doc 2 (char '\t' <> comment <+> loc)+ -- The tab tries to make them line up a bit+ where+ comment = text "--"
+ compiler/GHC/Unit/Finder.hs view
@@ -0,0 +1,855 @@+{-+(c) The University of Glasgow, 2000-2006++-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}++-- | Module finder+module GHC.Unit.Finder (+ FindResult(..),+ InstalledFindResult(..),+ FinderCache,+ flushFinderCaches,+ findImportedModule,+ findPluginModule,+ findExactModule,+ findHomeModule,+ findExposedPackageModule,+ mkHomeModLocation,+ mkHomeModLocation2,+ mkHiOnlyModLocation,+ mkHiPath,+ mkObjPath,+ addHomeModuleToFinder,+ uncacheModule,+ mkStubPaths,++ findObjectLinkableMaybe,+ findObjectLinkable,++ cannotFindModule,+ cannotFindInterface,++ ) where++#include "GhclibHsVersions.h"++import GHC.Prelude++import GHC.Driver.Env+import GHC.Driver.Session++import GHC.Platform.Ways++import GHC.Builtin.Names ( gHC_PRIM )++import GHC.Unit.Types+import GHC.Unit.Module+import GHC.Unit.Home+import GHC.Unit.State+import GHC.Unit.Finder.Types++import GHC.Data.FastString+import GHC.Data.Maybe ( expectJust )+import qualified GHC.Data.ShortText as ST++import GHC.Utils.Misc+import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic++import GHC.Runtime.Linker.Types++import Data.IORef ( IORef, readIORef, atomicModifyIORef' )+import System.Directory+import System.FilePath+import Control.Monad+import Data.Time+++type FileExt = String -- Filename extension+type BaseName = String -- Basename of file++-- -----------------------------------------------------------------------------+-- The Finder++-- The Finder provides a thin filesystem abstraction to the rest of+-- the compiler. For a given module, it can tell you where the+-- source, interface, and object files for that module live.++-- It does *not* know which particular package a module lives in. Use+-- Packages.lookupModuleInAllUnits for that.++-- -----------------------------------------------------------------------------+-- The finder's cache++-- remove all the home modules from the cache; package modules are+-- assumed to not move around during a session.+flushFinderCaches :: HscEnv -> IO ()+flushFinderCaches hsc_env =+ atomicModifyIORef' fc_ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ())+ where+ fc_ref = hsc_FC hsc_env+ home_unit = hsc_home_unit hsc_env+ is_ext mod _ = not (isHomeInstalledModule home_unit mod)++addToFinderCache :: IORef FinderCache -> InstalledModule -> InstalledFindResult -> IO ()+addToFinderCache ref key val =+ atomicModifyIORef' ref $ \c -> (extendInstalledModuleEnv c key val, ())++removeFromFinderCache :: IORef FinderCache -> InstalledModule -> IO ()+removeFromFinderCache ref key =+ atomicModifyIORef' ref $ \c -> (delInstalledModuleEnv c key, ())++lookupFinderCache :: IORef FinderCache -> InstalledModule -> IO (Maybe InstalledFindResult)+lookupFinderCache ref key = do+ c <- readIORef ref+ return $! lookupInstalledModuleEnv c key++-- -----------------------------------------------------------------------------+-- The three external entry points++-- | Locate a module that was imported by the user. We have the+-- module's name, and possibly a package name. Without a package+-- name, this function will use the search path and the known exposed+-- packages to find the module, if a package is specified then only+-- that package is searched for the module.++findImportedModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult+findImportedModule hsc_env mod_name mb_pkg =+ case mb_pkg of+ Nothing -> unqual_import+ Just pkg | pkg == fsLit "this" -> home_import -- "this" is special+ | otherwise -> pkg_import+ where+ home_import = findHomeModule hsc_env mod_name++ pkg_import = findExposedPackageModule hsc_env mod_name mb_pkg++ unqual_import = home_import+ `orIfNotFound`+ findExposedPackageModule hsc_env mod_name Nothing++-- | Locate a plugin module requested by the user, for a compiler+-- plugin. This consults the same set of exposed packages as+-- 'findImportedModule', unless @-hide-all-plugin-packages@ or+-- @-plugin-package@ are specified.+findPluginModule :: HscEnv -> ModuleName -> IO FindResult+findPluginModule hsc_env mod_name =+ findHomeModule hsc_env mod_name+ `orIfNotFound`+ findExposedPluginPackageModule hsc_env mod_name++-- | Locate a specific 'Module'. The purpose of this function is to+-- create a 'ModLocation' for a given 'Module', that is to find out+-- where the files associated with this module live. It is used when+-- reading the interface for a module mentioned by another interface,+-- for example (a "system import").++findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult+findExactModule hsc_env mod =+ let home_unit = hsc_home_unit hsc_env+ in if isHomeInstalledModule home_unit mod+ then findInstalledHomeModule hsc_env (moduleName mod)+ else findPackageModule hsc_env mod++-- -----------------------------------------------------------------------------+-- Helpers++-- | Given a monadic actions @this@ and @or_this@, first execute+-- @this@. If the returned 'FindResult' is successful, return+-- it; otherwise, execute @or_this@. If both failed, this function+-- also combines their failure messages in a reasonable way.+orIfNotFound :: Monad m => m FindResult -> m FindResult -> m FindResult+orIfNotFound this or_this = do+ res <- this+ case res of+ NotFound { fr_paths = paths1, fr_mods_hidden = mh1+ , fr_pkgs_hidden = ph1, fr_unusables = u1, fr_suggestions = s1 }+ -> do res2 <- or_this+ case res2 of+ NotFound { fr_paths = paths2, fr_pkg = mb_pkg2, fr_mods_hidden = mh2+ , fr_pkgs_hidden = ph2, fr_unusables = u2+ , fr_suggestions = s2 }+ -> return (NotFound { fr_paths = paths1 ++ paths2+ , fr_pkg = mb_pkg2 -- snd arg is the package search+ , fr_mods_hidden = mh1 ++ mh2+ , fr_pkgs_hidden = ph1 ++ ph2+ , fr_unusables = u1 ++ u2+ , fr_suggestions = s1 ++ s2 })+ _other -> return res2+ _other -> return res++-- | Helper function for 'findHomeModule': this function wraps an IO action+-- which would look up @mod_name@ in the file system (the home package),+-- and first consults the 'hsc_FC' cache to see if the lookup has already+-- been done. Otherwise, do the lookup (with the IO action) and save+-- the result in the finder cache and the module location cache (if it+-- was successful.)+homeSearchCache :: HscEnv -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult+homeSearchCache hsc_env mod_name do_this = do+ let home_unit = hsc_home_unit hsc_env+ mod = mkHomeInstalledModule home_unit mod_name+ modLocationCache hsc_env mod do_this++findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString+ -> IO FindResult+findExposedPackageModule hsc_env mod_name mb_pkg+ = findLookupResult hsc_env+ $ lookupModuleWithSuggestions+ (unitState (hsc_dflags hsc_env)) mod_name mb_pkg++findExposedPluginPackageModule :: HscEnv -> ModuleName+ -> IO FindResult+findExposedPluginPackageModule hsc_env mod_name+ = findLookupResult hsc_env+ $ lookupPluginModuleWithSuggestions+ (unitState (hsc_dflags hsc_env)) mod_name Nothing++findLookupResult :: HscEnv -> LookupResult -> IO FindResult+findLookupResult hsc_env r = case r of+ LookupFound m pkg_conf -> do+ let im = fst (getModuleInstantiation m)+ r' <- findPackageModule_ hsc_env im pkg_conf+ case r' of+ -- TODO: ghc -M is unlikely to do the right thing+ -- with just the location of the thing that was+ -- instantiated; you probably also need all of the+ -- implicit locations from the instances+ InstalledFound loc _ -> return (Found loc m)+ InstalledNoPackage _ -> return (NoPackage (moduleUnit m))+ InstalledNotFound fp _ -> return (NotFound{ fr_paths = fp, fr_pkg = Just (moduleUnit m)+ , fr_pkgs_hidden = []+ , fr_mods_hidden = []+ , fr_unusables = []+ , fr_suggestions = []})+ LookupMultiple rs ->+ return (FoundMultiple rs)+ LookupHidden pkg_hiddens mod_hiddens ->+ return (NotFound{ fr_paths = [], fr_pkg = Nothing+ , fr_pkgs_hidden = map (moduleUnit.fst) pkg_hiddens+ , fr_mods_hidden = map (moduleUnit.fst) mod_hiddens+ , fr_unusables = []+ , fr_suggestions = [] })+ LookupUnusable unusable ->+ let unusables' = map get_unusable unusable+ get_unusable (m, ModUnusable r) = (moduleUnit m, r)+ get_unusable (_, r) =+ pprPanic "findLookupResult: unexpected origin" (ppr r)+ in return (NotFound{ fr_paths = [], fr_pkg = Nothing+ , fr_pkgs_hidden = []+ , fr_mods_hidden = []+ , fr_unusables = unusables'+ , fr_suggestions = [] })+ 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' })++modLocationCache :: HscEnv -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult+modLocationCache hsc_env mod do_this = do+ m <- lookupFinderCache (hsc_FC hsc_env) mod+ case m of+ Just result -> return result+ Nothing -> do+ result <- do_this+ addToFinderCache (hsc_FC hsc_env) mod result+ return result++-- This returns a module because it's more convenient for users+addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module+addHomeModuleToFinder hsc_env mod_name loc = do+ let home_unit = hsc_home_unit hsc_env+ mod = mkHomeInstalledModule home_unit mod_name+ addToFinderCache (hsc_FC hsc_env) mod (InstalledFound loc mod)+ return (mkHomeModule home_unit mod_name)++uncacheModule :: HscEnv -> ModuleName -> IO ()+uncacheModule hsc_env mod_name = do+ let home_unit = hsc_home_unit hsc_env+ mod = mkHomeInstalledModule home_unit mod_name+ removeFromFinderCache (hsc_FC hsc_env) mod++-- -----------------------------------------------------------------------------+-- The internal workers++findHomeModule :: HscEnv -> ModuleName -> IO FindResult+findHomeModule hsc_env mod_name = do+ r <- findInstalledHomeModule hsc_env mod_name+ return $ case r of+ InstalledFound loc _ -> Found loc (mkHomeModule home_unit mod_name)+ InstalledNoPackage _ -> NoPackage uid -- impossible+ InstalledNotFound fps _ -> NotFound {+ fr_paths = fps,+ fr_pkg = Just uid,+ fr_mods_hidden = [],+ fr_pkgs_hidden = [],+ fr_unusables = [],+ fr_suggestions = []+ }+ where+ home_unit = hsc_home_unit hsc_env+ uid = homeUnitAsUnit home_unit++-- | 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+-- as a building block for the following operations:+--+-- 1. When you do a normal package lookup, we first check if the module+-- is available in the home module, before looking it up in the package+-- database.+--+-- 2. When you have a package qualified import with package name "this",+-- we shortcut to the home module.+--+-- 3. When we look up an exact 'Module', if the unit id associated with+-- the module is the current home module do a look up in the home module.+--+-- 4. Some special-case code in GHCi (ToDo: Figure out why that needs to+-- call this.)+findInstalledHomeModule :: HscEnv -> ModuleName -> IO InstalledFindResult+findInstalledHomeModule hsc_env mod_name =+ homeSearchCache hsc_env mod_name $+ let+ dflags = hsc_dflags hsc_env+ home_unit = hsc_home_unit hsc_env+ home_path = importPaths dflags+ hisuf = hiSuf dflags+ mod = mkHomeInstalledModule home_unit mod_name++ source_exts =+ [ ("hs", mkHomeModLocationSearched dflags mod_name "hs")+ , ("lhs", mkHomeModLocationSearched dflags mod_name "lhs")+ , ("hsig", mkHomeModLocationSearched dflags mod_name "hsig")+ , ("lhsig", mkHomeModLocationSearched dflags mod_name "lhsig")+ ]++ -- we use mkHomeModHiOnlyLocation instead of mkHiOnlyModLocation so that+ -- when hiDir field is set in dflags, we know to look there (see #16500)+ hi_exts = [ (hisuf, mkHomeModHiOnlyLocation dflags mod_name)+ , (addBootSuffix hisuf, mkHomeModHiOnlyLocation dflags mod_name)+ ]++ -- In compilation manager modes, we look for source files in the home+ -- package because we can compile these automatically. In one-shot+ -- compilation mode we look for .hi and .hi-boot files only.+ exts | isOneShot (ghcMode dflags) = hi_exts+ | otherwise = source_exts+ in++ -- special case for GHC.Prim; we won't find it in the filesystem.+ -- This is important only when compiling the base package (where GHC.Prim+ -- is a home module).+ if mod `installedModuleEq` gHC_PRIM+ then return (InstalledFound (error "GHC.Prim ModLocation") mod)+ else searchPathExts home_path mod exts+++-- | Search for a module in external packages only.+findPackageModule :: HscEnv -> InstalledModule -> IO InstalledFindResult+findPackageModule hsc_env mod = do+ let+ dflags = hsc_dflags hsc_env+ pkg_id = moduleUnit mod+ pkgstate = unitState dflags+ --+ 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 "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.+findPackageModule_ :: HscEnv -> InstalledModule -> UnitInfo -> IO InstalledFindResult+findPackageModule_ hsc_env mod pkg_conf =+ ASSERT2( moduleUnit mod == unitId pkg_conf, ppr (moduleUnit mod) <+> ppr (unitId pkg_conf) )+ modLocationCache hsc_env mod $++ -- special case for GHC.Prim; we won't find it in the filesystem.+ if mod `installedModuleEq` gHC_PRIM+ then return (InstalledFound (error "GHC.Prim ModLocation") mod)+ else++ let+ dflags = hsc_dflags hsc_env+ tag = waysBuildTag (ways dflags)++ -- hi-suffix for packages depends on the build tag.+ package_hisuf | null tag = "hi"+ | otherwise = tag ++ "_hi"++ mk_hi_loc = mkHiOnlyModLocation dflags package_hisuf++ import_dirs = map ST.unpack $ unitImportDirs pkg_conf+ -- we never look for a .hi-boot file in an external package;+ -- .hi-boot files only make sense for the home package.+ in+ case import_dirs of+ [one] | MkDepend <- ghcMode dflags -> do+ -- there's only one place that this .hi file can be, so+ -- don't bother looking for it.+ let basename = moduleNameSlashes (moduleName mod)+ loc <- mk_hi_loc one basename+ return (InstalledFound loc mod)+ _otherwise ->+ searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)]++-- -----------------------------------------------------------------------------+-- General path searching++searchPathExts :: [FilePath] -- paths to search+ -> InstalledModule -- module name+ -> [ (+ FileExt, -- suffix+ FilePath -> BaseName -> IO ModLocation -- action+ )+ ]+ -> IO InstalledFindResult++searchPathExts paths mod exts = search to_search+ where+ basename = moduleNameSlashes (moduleName mod)++ to_search :: [(FilePath, IO ModLocation)]+ to_search = [ (file, fn path basename)+ | path <- paths,+ (ext,fn) <- exts,+ let base | path == "." = basename+ | otherwise = path </> basename+ file = base <.> ext+ ]++ search [] = return (InstalledNotFound (map fst to_search) (Just (moduleUnit mod)))++ search ((file, mk_result) : rest) = do+ b <- doesFileExist file+ if b+ then do { loc <- mk_result; return (InstalledFound loc mod) }+ else search rest++mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt+ -> FilePath -> BaseName -> IO ModLocation+mkHomeModLocationSearched dflags mod suff path basename =+ mkHomeModLocation2 dflags mod (path </> basename) suff++-- -----------------------------------------------------------------------------+-- Constructing a home module location++-- This is where we construct the ModLocation for a module in the home+-- package, for which we have a source file. It is called from three+-- places:+--+-- (a) Here in the finder, when we are searching for a module to import,+-- using the search path (-i option).+--+-- (b) The compilation manager, when constructing the ModLocation for+-- a "root" module (a source file named explicitly on the command line+-- or in a :load command in GHCi).+--+-- (c) The driver in one-shot mode, when we need to construct a+-- ModLocation for a source file named on the command-line.+--+-- Parameters are:+--+-- mod+-- The name of the module+--+-- path+-- (a): The search path component where the source file was found.+-- (b) and (c): "."+--+-- src_basename+-- (a): (moduleNameSlashes mod)+-- (b) and (c): The filename of the source file, minus its extension+--+-- ext+-- The filename extension of the source file (usually "hs" or "lhs").++mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO ModLocation+mkHomeModLocation dflags mod src_filename = do+ let (basename,extension) = splitExtension src_filename+ mkHomeModLocation2 dflags mod basename extension++mkHomeModLocation2 :: DynFlags+ -> ModuleName+ -> FilePath -- Of source module, without suffix+ -> String -- Suffix+ -> IO ModLocation+mkHomeModLocation2 dflags mod src_basename ext = do+ let mod_basename = moduleNameSlashes mod++ obj_fn = mkObjPath dflags src_basename mod_basename+ hi_fn = mkHiPath dflags src_basename mod_basename+ hie_fn = mkHiePath dflags src_basename mod_basename++ return (ModLocation{ ml_hs_file = Just (src_basename <.> ext),+ ml_hi_file = hi_fn,+ ml_obj_file = obj_fn,+ ml_hie_file = hie_fn })++mkHomeModHiOnlyLocation :: DynFlags+ -> ModuleName+ -> FilePath+ -> BaseName+ -> IO ModLocation+mkHomeModHiOnlyLocation dflags mod path basename = do+ loc <- mkHomeModLocation2 dflags mod (path </> basename) ""+ return loc { ml_hs_file = Nothing }++mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String+ -> IO ModLocation+mkHiOnlyModLocation dflags hisuf path basename+ = do let full_basename = path </> basename+ obj_fn = mkObjPath dflags full_basename basename+ hie_fn = mkHiePath dflags full_basename basename+ return ModLocation{ ml_hs_file = Nothing,+ ml_hi_file = full_basename <.> hisuf,+ -- Remove the .hi-boot suffix from+ -- hi_file, if it had one. We always+ -- want the name of the real .hi file+ -- in the ml_hi_file field.+ ml_obj_file = obj_fn,+ ml_hie_file = hie_fn+ }++-- | Constructs the filename of a .o file for a given source file.+-- Does /not/ check whether the .o file exists+mkObjPath+ :: DynFlags+ -> FilePath -- the filename of the source file, minus the extension+ -> String -- the module name with dots replaced by slashes+ -> FilePath+mkObjPath dflags basename mod_basename = obj_basename <.> osuf+ where+ odir = objectDir dflags+ osuf = objectSuf dflags++ obj_basename | Just dir <- odir = dir </> mod_basename+ | otherwise = basename+++-- | Constructs the filename of a .hi file for a given source file.+-- Does /not/ check whether the .hi file exists+mkHiPath+ :: DynFlags+ -> FilePath -- the filename of the source file, minus the extension+ -> String -- the module name with dots replaced by slashes+ -> FilePath+mkHiPath dflags basename mod_basename = hi_basename <.> hisuf+ where+ hidir = hiDir dflags+ hisuf = hiSuf dflags++ hi_basename | Just dir <- hidir = dir </> mod_basename+ | otherwise = basename++-- | Constructs the filename of a .hie file for a given source file.+-- Does /not/ check whether the .hie file exists+mkHiePath+ :: DynFlags+ -> FilePath -- the filename of the source file, minus the extension+ -> String -- the module name with dots replaced by slashes+ -> FilePath+mkHiePath dflags basename mod_basename = hie_basename <.> hiesuf+ where+ hiedir = hieDir dflags+ hiesuf = hieSuf dflags++ hie_basename | Just dir <- hiedir = dir </> mod_basename+ | otherwise = basename++++-- -----------------------------------------------------------------------------+-- Filenames of the stub files++-- We don't have to store these in ModLocations, because they can be derived+-- from other available information, and they're only rarely needed.++mkStubPaths+ :: DynFlags+ -> ModuleName+ -> ModLocation+ -> FilePath++mkStubPaths dflags mod location+ = let+ stubdir = stubDir dflags++ mod_basename = moduleNameSlashes mod+ src_basename = dropExtension $ expectJust "mkStubPaths"+ (ml_hs_file location)++ stub_basename0+ | Just dir <- stubdir = dir </> mod_basename+ | otherwise = src_basename++ stub_basename = stub_basename0 ++ "_stub"+ in+ stub_basename <.> "h"++-- -----------------------------------------------------------------------------+-- findLinkable isn't related to the other stuff in here,+-- but there's no other obvious place for it++findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable)+findObjectLinkableMaybe mod locn+ = do let obj_fn = ml_obj_file locn+ maybe_obj_time <- modificationTimeIfExists obj_fn+ case maybe_obj_time of+ Nothing -> return Nothing+ Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time)++-- Make an object linkable when we know the object file exists, and we know+-- its modification time.+findObjectLinkable :: Module -> FilePath -> UTCTime -> IO Linkable+findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn])+ -- We used to look for _stub.o files here, but that was a bug (#706)+ -- Now GHC merges the stub.o into the main .o (#3687)++-- -----------------------------------------------------------------------------+-- Error messages++cannotFindModule :: DynFlags -> ModuleName -> FindResult -> SDoc+cannotFindModule dflags mod res = pprWithUnitState unit_state $+ cantFindErr (sLit cannotFindMsg)+ (sLit "Ambiguous module name")+ dflags mod res+ where+ unit_state = unitState dflags+ cannotFindMsg =+ case res of+ NotFound { fr_mods_hidden = hidden_mods+ , fr_pkgs_hidden = hidden_pkgs+ , fr_unusables = unusables }+ | not (null hidden_mods && null hidden_pkgs && null unusables)+ -> "Could not load module"+ _ -> "Could not find module"++cannotFindInterface :: DynFlags -> ModuleName -> InstalledFindResult -> SDoc+cannotFindInterface = cantFindInstalledErr (sLit "Failed to load interface for")+ (sLit "Ambiguous interface for")++cantFindErr :: PtrString -> PtrString -> DynFlags -> ModuleName -> FindResult+ -> SDoc+cantFindErr _ multiple_found _ mod_name (FoundMultiple mods)+ | Just pkgs <- unambiguousPackages+ = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 (+ sep [text "it was found in multiple packages:",+ hsep (map ppr pkgs) ]+ )+ | otherwise+ = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 (+ vcat (map pprMod mods)+ )+ where+ unambiguousPackages = foldl' unambiguousPackage (Just []) mods+ unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _)+ = Just (moduleUnit m : xs)+ unambiguousPackage _ _ = Nothing++ pprMod (m, o) = text "it is bound as" <+> ppr m <+>+ text "by" <+> pprOrigin m o+ pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden"+ pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable"+ pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma (+ if e == Just True+ then [text "package" <+> ppr (moduleUnit m)]+ else [] +++ map ((text "a reexport in package" <+>)+ .ppr.mkUnit) res +++ if f then [text "a package flag"] else []+ )++cantFindErr cannot_find _ dflags mod_name find_result+ = ptext cannot_find <+> quotes (ppr mod_name)+ $$ more_info+ where+ pkgs = unitState dflags+ home_unit = mkHomeUnitFromFlags dflags+ more_info+ = case find_result of+ NoPackage pkg+ -> text "no unit id matching" <+> quotes (ppr pkg) <+>+ text "was found"++ 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, not (isHomeUnit home_unit pkg)+ -> not_found_in_package pkg files++ | not (null suggest)+ -> pp_suggestions suggest $$ tried_these files dflags++ | null files && null mod_hiddens &&+ null pkg_hiddens && null unusables+ -> text "It is not a module in the current program, or in any known package."++ | otherwise+ -> vcat (map pkg_hidden pkg_hiddens) $$+ vcat (map mod_hidden mod_hiddens) $$+ vcat (map unusable unusables) $$+ tried_these files dflags++ _ -> panic "cantFindErr"++ build_tag = waysBuildTag (ways dflags)++ not_found_in_package pkg files+ | build_tag /= ""+ = let+ build = if build_tag == "p" then "profiling"+ else "\"" ++ build_tag ++ "\""+ in+ text "Perhaps you haven't installed the " <> text build <>+ text " libraries for package " <> quotes (ppr pkg) <> char '?' $$+ tried_these files dflags++ | otherwise+ = text "There are files missing in the " <> quotes (ppr pkg) <>+ text " package," $$+ text "try running 'ghc-pkg check'." $$+ tried_these files dflags++ pkg_hidden :: Unit -> SDoc+ pkg_hidden uid =+ text "It is a member of the hidden package"+ <+> quotes (ppr uid)+ --FIXME: we don't really want to show the unit id here we should+ -- show the source package id or installed package id if it's ambiguous+ <> dot $$ pkg_hidden_hint uid+ pkg_hidden_hint uid+ | gopt Opt_BuildingCabalPackage dflags+ = 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 pkgs uid+ = text "You can run" <+>+ quotes (text ":set -package " <> ppr (unitPackageName pkg)) <+>+ text "to expose it." $$+ text "(Note: this unloads all the modules in the current scope.)"+ | otherwise = Outputable.empty++ mod_hidden pkg =+ text "it is a hidden module in the package" <+> quotes (ppr pkg)++ unusable (pkg, reason)+ = text "It is a member of the package"+ <+> quotes (ppr pkg)+ $$ pprReason (text "which is") reason++ pp_suggestions :: [ModuleSuggestion] -> SDoc+ pp_suggestions sugs+ | null sugs = Outputable.empty+ | otherwise = hang (text "Perhaps you meant")+ 2 (vcat (map pp_sugg sugs))++ -- NB: Prefer the *original* location, and then reexports, and then+ -- package flags when making suggestions. ToDo: if the original package+ -- also has a reexport, prefer that one+ pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o+ where provenance ModHidden = Outputable.empty+ provenance (ModUnusable _) = Outputable.empty+ provenance (ModOrigin{ fromOrigUnit = e,+ fromExposedReexport = res,+ fromPackageFlag = f })+ | Just True <- e+ = parens (text "from" <+> ppr (moduleUnit mod))+ | f && moduleName mod == m+ = parens (text "from" <+> ppr (moduleUnit mod))+ | (pkg:_) <- res+ = parens (text "from" <+> ppr (mkUnit pkg)+ <> comma <+> text "reexporting" <+> ppr mod)+ | f+ = parens (text "defined via package flags to be"+ <+> ppr mod)+ | otherwise = Outputable.empty+ pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o+ where provenance ModHidden = Outputable.empty+ provenance (ModUnusable _) = Outputable.empty+ provenance (ModOrigin{ fromOrigUnit = e,+ fromHiddenReexport = rhs })+ | Just False <- e+ = parens (text "needs flag -package-id"+ <+> ppr (moduleUnit mod))+ | (pkg:_) <- rhs+ = parens (text "needs flag -package-id"+ <+> ppr (mkUnit pkg))+ | otherwise = Outputable.empty++cantFindInstalledErr :: PtrString -> PtrString -> DynFlags -> ModuleName+ -> InstalledFindResult -> SDoc+cantFindInstalledErr cannot_find _ dflags mod_name find_result+ = ptext cannot_find <+> quotes (ppr mod_name)+ $$ more_info+ where+ home_unit = mkHomeUnitFromFlags dflags+ unit_state = unitState dflags+ build_tag = waysBuildTag (ways dflags)++ more_info+ = case find_result of+ InstalledNoPackage pkg+ -> text "no unit id matching" <+> quotes (ppr pkg) <+>+ text "was found" $$ looks_like_srcpkgid pkg++ InstalledNotFound files mb_pkg+ | Just pkg <- mb_pkg, not (isHomeUnitId home_unit pkg)+ -> not_found_in_package pkg files++ | null files+ -> text "It is not a module in the current program, or in any known package."++ | otherwise+ -> tried_these files dflags++ _ -> panic "cantFindInstalledErr"++ looks_like_srcpkgid :: UnitId -> SDoc+ looks_like_srcpkgid pk+ -- Unsafely coerce a unit id (i.e. an installed package component+ -- identifier) into a PackageId and see if it means anything.+ | (pkg:pkgs) <- searchPackageId unit_state (PackageId (unitIdFS pk))+ = parens (text "This unit ID looks like the source package ID;" $$+ text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$+ (if null pkgs then Outputable.empty+ else text "and" <+> int (length pkgs) <+> text "other candidates"))+ -- Todo: also check if it looks like a package name!+ | otherwise = Outputable.empty++ not_found_in_package pkg files+ | build_tag /= ""+ = let+ build = if build_tag == "p" then "profiling"+ else "\"" ++ build_tag ++ "\""+ in+ text "Perhaps you haven't installed the " <> text build <>+ text " libraries for package " <> quotes (ppr pkg) <> char '?' $$+ tried_these files dflags++ | otherwise+ = text "There are files missing in the " <> quotes (ppr pkg) <>+ text " package," $$+ text "try running 'ghc-pkg check'." $$+ tried_these files dflags++tried_these :: [FilePath] -> DynFlags -> SDoc+tried_these files dflags+ | null files = Outputable.empty+ | verbosity dflags < 3 =+ text "Use -v (or `:set -v` in ghci) " <>+ text "to see a list of the files searched for."+ | otherwise =+ hang (text "Locations searched:") 2 $ vcat (map text files)
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-version: 0.20201001+version: 0.20201101 license: BSD3 license-file: LICENSE category: Development@@ -79,7 +79,7 @@ process >= 1 && < 1.7, hpc == 0.6.*, exceptions == 0.10.*,- ghc-lib-parser == 0.20201001+ ghc-lib-parser == 0.20201101 build-tools: alex >= 3.1, happy >= 1.19.4 other-extensions: BangPatterns@@ -125,7 +125,6 @@ libraries/template-haskell libraries/ghc-boot libraries/ghci- compiler/. compiler autogen-modules: Paths_ghc_lib@@ -182,6 +181,8 @@ GHC.Core.TyCo.Subst, GHC.Core.TyCo.Tidy, GHC.Core.TyCon,+ GHC.Core.TyCon.Env,+ GHC.Core.TyCon.RecWalk, GHC.Core.Type, GHC.Core.Unfold, GHC.Core.Unfold.Make,@@ -202,6 +203,7 @@ GHC.Data.Maybe, GHC.Data.OrdList, GHC.Data.Pair,+ GHC.Data.ShortText, GHC.Data.Stream, GHC.Data.StringBuffer, GHC.Data.TrieMap,@@ -209,6 +211,7 @@ GHC.Driver.Backpack.Syntax, GHC.Driver.CmdLine, GHC.Driver.Config,+ GHC.Driver.Env, GHC.Driver.Flags, GHC.Driver.Hooks, GHC.Driver.Monad,@@ -217,7 +220,6 @@ GHC.Driver.Plugins, GHC.Driver.Ppr, GHC.Driver.Session,- GHC.Driver.Types, GHC.Exts.Heap, GHC.Exts.Heap.ClosureTypes, GHC.Exts.Heap.Closures,@@ -241,6 +243,7 @@ GHC.Hs.Pat, GHC.Hs.Type, GHC.Hs.Utils,+ GHC.Iface.Ext.Fields, GHC.Iface.Recomp.Binary, GHC.Iface.Syntax, GHC.Iface.Type,@@ -250,10 +253,13 @@ GHC.Parser, GHC.Parser.Annotation, GHC.Parser.CharClass,+ GHC.Parser.Errors,+ GHC.Parser.Errors.Ppr, GHC.Parser.Header, GHC.Parser.Lexer, GHC.Parser.PostProcess, GHC.Parser.PostProcess.Haddock,+ GHC.Parser.Types, GHC.Platform, GHC.Platform.ARM, GHC.Platform.ARM64,@@ -271,6 +277,7 @@ GHC.Platform.X86, GHC.Platform.X86_64, GHC.Prelude,+ GHC.Runtime.Context, GHC.Runtime.Eval.Types, GHC.Runtime.Heap.Layout, GHC.Runtime.Interpreter.Types,@@ -293,24 +300,39 @@ GHC.Types.Annotations, GHC.Types.Avail, GHC.Types.Basic,+ GHC.Types.CompleteMatch, GHC.Types.CostCentre, GHC.Types.CostCentre.State, GHC.Types.Cpr, GHC.Types.Demand,+ GHC.Types.Error, GHC.Types.FieldLabel,+ GHC.Types.Fixity,+ GHC.Types.Fixity.Env, GHC.Types.ForeignCall,+ GHC.Types.ForeignStubs,+ GHC.Types.HpcInfo, GHC.Types.Id, GHC.Types.Id.Info, GHC.Types.Id.Make, GHC.Types.Literal,+ GHC.Types.Meta, GHC.Types.Name, GHC.Types.Name.Cache, GHC.Types.Name.Env, GHC.Types.Name.Occurrence,+ GHC.Types.Name.Ppr, GHC.Types.Name.Reader, GHC.Types.Name.Set, GHC.Types.RepType,+ GHC.Types.SafeHaskell,+ GHC.Types.SourceError,+ GHC.Types.SourceFile,+ GHC.Types.SourceText, GHC.Types.SrcLoc,+ GHC.Types.Target,+ GHC.Types.TyThing,+ GHC.Types.TypeEnv, GHC.Types.Unique, GHC.Types.Unique.DFM, GHC.Types.Unique.DSet,@@ -323,17 +345,30 @@ GHC.UniqueSubdir, GHC.Unit, GHC.Unit.Database,+ GHC.Unit.External,+ GHC.Unit.Finder.Types, GHC.Unit.Home,+ GHC.Unit.Home.ModInfo, GHC.Unit.Info, GHC.Unit.Module,+ GHC.Unit.Module.Deps, GHC.Unit.Module.Env,+ GHC.Unit.Module.Graph,+ GHC.Unit.Module.Imported, GHC.Unit.Module.Location,+ GHC.Unit.Module.ModDetails,+ GHC.Unit.Module.ModGuts,+ GHC.Unit.Module.ModIface,+ GHC.Unit.Module.ModSummary, GHC.Unit.Module.Name,+ GHC.Unit.Module.Status,+ GHC.Unit.Module.Warnings, GHC.Unit.Parser, GHC.Unit.Ppr, GHC.Unit.State, GHC.Unit.Types, GHC.Utils.Binary,+ GHC.Utils.Binary.Typeable, GHC.Utils.BufHandle, GHC.Utils.CliOption, GHC.Utils.Encoding,@@ -390,9 +425,9 @@ GHC.Cmm.Lexer GHC.Cmm.Lint GHC.Cmm.Liveness- GHC.Cmm.Monad GHC.Cmm.Opt GHC.Cmm.Parser+ GHC.Cmm.Parser.Monad GHC.Cmm.Pipeline GHC.Cmm.Ppr GHC.Cmm.Ppr.Decl@@ -498,9 +533,9 @@ GHC.Core.Opt.StaticArgs GHC.Core.Opt.WorkWrap GHC.Core.Opt.WorkWrap.Utils- GHC.Core.Ppr.TyThing GHC.Core.Rules GHC.Core.Tidy+ GHC.Core.TyCon.Set GHC.CoreToByteCode GHC.CoreToStg GHC.CoreToStg.Prep@@ -512,7 +547,6 @@ GHC.Data.Graph.UnVar GHC.Driver.Backpack GHC.Driver.CodeOutput- GHC.Driver.Finder GHC.Driver.Main GHC.Driver.Make GHC.Driver.MakeFile@@ -569,7 +603,6 @@ GHC.Platform.Host GHC.Plugins GHC.Rename.Bind- GHC.Rename.Doc GHC.Rename.Env GHC.Rename.Expr GHC.Rename.Fixity@@ -675,7 +708,9 @@ GHC.Tc.Validity GHC.ThToHs GHC.Types.Name.Shape+ GHC.Types.TyThing.Ppr GHC.Types.Unique.SDFM+ GHC.Unit.Finder GHC.Utils.Asm GHC.Utils.Monad.State GHCi.BinaryArray
ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl view
@@ -63,6 +63,8 @@ primOpCanFail IndexByteArrayOp_Word64 = True primOpCanFail IndexByteArrayOp_Word8AsChar = True primOpCanFail IndexByteArrayOp_Word8AsWideChar = True+primOpCanFail IndexByteArrayOp_Word8AsInt = True+primOpCanFail IndexByteArrayOp_Word8AsWord = True primOpCanFail IndexByteArrayOp_Word8AsAddr = True primOpCanFail IndexByteArrayOp_Word8AsFloat = True primOpCanFail IndexByteArrayOp_Word8AsDouble = True@@ -70,11 +72,9 @@ primOpCanFail IndexByteArrayOp_Word8AsInt16 = True primOpCanFail IndexByteArrayOp_Word8AsInt32 = True primOpCanFail IndexByteArrayOp_Word8AsInt64 = True-primOpCanFail IndexByteArrayOp_Word8AsInt = True primOpCanFail IndexByteArrayOp_Word8AsWord16 = True primOpCanFail IndexByteArrayOp_Word8AsWord32 = True primOpCanFail IndexByteArrayOp_Word8AsWord64 = True-primOpCanFail IndexByteArrayOp_Word8AsWord = True primOpCanFail ReadByteArrayOp_Char = True primOpCanFail ReadByteArrayOp_WideChar = True primOpCanFail ReadByteArrayOp_Int = True@@ -93,6 +93,8 @@ primOpCanFail ReadByteArrayOp_Word64 = True primOpCanFail ReadByteArrayOp_Word8AsChar = True primOpCanFail ReadByteArrayOp_Word8AsWideChar = True+primOpCanFail ReadByteArrayOp_Word8AsInt = True+primOpCanFail ReadByteArrayOp_Word8AsWord = True primOpCanFail ReadByteArrayOp_Word8AsAddr = True primOpCanFail ReadByteArrayOp_Word8AsFloat = True primOpCanFail ReadByteArrayOp_Word8AsDouble = True@@ -100,11 +102,9 @@ primOpCanFail ReadByteArrayOp_Word8AsInt16 = True primOpCanFail ReadByteArrayOp_Word8AsInt32 = True primOpCanFail ReadByteArrayOp_Word8AsInt64 = True-primOpCanFail ReadByteArrayOp_Word8AsInt = True primOpCanFail ReadByteArrayOp_Word8AsWord16 = True primOpCanFail ReadByteArrayOp_Word8AsWord32 = True primOpCanFail ReadByteArrayOp_Word8AsWord64 = True-primOpCanFail ReadByteArrayOp_Word8AsWord = True primOpCanFail WriteByteArrayOp_Char = True primOpCanFail WriteByteArrayOp_WideChar = True primOpCanFail WriteByteArrayOp_Int = True@@ -123,6 +123,8 @@ primOpCanFail WriteByteArrayOp_Word64 = True primOpCanFail WriteByteArrayOp_Word8AsChar = True primOpCanFail WriteByteArrayOp_Word8AsWideChar = True+primOpCanFail WriteByteArrayOp_Word8AsInt = True+primOpCanFail WriteByteArrayOp_Word8AsWord = True primOpCanFail WriteByteArrayOp_Word8AsAddr = True primOpCanFail WriteByteArrayOp_Word8AsFloat = True primOpCanFail WriteByteArrayOp_Word8AsDouble = True@@ -130,11 +132,9 @@ primOpCanFail WriteByteArrayOp_Word8AsInt16 = True primOpCanFail WriteByteArrayOp_Word8AsInt32 = True primOpCanFail WriteByteArrayOp_Word8AsInt64 = True-primOpCanFail WriteByteArrayOp_Word8AsInt = True primOpCanFail WriteByteArrayOp_Word8AsWord16 = True primOpCanFail WriteByteArrayOp_Word8AsWord32 = True primOpCanFail WriteByteArrayOp_Word8AsWord64 = True-primOpCanFail WriteByteArrayOp_Word8AsWord = True primOpCanFail CompareByteArraysOp = True primOpCanFail CopyByteArrayOp = True primOpCanFail CopyMutableByteArrayOp = True
ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl view
@@ -292,6 +292,8 @@ | IndexByteArrayOp_Word64 | IndexByteArrayOp_Word8AsChar | IndexByteArrayOp_Word8AsWideChar+ | IndexByteArrayOp_Word8AsInt+ | IndexByteArrayOp_Word8AsWord | IndexByteArrayOp_Word8AsAddr | IndexByteArrayOp_Word8AsFloat | IndexByteArrayOp_Word8AsDouble@@ -299,11 +301,9 @@ | IndexByteArrayOp_Word8AsInt16 | IndexByteArrayOp_Word8AsInt32 | IndexByteArrayOp_Word8AsInt64- | IndexByteArrayOp_Word8AsInt | IndexByteArrayOp_Word8AsWord16 | IndexByteArrayOp_Word8AsWord32 | IndexByteArrayOp_Word8AsWord64- | IndexByteArrayOp_Word8AsWord | ReadByteArrayOp_Char | ReadByteArrayOp_WideChar | ReadByteArrayOp_Int@@ -322,6 +322,8 @@ | ReadByteArrayOp_Word64 | ReadByteArrayOp_Word8AsChar | ReadByteArrayOp_Word8AsWideChar+ | ReadByteArrayOp_Word8AsInt+ | ReadByteArrayOp_Word8AsWord | ReadByteArrayOp_Word8AsAddr | ReadByteArrayOp_Word8AsFloat | ReadByteArrayOp_Word8AsDouble@@ -329,11 +331,9 @@ | ReadByteArrayOp_Word8AsInt16 | ReadByteArrayOp_Word8AsInt32 | ReadByteArrayOp_Word8AsInt64- | ReadByteArrayOp_Word8AsInt | ReadByteArrayOp_Word8AsWord16 | ReadByteArrayOp_Word8AsWord32 | ReadByteArrayOp_Word8AsWord64- | ReadByteArrayOp_Word8AsWord | WriteByteArrayOp_Char | WriteByteArrayOp_WideChar | WriteByteArrayOp_Int@@ -352,6 +352,8 @@ | WriteByteArrayOp_Word64 | WriteByteArrayOp_Word8AsChar | WriteByteArrayOp_Word8AsWideChar+ | WriteByteArrayOp_Word8AsInt+ | WriteByteArrayOp_Word8AsWord | WriteByteArrayOp_Word8AsAddr | WriteByteArrayOp_Word8AsFloat | WriteByteArrayOp_Word8AsDouble@@ -359,11 +361,9 @@ | WriteByteArrayOp_Word8AsInt16 | WriteByteArrayOp_Word8AsInt32 | WriteByteArrayOp_Word8AsInt64- | WriteByteArrayOp_Word8AsInt | WriteByteArrayOp_Word8AsWord16 | WriteByteArrayOp_Word8AsWord32 | WriteByteArrayOp_Word8AsWord64- | WriteByteArrayOp_Word8AsWord | CompareByteArraysOp | CopyByteArrayOp | CopyMutableByteArrayOp@@ -458,6 +458,8 @@ | WriteOffAddrOp_Word64 | InterlockedExchange_Addr | InterlockedExchange_Int+ | AtomicCompareExchange_Int+ | AtomicCompareExchange_Addr | NewMutVarOp | ReadMutVarOp | WriteMutVarOp
ghc-lib/stage0/compiler/build/primop-docs.hs-incl view
@@ -105,36 +105,96 @@ , ("sizeofByteArray#","Return the size of the array in bytes.") , ("sizeofMutableByteArray#","Return the size of the array in bytes. Note that this is deprecated as it is\n unsafe in the presence of shrink and resize operations on the same mutable byte\n array.") , ("getSizeofMutableByteArray#","Return the number of elements in the array.")- , ("indexCharArray#","Read 8-bit character; offset in bytes.")- , ("indexWideCharArray#","Read 31-bit character; offset in 4-byte words.")- , ("indexInt8Array#","Read 8-bit integer; offset in bytes.")- , ("indexInt16Array#","Read 16-bit integer; offset in 16-bit words.")- , ("indexInt32Array#","Read 32-bit integer; offset in 32-bit words.")- , ("indexInt64Array#","Read 64-bit integer; offset in 64-bit words.")- , ("indexWord8Array#","Read 8-bit word; offset in bytes.")- , ("indexWord16Array#","Read 16-bit word; offset in 16-bit words.")- , ("indexWord32Array#","Read 32-bit word; offset in 32-bit words.")- , ("indexWord64Array#","Read 64-bit word; offset in 64-bit words.")- , ("indexWord8ArrayAsChar#","Read 8-bit character; offset in bytes.")- , ("indexWord8ArrayAsWideChar#","Read 31-bit character; offset in bytes.")- , ("indexWord8ArrayAsAddr#","Read address; offset in bytes.")- , ("indexWord8ArrayAsFloat#","Read float; offset in bytes.")- , ("indexWord8ArrayAsDouble#","Read double; offset in bytes.")- , ("indexWord8ArrayAsStablePtr#","Read stable pointer; offset in bytes.")- , ("indexWord8ArrayAsInt16#","Read 16-bit int; offset in bytes.")- , ("indexWord8ArrayAsInt32#","Read 32-bit int; offset in bytes.")- , ("indexWord8ArrayAsInt64#","Read 64-bit int; offset in bytes.")- , ("indexWord8ArrayAsInt#","Read int; offset in bytes.")- , ("indexWord8ArrayAsWord16#","Read 16-bit word; offset in bytes.")- , ("indexWord8ArrayAsWord32#","Read 32-bit word; offset in bytes.")- , ("indexWord8ArrayAsWord64#","Read 64-bit word; offset in bytes.")- , ("indexWord8ArrayAsWord#","Read word; offset in bytes.")- , ("readCharArray#","Read 8-bit character; offset in bytes.")- , ("readWideCharArray#","Read 31-bit character; offset in 4-byte words.")- , ("readIntArray#","Read integer; offset in machine words.")- , ("readWordArray#","Read word; offset in machine words.")- , ("writeCharArray#","Write 8-bit character; offset in bytes.")- , ("writeWideCharArray#","Write 31-bit character; offset in 4-byte words.")+ , ("indexCharArray#","Read a 8-bit character; offset in bytes.")+ , ("indexWideCharArray#","Read a 32-bit character; offset in 4-byte words.")+ , ("indexIntArray#","Read a word-sized integer; offset in machine words.")+ , ("indexWordArray#","Read a word-sized unsigned integer; offset in machine words.")+ , ("indexAddrArray#","Read a machine address; offset in machine words.")+ , ("indexFloatArray#","Read a single-precision floating-point value; offset in 4-byte words.")+ , ("indexDoubleArray#","Read a double-precision floating-point value; offset in 8-byte words.")+ , ("indexStablePtrArray#","Read a @StablePtr#@ value; offset in machine words.")+ , ("indexInt8Array#","Read a 8-bit signed integer; offset in bytes.")+ , ("indexInt16Array#","Read a 16-bit signed integer; offset in 2-byte words.")+ , ("indexInt32Array#","Read a 32-bit signed integer; offset in 4-byte words.")+ , ("indexInt64Array#","Read a 64-bit signed integer; offset in 8-byte words.")+ , ("indexWord8Array#","Read a 8-bit unsigned integer; offset in bytes.")+ , ("indexWord16Array#","Read a 16-bit unsigned integer; offset in 2-byte words.")+ , ("indexWord32Array#","Read a 32-bit unsigned integer; offset in 4-byte words.")+ , ("indexWord64Array#","Read a 64-bit unsigned integer; offset in 8-byte words.")+ , ("indexWord8ArrayAsChar#","Read a 8-bit character; offset in bytes.")+ , ("indexWord8ArrayAsWideChar#","Read a 32-bit character; offset in bytes.")+ , ("indexWord8ArrayAsInt#","Read a word-sized integer; offset in bytes.")+ , ("indexWord8ArrayAsWord#","Read a word-sized unsigned integer; offset in bytes.")+ , ("indexWord8ArrayAsAddr#","Read a machine address; offset in bytes.")+ , ("indexWord8ArrayAsFloat#","Read a single-precision floating-point value; offset in bytes.")+ , ("indexWord8ArrayAsDouble#","Read a double-precision floating-point value; offset in bytes.")+ , ("indexWord8ArrayAsStablePtr#","Read a @StablePtr#@ value; offset in bytes.")+ , ("indexWord8ArrayAsInt16#","Read a 16-bit signed integer; offset in bytes.")+ , ("indexWord8ArrayAsInt32#","Read a 32-bit signed integer; offset in bytes.")+ , ("indexWord8ArrayAsInt64#","Read a 64-bit signed integer; offset in bytes.")+ , ("indexWord8ArrayAsWord16#","Read a 16-bit unsigned integer; offset in bytes.")+ , ("indexWord8ArrayAsWord32#","Read a 32-bit unsigned integer; offset in bytes.")+ , ("indexWord8ArrayAsWord64#","Read a 64-bit unsigned integer; offset in bytes.")+ , ("readCharArray#","Read a 8-bit character; offset in bytes.")+ , ("readWideCharArray#","Read a 32-bit character; offset in 4-byte words.")+ , ("readIntArray#","Read a word-sized integer; offset in machine words.")+ , ("readWordArray#","Read a word-sized unsigned integer; offset in machine words.")+ , ("readAddrArray#","Read a machine address; offset in machine words.")+ , ("readFloatArray#","Read a single-precision floating-point value; offset in 4-byte words.")+ , ("readDoubleArray#","Read a double-precision floating-point value; offset in 8-byte words.")+ , ("readStablePtrArray#","Read a @StablePtr#@ value; offset in machine words.")+ , ("readInt8Array#","Read a 8-bit signed integer; offset in bytes.")+ , ("readInt16Array#","Read a 16-bit signed integer; offset in 2-byte words.")+ , ("readInt32Array#","Read a 32-bit signed integer; offset in 4-byte words.")+ , ("readInt64Array#","Read a 64-bit signed integer; offset in 8-byte words.")+ , ("readWord8Array#","Read a 8-bit unsigned integer; offset in bytes.")+ , ("readWord16Array#","Read a 16-bit unsigned integer; offset in 2-byte words.")+ , ("readWord32Array#","Read a 32-bit unsigned integer; offset in 4-byte words.")+ , ("readWord64Array#","Read a 64-bit unsigned integer; offset in 8-byte words.")+ , ("readWord8ArrayAsChar#","Read a 8-bit character; offset in bytes.")+ , ("readWord8ArrayAsWideChar#","Read a 32-bit character; offset in bytes.")+ , ("readWord8ArrayAsInt#","Read a word-sized integer; offset in bytes.")+ , ("readWord8ArrayAsWord#","Read a word-sized unsigned integer; offset in bytes.")+ , ("readWord8ArrayAsAddr#","Read a machine address; offset in bytes.")+ , ("readWord8ArrayAsFloat#","Read a single-precision floating-point value; offset in bytes.")+ , ("readWord8ArrayAsDouble#","Read a double-precision floating-point value; offset in bytes.")+ , ("readWord8ArrayAsStablePtr#","Read a @StablePtr#@ value; offset in bytes.")+ , ("readWord8ArrayAsInt16#","Read a 16-bit signed integer; offset in bytes.")+ , ("readWord8ArrayAsInt32#","Read a 32-bit signed integer; offset in bytes.")+ , ("readWord8ArrayAsInt64#","Read a 64-bit signed integer; offset in bytes.")+ , ("readWord8ArrayAsWord16#","Read a 16-bit unsigned integer; offset in bytes.")+ , ("readWord8ArrayAsWord32#","Read a 32-bit unsigned integer; offset in bytes.")+ , ("readWord8ArrayAsWord64#","Read a 64-bit unsigned integer; offset in bytes.")+ , ("writeCharArray#","Write a 8-bit character; offset in bytes.")+ , ("writeWideCharArray#","Write a 32-bit character; offset in 4-byte words.")+ , ("writeIntArray#","Write a word-sized integer; offset in machine words.")+ , ("writeWordArray#","Write a word-sized unsigned integer; offset in machine words.")+ , ("writeAddrArray#","Write a machine address; offset in machine words.")+ , ("writeFloatArray#","Write a single-precision floating-point value; offset in 4-byte words.")+ , ("writeDoubleArray#","Write a double-precision floating-point value; offset in 8-byte words.")+ , ("writeStablePtrArray#","Write a @StablePtr#@ value; offset in machine words.")+ , ("writeInt8Array#","Write a 8-bit signed integer; offset in bytes.")+ , ("writeInt16Array#","Write a 16-bit signed integer; offset in 2-byte words.")+ , ("writeInt32Array#","Write a 32-bit signed integer; offset in 4-byte words.")+ , ("writeInt64Array#","Write a 64-bit signed integer; offset in 8-byte words.")+ , ("writeWord8Array#","Write a 8-bit unsigned integer; offset in bytes.")+ , ("writeWord16Array#","Write a 16-bit unsigned integer; offset in 2-byte words.")+ , ("writeWord32Array#","Write a 32-bit unsigned integer; offset in 4-byte words.")+ , ("writeWord64Array#","Write a 64-bit unsigned integer; offset in 8-byte words.")+ , ("writeWord8ArrayAsChar#","Write a 8-bit character; offset in bytes.")+ , ("writeWord8ArrayAsWideChar#","Write a 32-bit character; offset in bytes.")+ , ("writeWord8ArrayAsInt#","Write a word-sized integer; offset in bytes.")+ , ("writeWord8ArrayAsWord#","Write a word-sized unsigned integer; offset in bytes.")+ , ("writeWord8ArrayAsAddr#","Write a machine address; offset in bytes.")+ , ("writeWord8ArrayAsFloat#","Write a single-precision floating-point value; offset in bytes.")+ , ("writeWord8ArrayAsDouble#","Write a double-precision floating-point value; offset in bytes.")+ , ("writeWord8ArrayAsStablePtr#","Write a @StablePtr#@ value; offset in bytes.")+ , ("writeWord8ArrayAsInt16#","Write a 16-bit signed integer; offset in bytes.")+ , ("writeWord8ArrayAsInt32#","Write a 32-bit signed integer; offset in bytes.")+ , ("writeWord8ArrayAsInt64#","Write a 64-bit signed integer; offset in bytes.")+ , ("writeWord8ArrayAsWord16#","Write a 16-bit unsigned integer; offset in bytes.")+ , ("writeWord8ArrayAsWord32#","Write a 32-bit unsigned integer; offset in bytes.")+ , ("writeWord8ArrayAsWord64#","Write a 64-bit unsigned integer; offset in bytes.") , ("compareByteArrays#","@compareByteArrays# src1 src1_ofs src2 src2_ofs n@ compares\n @n@ bytes starting at offset @src1_ofs@ in the first\n @ByteArray#@ @src1@ to the range of @n@ bytes\n (i.e. same length) starting at offset @src2_ofs@ of the second\n @ByteArray#@ @src2@. Both arrays must fully contain the\n specified ranges, but this is not checked. Returns an @Int#@\n less than, equal to, or greater than zero if the range is found,\n respectively, to be byte-wise lexicographically less than, to\n match, or be greater than the second range.") , ("copyByteArray#","@copyByteArray# src src_ofs dst dst_ofs n@ copies the range\n starting at offset @src_ofs@ of length @n@ from the\n @ByteArray#@ @src@ to the @MutableByteArray#@ @dst@\n starting at offset @dst_ofs@. Both arrays must fully contain\n the specified ranges, but this is not checked. The two arrays must\n not be the same array in different states, but this is not checked\n either.") , ("copyMutableByteArray#","Copy a range of the first MutableByteArray\\# to the specified region in the second MutableByteArray\\#.\n Both arrays must fully contain the specified ranges, but this is not checked. The regions are\n allowed to overlap, although this is only possible when the same array is provided\n as both the source and the destination.")@@ -167,8 +227,10 @@ , ("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.")+ , ("atomicExchangeAddr#","The atomic exchange operation. Atomically exchanges the value at the first address\n with the Addr# given as second argument. Implies a read barrier.")+ , ("atomicExchangeInt#","The atomic exchange operation. Atomically exchanges the value at the address\n with the given value. Returns the old value. Implies a read barrier.")+ , ("atomicCasInt#"," Compare and swap on a word-sized memory location.\n\n Use as atomicCasInt# location expected desired\n\n This version always returns the old value read. This follows the normal protocol for CAS operations (and matches the underlying instruction on most architectures).\n\n Implies a full memory barrier.")+ , ("atomicCasAddr#"," Compare and swap on a word-sized memory location.\n\n Use as atomicCasAddr# location expected desired\n\n This version always returns the old value read. This follows the normal protocol for CAS operations (and matches the underlying instruction on most architectures).\n\n Implies a full memory 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.")
ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl view
@@ -47,6 +47,8 @@ primOpHasSideEffects ReadByteArrayOp_Word64 = True primOpHasSideEffects ReadByteArrayOp_Word8AsChar = True primOpHasSideEffects ReadByteArrayOp_Word8AsWideChar = True+primOpHasSideEffects ReadByteArrayOp_Word8AsInt = True+primOpHasSideEffects ReadByteArrayOp_Word8AsWord = True primOpHasSideEffects ReadByteArrayOp_Word8AsAddr = True primOpHasSideEffects ReadByteArrayOp_Word8AsFloat = True primOpHasSideEffects ReadByteArrayOp_Word8AsDouble = True@@ -54,11 +56,9 @@ primOpHasSideEffects ReadByteArrayOp_Word8AsInt16 = True primOpHasSideEffects ReadByteArrayOp_Word8AsInt32 = True primOpHasSideEffects ReadByteArrayOp_Word8AsInt64 = True-primOpHasSideEffects ReadByteArrayOp_Word8AsInt = True primOpHasSideEffects ReadByteArrayOp_Word8AsWord16 = True primOpHasSideEffects ReadByteArrayOp_Word8AsWord32 = True primOpHasSideEffects ReadByteArrayOp_Word8AsWord64 = True-primOpHasSideEffects ReadByteArrayOp_Word8AsWord = True primOpHasSideEffects WriteByteArrayOp_Char = True primOpHasSideEffects WriteByteArrayOp_WideChar = True primOpHasSideEffects WriteByteArrayOp_Int = True@@ -77,6 +77,8 @@ primOpHasSideEffects WriteByteArrayOp_Word64 = True primOpHasSideEffects WriteByteArrayOp_Word8AsChar = True primOpHasSideEffects WriteByteArrayOp_Word8AsWideChar = True+primOpHasSideEffects WriteByteArrayOp_Word8AsInt = True+primOpHasSideEffects WriteByteArrayOp_Word8AsWord = True primOpHasSideEffects WriteByteArrayOp_Word8AsAddr = True primOpHasSideEffects WriteByteArrayOp_Word8AsFloat = True primOpHasSideEffects WriteByteArrayOp_Word8AsDouble = True@@ -84,11 +86,9 @@ primOpHasSideEffects WriteByteArrayOp_Word8AsInt16 = True primOpHasSideEffects WriteByteArrayOp_Word8AsInt32 = True primOpHasSideEffects WriteByteArrayOp_Word8AsInt64 = True-primOpHasSideEffects WriteByteArrayOp_Word8AsInt = True primOpHasSideEffects WriteByteArrayOp_Word8AsWord16 = True primOpHasSideEffects WriteByteArrayOp_Word8AsWord32 = True primOpHasSideEffects WriteByteArrayOp_Word8AsWord64 = True-primOpHasSideEffects WriteByteArrayOp_Word8AsWord = True primOpHasSideEffects CopyByteArrayOp = True primOpHasSideEffects CopyMutableByteArrayOp = True primOpHasSideEffects CopyByteArrayToAddrOp = True@@ -150,6 +150,8 @@ primOpHasSideEffects WriteOffAddrOp_Word64 = True primOpHasSideEffects InterlockedExchange_Addr = True primOpHasSideEffects InterlockedExchange_Int = True+primOpHasSideEffects AtomicCompareExchange_Int = True+primOpHasSideEffects AtomicCompareExchange_Addr = True primOpHasSideEffects NewMutVarOp = True primOpHasSideEffects ReadMutVarOp = True primOpHasSideEffects WriteMutVarOp = True
ghc-lib/stage0/compiler/build/primop-list.hs-incl view
@@ -291,6 +291,8 @@ , IndexByteArrayOp_Word64 , IndexByteArrayOp_Word8AsChar , IndexByteArrayOp_Word8AsWideChar+ , IndexByteArrayOp_Word8AsInt+ , IndexByteArrayOp_Word8AsWord , IndexByteArrayOp_Word8AsAddr , IndexByteArrayOp_Word8AsFloat , IndexByteArrayOp_Word8AsDouble@@ -298,11 +300,9 @@ , IndexByteArrayOp_Word8AsInt16 , IndexByteArrayOp_Word8AsInt32 , IndexByteArrayOp_Word8AsInt64- , IndexByteArrayOp_Word8AsInt , IndexByteArrayOp_Word8AsWord16 , IndexByteArrayOp_Word8AsWord32 , IndexByteArrayOp_Word8AsWord64- , IndexByteArrayOp_Word8AsWord , ReadByteArrayOp_Char , ReadByteArrayOp_WideChar , ReadByteArrayOp_Int@@ -321,6 +321,8 @@ , ReadByteArrayOp_Word64 , ReadByteArrayOp_Word8AsChar , ReadByteArrayOp_Word8AsWideChar+ , ReadByteArrayOp_Word8AsInt+ , ReadByteArrayOp_Word8AsWord , ReadByteArrayOp_Word8AsAddr , ReadByteArrayOp_Word8AsFloat , ReadByteArrayOp_Word8AsDouble@@ -328,11 +330,9 @@ , ReadByteArrayOp_Word8AsInt16 , ReadByteArrayOp_Word8AsInt32 , ReadByteArrayOp_Word8AsInt64- , ReadByteArrayOp_Word8AsInt , ReadByteArrayOp_Word8AsWord16 , ReadByteArrayOp_Word8AsWord32 , ReadByteArrayOp_Word8AsWord64- , ReadByteArrayOp_Word8AsWord , WriteByteArrayOp_Char , WriteByteArrayOp_WideChar , WriteByteArrayOp_Int@@ -351,6 +351,8 @@ , WriteByteArrayOp_Word64 , WriteByteArrayOp_Word8AsChar , WriteByteArrayOp_Word8AsWideChar+ , WriteByteArrayOp_Word8AsInt+ , WriteByteArrayOp_Word8AsWord , WriteByteArrayOp_Word8AsAddr , WriteByteArrayOp_Word8AsFloat , WriteByteArrayOp_Word8AsDouble@@ -358,11 +360,9 @@ , WriteByteArrayOp_Word8AsInt16 , WriteByteArrayOp_Word8AsInt32 , WriteByteArrayOp_Word8AsInt64- , WriteByteArrayOp_Word8AsInt , WriteByteArrayOp_Word8AsWord16 , WriteByteArrayOp_Word8AsWord32 , WriteByteArrayOp_Word8AsWord64- , WriteByteArrayOp_Word8AsWord , CompareByteArraysOp , CopyByteArrayOp , CopyMutableByteArrayOp@@ -457,6 +457,8 @@ , WriteOffAddrOp_Word64 , InterlockedExchange_Addr , InterlockedExchange_Int+ , AtomicCompareExchange_Int+ , AtomicCompareExchange_Addr , NewMutVarOp , ReadMutVarOp , WriteMutVarOp
ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl view
@@ -291,6 +291,8 @@ primOpInfo IndexByteArrayOp_Word64 = mkGenPrimOp (fsLit "indexWord64Array#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) primOpInfo IndexByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "indexWord8ArrayAsChar#") [] [byteArrayPrimTy, intPrimTy] (charPrimTy) primOpInfo IndexByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "indexWord8ArrayAsWideChar#") [] [byteArrayPrimTy, intPrimTy] (charPrimTy)+primOpInfo IndexByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "indexWord8ArrayAsInt#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "indexWord8ArrayAsWord#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) primOpInfo IndexByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "indexWord8ArrayAsAddr#") [] [byteArrayPrimTy, intPrimTy] (addrPrimTy) primOpInfo IndexByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "indexWord8ArrayAsFloat#") [] [byteArrayPrimTy, intPrimTy] (floatPrimTy) primOpInfo IndexByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "indexWord8ArrayAsDouble#") [] [byteArrayPrimTy, intPrimTy] (doublePrimTy)@@ -298,11 +300,9 @@ primOpInfo IndexByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt16#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy) primOpInfo IndexByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt32#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy) primOpInfo IndexByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt64#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy)-primOpInfo IndexByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "indexWord8ArrayAsInt#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy) primOpInfo IndexByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord16#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) primOpInfo IndexByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord32#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) primOpInfo IndexByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord64#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)-primOpInfo IndexByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "indexWord8ArrayAsWord#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) primOpInfo ReadByteArrayOp_Char = mkGenPrimOp (fsLit "readCharArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) primOpInfo ReadByteArrayOp_WideChar = mkGenPrimOp (fsLit "readWideCharArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) primOpInfo ReadByteArrayOp_Int = mkGenPrimOp (fsLit "readIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))@@ -321,6 +321,8 @@ primOpInfo ReadByteArrayOp_Word64 = mkGenPrimOp (fsLit "readWord64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) primOpInfo ReadByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "readWord8ArrayAsChar#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) primOpInfo ReadByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "readWord8ArrayAsWideChar#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "readWord8ArrayAsInt#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "readWord8ArrayAsWord#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) primOpInfo ReadByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "readWord8ArrayAsAddr#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) primOpInfo ReadByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "readWord8ArrayAsFloat#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy])) primOpInfo ReadByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "readWord8ArrayAsDouble#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy]))@@ -328,11 +330,9 @@ primOpInfo ReadByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "readWord8ArrayAsInt16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo ReadByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "readWord8ArrayAsInt32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo ReadByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "readWord8ArrayAsInt64#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo ReadByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "readWord8ArrayAsInt#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo ReadByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "readWord8ArrayAsWord16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) primOpInfo ReadByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "readWord8ArrayAsWord32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) primOpInfo ReadByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "readWord8ArrayAsWord64#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))-primOpInfo ReadByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "readWord8ArrayAsWord#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) primOpInfo WriteByteArrayOp_Char = mkGenPrimOp (fsLit "writeCharArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_WideChar = mkGenPrimOp (fsLit "writeWideCharArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Int = mkGenPrimOp (fsLit "writeIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)@@ -351,6 +351,8 @@ primOpInfo WriteByteArrayOp_Word64 = mkGenPrimOp (fsLit "writeWord64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "writeWord8ArrayAsChar#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "writeWord8ArrayAsWideChar#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "writeWord8ArrayAsInt#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "writeWord8ArrayAsWord#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "writeWord8ArrayAsAddr#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "writeWord8ArrayAsFloat#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "writeWord8ArrayAsDouble#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)@@ -358,11 +360,9 @@ primOpInfo WriteByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt64#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "writeWord8ArrayAsInt#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord64#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "writeWord8ArrayAsWord#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo CompareByteArraysOp = mkGenPrimOp (fsLit "compareByteArrays#") [] [byteArrayPrimTy, intPrimTy, byteArrayPrimTy, intPrimTy, intPrimTy] (intPrimTy) primOpInfo CopyByteArrayOp = mkGenPrimOp (fsLit "copyByteArray#") [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo CopyMutableByteArrayOp = mkGenPrimOp (fsLit "copyMutableByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)@@ -455,8 +455,10 @@ 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 InterlockedExchange_Addr = mkGenPrimOp (fsLit "atomicExchangeAddr#") [deltaTyVar] [addrPrimTy, addrPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))+primOpInfo InterlockedExchange_Int = mkGenPrimOp (fsLit "atomicExchangeInt#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo AtomicCompareExchange_Int = mkGenPrimOp (fsLit "atomicCasInt#") [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo AtomicCompareExchange_Addr = mkGenPrimOp (fsLit "atomicCasAddr#") [deltaTyVar] [addrPrimTy, addrPrimTy, addrPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) 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)
ghc-lib/stage0/compiler/build/primop-tag.hs-incl view
@@ -1,1213 +1,1215 @@ maxPrimOpTag :: Int-maxPrimOpTag = 1210-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 IntToWordOp = 90-primOpTag IntToFloatOp = 91-primOpTag IntToDoubleOp = 92-primOpTag WordToFloatOp = 93-primOpTag WordToDoubleOp = 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 WordToIntOp = 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 DoubleToIntOp = 174-primOpTag DoubleToFloatOp = 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 FloatToIntOp = 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 FloatToDoubleOp = 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 AddrToIntOp = 402-primOpTag IntToAddrOp = 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 NewIOPortrOp = 492-primOpTag ReadIOPortOp = 493-primOpTag WriteIOPortOp = 494-primOpTag SameIOPortOp = 495-primOpTag DelayOp = 496-primOpTag WaitReadOp = 497-primOpTag WaitWriteOp = 498-primOpTag ForkOp = 499-primOpTag ForkOnOp = 500-primOpTag KillThreadOp = 501-primOpTag YieldOp = 502-primOpTag MyThreadIdOp = 503-primOpTag LabelThreadOp = 504-primOpTag IsCurrentThreadBoundOp = 505-primOpTag NoDuplicateOp = 506-primOpTag ThreadStatusOp = 507-primOpTag MkWeakOp = 508-primOpTag MkWeakNoFinalizerOp = 509-primOpTag AddCFinalizerToWeakOp = 510-primOpTag DeRefWeakOp = 511-primOpTag FinalizeWeakOp = 512-primOpTag TouchOp = 513-primOpTag MakeStablePtrOp = 514-primOpTag DeRefStablePtrOp = 515-primOpTag EqStablePtrOp = 516-primOpTag MakeStableNameOp = 517-primOpTag EqStableNameOp = 518-primOpTag StableNameToIntOp = 519-primOpTag CompactNewOp = 520-primOpTag CompactResizeOp = 521-primOpTag CompactContainsOp = 522-primOpTag CompactContainsAnyOp = 523-primOpTag CompactGetFirstBlockOp = 524-primOpTag CompactGetNextBlockOp = 525-primOpTag CompactAllocateBlockOp = 526-primOpTag CompactFixupPointersOp = 527-primOpTag CompactAdd = 528-primOpTag CompactAddWithSharing = 529-primOpTag CompactSize = 530-primOpTag ReallyUnsafePtrEqualityOp = 531-primOpTag ParOp = 532-primOpTag SparkOp = 533-primOpTag SeqOp = 534-primOpTag GetSparkOp = 535-primOpTag NumSparks = 536-primOpTag DataToTagOp = 537-primOpTag TagToEnumOp = 538-primOpTag AddrToAnyOp = 539-primOpTag AnyToAddrOp = 540-primOpTag MkApUpd0_Op = 541-primOpTag NewBCOOp = 542-primOpTag UnpackClosureOp = 543-primOpTag ClosureSizeOp = 544-primOpTag GetApStackValOp = 545-primOpTag GetCCSOfOp = 546-primOpTag GetCurrentCCSOp = 547-primOpTag ClearCCSOp = 548-primOpTag TraceEventOp = 549-primOpTag TraceEventBinaryOp = 550-primOpTag TraceMarkerOp = 551-primOpTag SetThreadAllocationCounter = 552-primOpTag (VecBroadcastOp IntVec 16 W8) = 553-primOpTag (VecBroadcastOp IntVec 8 W16) = 554-primOpTag (VecBroadcastOp IntVec 4 W32) = 555-primOpTag (VecBroadcastOp IntVec 2 W64) = 556-primOpTag (VecBroadcastOp IntVec 32 W8) = 557-primOpTag (VecBroadcastOp IntVec 16 W16) = 558-primOpTag (VecBroadcastOp IntVec 8 W32) = 559-primOpTag (VecBroadcastOp IntVec 4 W64) = 560-primOpTag (VecBroadcastOp IntVec 64 W8) = 561-primOpTag (VecBroadcastOp IntVec 32 W16) = 562-primOpTag (VecBroadcastOp IntVec 16 W32) = 563-primOpTag (VecBroadcastOp IntVec 8 W64) = 564-primOpTag (VecBroadcastOp WordVec 16 W8) = 565-primOpTag (VecBroadcastOp WordVec 8 W16) = 566-primOpTag (VecBroadcastOp WordVec 4 W32) = 567-primOpTag (VecBroadcastOp WordVec 2 W64) = 568-primOpTag (VecBroadcastOp WordVec 32 W8) = 569-primOpTag (VecBroadcastOp WordVec 16 W16) = 570-primOpTag (VecBroadcastOp WordVec 8 W32) = 571-primOpTag (VecBroadcastOp WordVec 4 W64) = 572-primOpTag (VecBroadcastOp WordVec 64 W8) = 573-primOpTag (VecBroadcastOp WordVec 32 W16) = 574-primOpTag (VecBroadcastOp WordVec 16 W32) = 575-primOpTag (VecBroadcastOp WordVec 8 W64) = 576-primOpTag (VecBroadcastOp FloatVec 4 W32) = 577-primOpTag (VecBroadcastOp FloatVec 2 W64) = 578-primOpTag (VecBroadcastOp FloatVec 8 W32) = 579-primOpTag (VecBroadcastOp FloatVec 4 W64) = 580-primOpTag (VecBroadcastOp FloatVec 16 W32) = 581-primOpTag (VecBroadcastOp FloatVec 8 W64) = 582-primOpTag (VecPackOp IntVec 16 W8) = 583-primOpTag (VecPackOp IntVec 8 W16) = 584-primOpTag (VecPackOp IntVec 4 W32) = 585-primOpTag (VecPackOp IntVec 2 W64) = 586-primOpTag (VecPackOp IntVec 32 W8) = 587-primOpTag (VecPackOp IntVec 16 W16) = 588-primOpTag (VecPackOp IntVec 8 W32) = 589-primOpTag (VecPackOp IntVec 4 W64) = 590-primOpTag (VecPackOp IntVec 64 W8) = 591-primOpTag (VecPackOp IntVec 32 W16) = 592-primOpTag (VecPackOp IntVec 16 W32) = 593-primOpTag (VecPackOp IntVec 8 W64) = 594-primOpTag (VecPackOp WordVec 16 W8) = 595-primOpTag (VecPackOp WordVec 8 W16) = 596-primOpTag (VecPackOp WordVec 4 W32) = 597-primOpTag (VecPackOp WordVec 2 W64) = 598-primOpTag (VecPackOp WordVec 32 W8) = 599-primOpTag (VecPackOp WordVec 16 W16) = 600-primOpTag (VecPackOp WordVec 8 W32) = 601-primOpTag (VecPackOp WordVec 4 W64) = 602-primOpTag (VecPackOp WordVec 64 W8) = 603-primOpTag (VecPackOp WordVec 32 W16) = 604-primOpTag (VecPackOp WordVec 16 W32) = 605-primOpTag (VecPackOp WordVec 8 W64) = 606-primOpTag (VecPackOp FloatVec 4 W32) = 607-primOpTag (VecPackOp FloatVec 2 W64) = 608-primOpTag (VecPackOp FloatVec 8 W32) = 609-primOpTag (VecPackOp FloatVec 4 W64) = 610-primOpTag (VecPackOp FloatVec 16 W32) = 611-primOpTag (VecPackOp FloatVec 8 W64) = 612-primOpTag (VecUnpackOp IntVec 16 W8) = 613-primOpTag (VecUnpackOp IntVec 8 W16) = 614-primOpTag (VecUnpackOp IntVec 4 W32) = 615-primOpTag (VecUnpackOp IntVec 2 W64) = 616-primOpTag (VecUnpackOp IntVec 32 W8) = 617-primOpTag (VecUnpackOp IntVec 16 W16) = 618-primOpTag (VecUnpackOp IntVec 8 W32) = 619-primOpTag (VecUnpackOp IntVec 4 W64) = 620-primOpTag (VecUnpackOp IntVec 64 W8) = 621-primOpTag (VecUnpackOp IntVec 32 W16) = 622-primOpTag (VecUnpackOp IntVec 16 W32) = 623-primOpTag (VecUnpackOp IntVec 8 W64) = 624-primOpTag (VecUnpackOp WordVec 16 W8) = 625-primOpTag (VecUnpackOp WordVec 8 W16) = 626-primOpTag (VecUnpackOp WordVec 4 W32) = 627-primOpTag (VecUnpackOp WordVec 2 W64) = 628-primOpTag (VecUnpackOp WordVec 32 W8) = 629-primOpTag (VecUnpackOp WordVec 16 W16) = 630-primOpTag (VecUnpackOp WordVec 8 W32) = 631-primOpTag (VecUnpackOp WordVec 4 W64) = 632-primOpTag (VecUnpackOp WordVec 64 W8) = 633-primOpTag (VecUnpackOp WordVec 32 W16) = 634-primOpTag (VecUnpackOp WordVec 16 W32) = 635-primOpTag (VecUnpackOp WordVec 8 W64) = 636-primOpTag (VecUnpackOp FloatVec 4 W32) = 637-primOpTag (VecUnpackOp FloatVec 2 W64) = 638-primOpTag (VecUnpackOp FloatVec 8 W32) = 639-primOpTag (VecUnpackOp FloatVec 4 W64) = 640-primOpTag (VecUnpackOp FloatVec 16 W32) = 641-primOpTag (VecUnpackOp FloatVec 8 W64) = 642-primOpTag (VecInsertOp IntVec 16 W8) = 643-primOpTag (VecInsertOp IntVec 8 W16) = 644-primOpTag (VecInsertOp IntVec 4 W32) = 645-primOpTag (VecInsertOp IntVec 2 W64) = 646-primOpTag (VecInsertOp IntVec 32 W8) = 647-primOpTag (VecInsertOp IntVec 16 W16) = 648-primOpTag (VecInsertOp IntVec 8 W32) = 649-primOpTag (VecInsertOp IntVec 4 W64) = 650-primOpTag (VecInsertOp IntVec 64 W8) = 651-primOpTag (VecInsertOp IntVec 32 W16) = 652-primOpTag (VecInsertOp IntVec 16 W32) = 653-primOpTag (VecInsertOp IntVec 8 W64) = 654-primOpTag (VecInsertOp WordVec 16 W8) = 655-primOpTag (VecInsertOp WordVec 8 W16) = 656-primOpTag (VecInsertOp WordVec 4 W32) = 657-primOpTag (VecInsertOp WordVec 2 W64) = 658-primOpTag (VecInsertOp WordVec 32 W8) = 659-primOpTag (VecInsertOp WordVec 16 W16) = 660-primOpTag (VecInsertOp WordVec 8 W32) = 661-primOpTag (VecInsertOp WordVec 4 W64) = 662-primOpTag (VecInsertOp WordVec 64 W8) = 663-primOpTag (VecInsertOp WordVec 32 W16) = 664-primOpTag (VecInsertOp WordVec 16 W32) = 665-primOpTag (VecInsertOp WordVec 8 W64) = 666-primOpTag (VecInsertOp FloatVec 4 W32) = 667-primOpTag (VecInsertOp FloatVec 2 W64) = 668-primOpTag (VecInsertOp FloatVec 8 W32) = 669-primOpTag (VecInsertOp FloatVec 4 W64) = 670-primOpTag (VecInsertOp FloatVec 16 W32) = 671-primOpTag (VecInsertOp FloatVec 8 W64) = 672-primOpTag (VecAddOp IntVec 16 W8) = 673-primOpTag (VecAddOp IntVec 8 W16) = 674-primOpTag (VecAddOp IntVec 4 W32) = 675-primOpTag (VecAddOp IntVec 2 W64) = 676-primOpTag (VecAddOp IntVec 32 W8) = 677-primOpTag (VecAddOp IntVec 16 W16) = 678-primOpTag (VecAddOp IntVec 8 W32) = 679-primOpTag (VecAddOp IntVec 4 W64) = 680-primOpTag (VecAddOp IntVec 64 W8) = 681-primOpTag (VecAddOp IntVec 32 W16) = 682-primOpTag (VecAddOp IntVec 16 W32) = 683-primOpTag (VecAddOp IntVec 8 W64) = 684-primOpTag (VecAddOp WordVec 16 W8) = 685-primOpTag (VecAddOp WordVec 8 W16) = 686-primOpTag (VecAddOp WordVec 4 W32) = 687-primOpTag (VecAddOp WordVec 2 W64) = 688-primOpTag (VecAddOp WordVec 32 W8) = 689-primOpTag (VecAddOp WordVec 16 W16) = 690-primOpTag (VecAddOp WordVec 8 W32) = 691-primOpTag (VecAddOp WordVec 4 W64) = 692-primOpTag (VecAddOp WordVec 64 W8) = 693-primOpTag (VecAddOp WordVec 32 W16) = 694-primOpTag (VecAddOp WordVec 16 W32) = 695-primOpTag (VecAddOp WordVec 8 W64) = 696-primOpTag (VecAddOp FloatVec 4 W32) = 697-primOpTag (VecAddOp FloatVec 2 W64) = 698-primOpTag (VecAddOp FloatVec 8 W32) = 699-primOpTag (VecAddOp FloatVec 4 W64) = 700-primOpTag (VecAddOp FloatVec 16 W32) = 701-primOpTag (VecAddOp FloatVec 8 W64) = 702-primOpTag (VecSubOp IntVec 16 W8) = 703-primOpTag (VecSubOp IntVec 8 W16) = 704-primOpTag (VecSubOp IntVec 4 W32) = 705-primOpTag (VecSubOp IntVec 2 W64) = 706-primOpTag (VecSubOp IntVec 32 W8) = 707-primOpTag (VecSubOp IntVec 16 W16) = 708-primOpTag (VecSubOp IntVec 8 W32) = 709-primOpTag (VecSubOp IntVec 4 W64) = 710-primOpTag (VecSubOp IntVec 64 W8) = 711-primOpTag (VecSubOp IntVec 32 W16) = 712-primOpTag (VecSubOp IntVec 16 W32) = 713-primOpTag (VecSubOp IntVec 8 W64) = 714-primOpTag (VecSubOp WordVec 16 W8) = 715-primOpTag (VecSubOp WordVec 8 W16) = 716-primOpTag (VecSubOp WordVec 4 W32) = 717-primOpTag (VecSubOp WordVec 2 W64) = 718-primOpTag (VecSubOp WordVec 32 W8) = 719-primOpTag (VecSubOp WordVec 16 W16) = 720-primOpTag (VecSubOp WordVec 8 W32) = 721-primOpTag (VecSubOp WordVec 4 W64) = 722-primOpTag (VecSubOp WordVec 64 W8) = 723-primOpTag (VecSubOp WordVec 32 W16) = 724-primOpTag (VecSubOp WordVec 16 W32) = 725-primOpTag (VecSubOp WordVec 8 W64) = 726-primOpTag (VecSubOp FloatVec 4 W32) = 727-primOpTag (VecSubOp FloatVec 2 W64) = 728-primOpTag (VecSubOp FloatVec 8 W32) = 729-primOpTag (VecSubOp FloatVec 4 W64) = 730-primOpTag (VecSubOp FloatVec 16 W32) = 731-primOpTag (VecSubOp FloatVec 8 W64) = 732-primOpTag (VecMulOp IntVec 16 W8) = 733-primOpTag (VecMulOp IntVec 8 W16) = 734-primOpTag (VecMulOp IntVec 4 W32) = 735-primOpTag (VecMulOp IntVec 2 W64) = 736-primOpTag (VecMulOp IntVec 32 W8) = 737-primOpTag (VecMulOp IntVec 16 W16) = 738-primOpTag (VecMulOp IntVec 8 W32) = 739-primOpTag (VecMulOp IntVec 4 W64) = 740-primOpTag (VecMulOp IntVec 64 W8) = 741-primOpTag (VecMulOp IntVec 32 W16) = 742-primOpTag (VecMulOp IntVec 16 W32) = 743-primOpTag (VecMulOp IntVec 8 W64) = 744-primOpTag (VecMulOp WordVec 16 W8) = 745-primOpTag (VecMulOp WordVec 8 W16) = 746-primOpTag (VecMulOp WordVec 4 W32) = 747-primOpTag (VecMulOp WordVec 2 W64) = 748-primOpTag (VecMulOp WordVec 32 W8) = 749-primOpTag (VecMulOp WordVec 16 W16) = 750-primOpTag (VecMulOp WordVec 8 W32) = 751-primOpTag (VecMulOp WordVec 4 W64) = 752-primOpTag (VecMulOp WordVec 64 W8) = 753-primOpTag (VecMulOp WordVec 32 W16) = 754-primOpTag (VecMulOp WordVec 16 W32) = 755-primOpTag (VecMulOp WordVec 8 W64) = 756-primOpTag (VecMulOp FloatVec 4 W32) = 757-primOpTag (VecMulOp FloatVec 2 W64) = 758-primOpTag (VecMulOp FloatVec 8 W32) = 759-primOpTag (VecMulOp FloatVec 4 W64) = 760-primOpTag (VecMulOp FloatVec 16 W32) = 761-primOpTag (VecMulOp FloatVec 8 W64) = 762-primOpTag (VecDivOp FloatVec 4 W32) = 763-primOpTag (VecDivOp FloatVec 2 W64) = 764-primOpTag (VecDivOp FloatVec 8 W32) = 765-primOpTag (VecDivOp FloatVec 4 W64) = 766-primOpTag (VecDivOp FloatVec 16 W32) = 767-primOpTag (VecDivOp FloatVec 8 W64) = 768-primOpTag (VecQuotOp IntVec 16 W8) = 769-primOpTag (VecQuotOp IntVec 8 W16) = 770-primOpTag (VecQuotOp IntVec 4 W32) = 771-primOpTag (VecQuotOp IntVec 2 W64) = 772-primOpTag (VecQuotOp IntVec 32 W8) = 773-primOpTag (VecQuotOp IntVec 16 W16) = 774-primOpTag (VecQuotOp IntVec 8 W32) = 775-primOpTag (VecQuotOp IntVec 4 W64) = 776-primOpTag (VecQuotOp IntVec 64 W8) = 777-primOpTag (VecQuotOp IntVec 32 W16) = 778-primOpTag (VecQuotOp IntVec 16 W32) = 779-primOpTag (VecQuotOp IntVec 8 W64) = 780-primOpTag (VecQuotOp WordVec 16 W8) = 781-primOpTag (VecQuotOp WordVec 8 W16) = 782-primOpTag (VecQuotOp WordVec 4 W32) = 783-primOpTag (VecQuotOp WordVec 2 W64) = 784-primOpTag (VecQuotOp WordVec 32 W8) = 785-primOpTag (VecQuotOp WordVec 16 W16) = 786-primOpTag (VecQuotOp WordVec 8 W32) = 787-primOpTag (VecQuotOp WordVec 4 W64) = 788-primOpTag (VecQuotOp WordVec 64 W8) = 789-primOpTag (VecQuotOp WordVec 32 W16) = 790-primOpTag (VecQuotOp WordVec 16 W32) = 791-primOpTag (VecQuotOp WordVec 8 W64) = 792-primOpTag (VecRemOp IntVec 16 W8) = 793-primOpTag (VecRemOp IntVec 8 W16) = 794-primOpTag (VecRemOp IntVec 4 W32) = 795-primOpTag (VecRemOp IntVec 2 W64) = 796-primOpTag (VecRemOp IntVec 32 W8) = 797-primOpTag (VecRemOp IntVec 16 W16) = 798-primOpTag (VecRemOp IntVec 8 W32) = 799-primOpTag (VecRemOp IntVec 4 W64) = 800-primOpTag (VecRemOp IntVec 64 W8) = 801-primOpTag (VecRemOp IntVec 32 W16) = 802-primOpTag (VecRemOp IntVec 16 W32) = 803-primOpTag (VecRemOp IntVec 8 W64) = 804-primOpTag (VecRemOp WordVec 16 W8) = 805-primOpTag (VecRemOp WordVec 8 W16) = 806-primOpTag (VecRemOp WordVec 4 W32) = 807-primOpTag (VecRemOp WordVec 2 W64) = 808-primOpTag (VecRemOp WordVec 32 W8) = 809-primOpTag (VecRemOp WordVec 16 W16) = 810-primOpTag (VecRemOp WordVec 8 W32) = 811-primOpTag (VecRemOp WordVec 4 W64) = 812-primOpTag (VecRemOp WordVec 64 W8) = 813-primOpTag (VecRemOp WordVec 32 W16) = 814-primOpTag (VecRemOp WordVec 16 W32) = 815-primOpTag (VecRemOp WordVec 8 W64) = 816-primOpTag (VecNegOp IntVec 16 W8) = 817-primOpTag (VecNegOp IntVec 8 W16) = 818-primOpTag (VecNegOp IntVec 4 W32) = 819-primOpTag (VecNegOp IntVec 2 W64) = 820-primOpTag (VecNegOp IntVec 32 W8) = 821-primOpTag (VecNegOp IntVec 16 W16) = 822-primOpTag (VecNegOp IntVec 8 W32) = 823-primOpTag (VecNegOp IntVec 4 W64) = 824-primOpTag (VecNegOp IntVec 64 W8) = 825-primOpTag (VecNegOp IntVec 32 W16) = 826-primOpTag (VecNegOp IntVec 16 W32) = 827-primOpTag (VecNegOp IntVec 8 W64) = 828-primOpTag (VecNegOp FloatVec 4 W32) = 829-primOpTag (VecNegOp FloatVec 2 W64) = 830-primOpTag (VecNegOp FloatVec 8 W32) = 831-primOpTag (VecNegOp FloatVec 4 W64) = 832-primOpTag (VecNegOp FloatVec 16 W32) = 833-primOpTag (VecNegOp FloatVec 8 W64) = 834-primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 835-primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 836-primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 837-primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 838-primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 839-primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 840-primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 841-primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 842-primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 843-primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 844-primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 845-primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 846-primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 847-primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 848-primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 849-primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 850-primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 851-primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 852-primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 853-primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 854-primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 855-primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 856-primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 857-primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 858-primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 859-primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 860-primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 861-primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 862-primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 863-primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 864-primOpTag (VecReadByteArrayOp IntVec 16 W8) = 865-primOpTag (VecReadByteArrayOp IntVec 8 W16) = 866-primOpTag (VecReadByteArrayOp IntVec 4 W32) = 867-primOpTag (VecReadByteArrayOp IntVec 2 W64) = 868-primOpTag (VecReadByteArrayOp IntVec 32 W8) = 869-primOpTag (VecReadByteArrayOp IntVec 16 W16) = 870-primOpTag (VecReadByteArrayOp IntVec 8 W32) = 871-primOpTag (VecReadByteArrayOp IntVec 4 W64) = 872-primOpTag (VecReadByteArrayOp IntVec 64 W8) = 873-primOpTag (VecReadByteArrayOp IntVec 32 W16) = 874-primOpTag (VecReadByteArrayOp IntVec 16 W32) = 875-primOpTag (VecReadByteArrayOp IntVec 8 W64) = 876-primOpTag (VecReadByteArrayOp WordVec 16 W8) = 877-primOpTag (VecReadByteArrayOp WordVec 8 W16) = 878-primOpTag (VecReadByteArrayOp WordVec 4 W32) = 879-primOpTag (VecReadByteArrayOp WordVec 2 W64) = 880-primOpTag (VecReadByteArrayOp WordVec 32 W8) = 881-primOpTag (VecReadByteArrayOp WordVec 16 W16) = 882-primOpTag (VecReadByteArrayOp WordVec 8 W32) = 883-primOpTag (VecReadByteArrayOp WordVec 4 W64) = 884-primOpTag (VecReadByteArrayOp WordVec 64 W8) = 885-primOpTag (VecReadByteArrayOp WordVec 32 W16) = 886-primOpTag (VecReadByteArrayOp WordVec 16 W32) = 887-primOpTag (VecReadByteArrayOp WordVec 8 W64) = 888-primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 889-primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 890-primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 891-primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 892-primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 893-primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 894-primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 895-primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 896-primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 897-primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 898-primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 899-primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 900-primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 901-primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 902-primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 903-primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 904-primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 905-primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 906-primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 907-primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 908-primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 909-primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 910-primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 911-primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 912-primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 913-primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 914-primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 915-primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 916-primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 917-primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 918-primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 919-primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 920-primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 921-primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 922-primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 923-primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 924-primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 925-primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 926-primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 927-primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 928-primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 929-primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 930-primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 931-primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 932-primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 933-primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 934-primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 935-primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 936-primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 937-primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 938-primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 939-primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 940-primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 941-primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 942-primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 943-primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 944-primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 945-primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 946-primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 947-primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 948-primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 949-primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 950-primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 951-primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 952-primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 953-primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 954-primOpTag (VecReadOffAddrOp IntVec 16 W8) = 955-primOpTag (VecReadOffAddrOp IntVec 8 W16) = 956-primOpTag (VecReadOffAddrOp IntVec 4 W32) = 957-primOpTag (VecReadOffAddrOp IntVec 2 W64) = 958-primOpTag (VecReadOffAddrOp IntVec 32 W8) = 959-primOpTag (VecReadOffAddrOp IntVec 16 W16) = 960-primOpTag (VecReadOffAddrOp IntVec 8 W32) = 961-primOpTag (VecReadOffAddrOp IntVec 4 W64) = 962-primOpTag (VecReadOffAddrOp IntVec 64 W8) = 963-primOpTag (VecReadOffAddrOp IntVec 32 W16) = 964-primOpTag (VecReadOffAddrOp IntVec 16 W32) = 965-primOpTag (VecReadOffAddrOp IntVec 8 W64) = 966-primOpTag (VecReadOffAddrOp WordVec 16 W8) = 967-primOpTag (VecReadOffAddrOp WordVec 8 W16) = 968-primOpTag (VecReadOffAddrOp WordVec 4 W32) = 969-primOpTag (VecReadOffAddrOp WordVec 2 W64) = 970-primOpTag (VecReadOffAddrOp WordVec 32 W8) = 971-primOpTag (VecReadOffAddrOp WordVec 16 W16) = 972-primOpTag (VecReadOffAddrOp WordVec 8 W32) = 973-primOpTag (VecReadOffAddrOp WordVec 4 W64) = 974-primOpTag (VecReadOffAddrOp WordVec 64 W8) = 975-primOpTag (VecReadOffAddrOp WordVec 32 W16) = 976-primOpTag (VecReadOffAddrOp WordVec 16 W32) = 977-primOpTag (VecReadOffAddrOp WordVec 8 W64) = 978-primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 979-primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 980-primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 981-primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 982-primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 983-primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 984-primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 985-primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 986-primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 987-primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 988-primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 989-primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 990-primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 991-primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 992-primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 993-primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 994-primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 995-primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 996-primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 997-primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 998-primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 999-primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 1000-primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 1001-primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 1002-primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 1003-primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 1004-primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 1005-primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 1006-primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1007-primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1008-primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1009-primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1010-primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1011-primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1012-primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1013-primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1014-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1015-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1016-primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1017-primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1018-primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1019-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1020-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1021-primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1022-primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1023-primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1024-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1025-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1026-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1027-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1028-primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1029-primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1030-primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1031-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1032-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1033-primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1034-primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1035-primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1036-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1037-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1038-primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1039-primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1040-primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1041-primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1042-primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1043-primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1044-primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1045-primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1046-primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1047-primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1048-primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1049-primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1050-primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1051-primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1052-primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1053-primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1054-primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1055-primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1056-primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1057-primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1058-primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1059-primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1060-primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1061-primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1062-primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1063-primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1064-primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1065-primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1066-primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1067-primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1068-primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1069-primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1070-primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1071-primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1072-primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1073-primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1074-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1075-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1076-primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1077-primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1078-primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1079-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1080-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1081-primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1082-primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1083-primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1084-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1085-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1086-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1087-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1088-primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1089-primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1090-primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1091-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1092-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1093-primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1094-primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1095-primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1096-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1097-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1098-primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1099-primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1100-primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1101-primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1102-primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1103-primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1104-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1105-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1106-primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1107-primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1108-primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1109-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1110-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1111-primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1112-primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1113-primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1114-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1115-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1116-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1117-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1118-primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1119-primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1120-primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1121-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1122-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1123-primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1124-primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1125-primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1126-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1127-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1128-primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1129-primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1130-primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1131-primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1132-primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1133-primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1134-primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1135-primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1136-primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1137-primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1138-primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1139-primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1140-primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1141-primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1142-primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1143-primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1144-primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1145-primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1146-primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1147-primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1148-primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1149-primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1150-primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1151-primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1152-primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1153-primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1154-primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1155-primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1156-primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1157-primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1158-primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1159-primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1160-primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1161-primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1162-primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1163-primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1164-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1165-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1166-primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1167-primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1168-primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1169-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1170-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1171-primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1172-primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1173-primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1174-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1175-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1176-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1177-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1178-primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1179-primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1180-primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1181-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1182-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1183-primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1184-primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1185-primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1186-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1187-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1188-primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1189-primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1190-primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1191-primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1192-primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1193-primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1194-primOpTag PrefetchByteArrayOp3 = 1195-primOpTag PrefetchMutableByteArrayOp3 = 1196-primOpTag PrefetchAddrOp3 = 1197-primOpTag PrefetchValueOp3 = 1198-primOpTag PrefetchByteArrayOp2 = 1199-primOpTag PrefetchMutableByteArrayOp2 = 1200-primOpTag PrefetchAddrOp2 = 1201-primOpTag PrefetchValueOp2 = 1202-primOpTag PrefetchByteArrayOp1 = 1203-primOpTag PrefetchMutableByteArrayOp1 = 1204-primOpTag PrefetchAddrOp1 = 1205-primOpTag PrefetchValueOp1 = 1206-primOpTag PrefetchByteArrayOp0 = 1207-primOpTag PrefetchMutableByteArrayOp0 = 1208-primOpTag PrefetchAddrOp0 = 1209-primOpTag PrefetchValueOp0 = 1210+maxPrimOpTag = 1212+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 IntToWordOp = 90+primOpTag IntToFloatOp = 91+primOpTag IntToDoubleOp = 92+primOpTag WordToFloatOp = 93+primOpTag WordToDoubleOp = 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 WordToIntOp = 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 DoubleToIntOp = 174+primOpTag DoubleToFloatOp = 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 FloatToIntOp = 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 FloatToDoubleOp = 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_Word8AsInt = 294+primOpTag IndexByteArrayOp_Word8AsWord = 295+primOpTag IndexByteArrayOp_Word8AsAddr = 296+primOpTag IndexByteArrayOp_Word8AsFloat = 297+primOpTag IndexByteArrayOp_Word8AsDouble = 298+primOpTag IndexByteArrayOp_Word8AsStablePtr = 299+primOpTag IndexByteArrayOp_Word8AsInt16 = 300+primOpTag IndexByteArrayOp_Word8AsInt32 = 301+primOpTag IndexByteArrayOp_Word8AsInt64 = 302+primOpTag IndexByteArrayOp_Word8AsWord16 = 303+primOpTag IndexByteArrayOp_Word8AsWord32 = 304+primOpTag IndexByteArrayOp_Word8AsWord64 = 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_Word8AsInt = 324+primOpTag ReadByteArrayOp_Word8AsWord = 325+primOpTag ReadByteArrayOp_Word8AsAddr = 326+primOpTag ReadByteArrayOp_Word8AsFloat = 327+primOpTag ReadByteArrayOp_Word8AsDouble = 328+primOpTag ReadByteArrayOp_Word8AsStablePtr = 329+primOpTag ReadByteArrayOp_Word8AsInt16 = 330+primOpTag ReadByteArrayOp_Word8AsInt32 = 331+primOpTag ReadByteArrayOp_Word8AsInt64 = 332+primOpTag ReadByteArrayOp_Word8AsWord16 = 333+primOpTag ReadByteArrayOp_Word8AsWord32 = 334+primOpTag ReadByteArrayOp_Word8AsWord64 = 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_Word8AsInt = 354+primOpTag WriteByteArrayOp_Word8AsWord = 355+primOpTag WriteByteArrayOp_Word8AsAddr = 356+primOpTag WriteByteArrayOp_Word8AsFloat = 357+primOpTag WriteByteArrayOp_Word8AsDouble = 358+primOpTag WriteByteArrayOp_Word8AsStablePtr = 359+primOpTag WriteByteArrayOp_Word8AsInt16 = 360+primOpTag WriteByteArrayOp_Word8AsInt32 = 361+primOpTag WriteByteArrayOp_Word8AsInt64 = 362+primOpTag WriteByteArrayOp_Word8AsWord16 = 363+primOpTag WriteByteArrayOp_Word8AsWord32 = 364+primOpTag WriteByteArrayOp_Word8AsWord64 = 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 AddrToIntOp = 402+primOpTag IntToAddrOp = 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 AtomicCompareExchange_Int = 460+primOpTag AtomicCompareExchange_Addr = 461+primOpTag NewMutVarOp = 462+primOpTag ReadMutVarOp = 463+primOpTag WriteMutVarOp = 464+primOpTag SameMutVarOp = 465+primOpTag AtomicModifyMutVar2Op = 466+primOpTag AtomicModifyMutVar_Op = 467+primOpTag CasMutVarOp = 468+primOpTag CatchOp = 469+primOpTag RaiseOp = 470+primOpTag RaiseIOOp = 471+primOpTag MaskAsyncExceptionsOp = 472+primOpTag MaskUninterruptibleOp = 473+primOpTag UnmaskAsyncExceptionsOp = 474+primOpTag MaskStatus = 475+primOpTag AtomicallyOp = 476+primOpTag RetryOp = 477+primOpTag CatchRetryOp = 478+primOpTag CatchSTMOp = 479+primOpTag NewTVarOp = 480+primOpTag ReadTVarOp = 481+primOpTag ReadTVarIOOp = 482+primOpTag WriteTVarOp = 483+primOpTag SameTVarOp = 484+primOpTag NewMVarOp = 485+primOpTag TakeMVarOp = 486+primOpTag TryTakeMVarOp = 487+primOpTag PutMVarOp = 488+primOpTag TryPutMVarOp = 489+primOpTag ReadMVarOp = 490+primOpTag TryReadMVarOp = 491+primOpTag SameMVarOp = 492+primOpTag IsEmptyMVarOp = 493+primOpTag NewIOPortrOp = 494+primOpTag ReadIOPortOp = 495+primOpTag WriteIOPortOp = 496+primOpTag SameIOPortOp = 497+primOpTag DelayOp = 498+primOpTag WaitReadOp = 499+primOpTag WaitWriteOp = 500+primOpTag ForkOp = 501+primOpTag ForkOnOp = 502+primOpTag KillThreadOp = 503+primOpTag YieldOp = 504+primOpTag MyThreadIdOp = 505+primOpTag LabelThreadOp = 506+primOpTag IsCurrentThreadBoundOp = 507+primOpTag NoDuplicateOp = 508+primOpTag ThreadStatusOp = 509+primOpTag MkWeakOp = 510+primOpTag MkWeakNoFinalizerOp = 511+primOpTag AddCFinalizerToWeakOp = 512+primOpTag DeRefWeakOp = 513+primOpTag FinalizeWeakOp = 514+primOpTag TouchOp = 515+primOpTag MakeStablePtrOp = 516+primOpTag DeRefStablePtrOp = 517+primOpTag EqStablePtrOp = 518+primOpTag MakeStableNameOp = 519+primOpTag EqStableNameOp = 520+primOpTag StableNameToIntOp = 521+primOpTag CompactNewOp = 522+primOpTag CompactResizeOp = 523+primOpTag CompactContainsOp = 524+primOpTag CompactContainsAnyOp = 525+primOpTag CompactGetFirstBlockOp = 526+primOpTag CompactGetNextBlockOp = 527+primOpTag CompactAllocateBlockOp = 528+primOpTag CompactFixupPointersOp = 529+primOpTag CompactAdd = 530+primOpTag CompactAddWithSharing = 531+primOpTag CompactSize = 532+primOpTag ReallyUnsafePtrEqualityOp = 533+primOpTag ParOp = 534+primOpTag SparkOp = 535+primOpTag SeqOp = 536+primOpTag GetSparkOp = 537+primOpTag NumSparks = 538+primOpTag DataToTagOp = 539+primOpTag TagToEnumOp = 540+primOpTag AddrToAnyOp = 541+primOpTag AnyToAddrOp = 542+primOpTag MkApUpd0_Op = 543+primOpTag NewBCOOp = 544+primOpTag UnpackClosureOp = 545+primOpTag ClosureSizeOp = 546+primOpTag GetApStackValOp = 547+primOpTag GetCCSOfOp = 548+primOpTag GetCurrentCCSOp = 549+primOpTag ClearCCSOp = 550+primOpTag TraceEventOp = 551+primOpTag TraceEventBinaryOp = 552+primOpTag TraceMarkerOp = 553+primOpTag SetThreadAllocationCounter = 554+primOpTag (VecBroadcastOp IntVec 16 W8) = 555+primOpTag (VecBroadcastOp IntVec 8 W16) = 556+primOpTag (VecBroadcastOp IntVec 4 W32) = 557+primOpTag (VecBroadcastOp IntVec 2 W64) = 558+primOpTag (VecBroadcastOp IntVec 32 W8) = 559+primOpTag (VecBroadcastOp IntVec 16 W16) = 560+primOpTag (VecBroadcastOp IntVec 8 W32) = 561+primOpTag (VecBroadcastOp IntVec 4 W64) = 562+primOpTag (VecBroadcastOp IntVec 64 W8) = 563+primOpTag (VecBroadcastOp IntVec 32 W16) = 564+primOpTag (VecBroadcastOp IntVec 16 W32) = 565+primOpTag (VecBroadcastOp IntVec 8 W64) = 566+primOpTag (VecBroadcastOp WordVec 16 W8) = 567+primOpTag (VecBroadcastOp WordVec 8 W16) = 568+primOpTag (VecBroadcastOp WordVec 4 W32) = 569+primOpTag (VecBroadcastOp WordVec 2 W64) = 570+primOpTag (VecBroadcastOp WordVec 32 W8) = 571+primOpTag (VecBroadcastOp WordVec 16 W16) = 572+primOpTag (VecBroadcastOp WordVec 8 W32) = 573+primOpTag (VecBroadcastOp WordVec 4 W64) = 574+primOpTag (VecBroadcastOp WordVec 64 W8) = 575+primOpTag (VecBroadcastOp WordVec 32 W16) = 576+primOpTag (VecBroadcastOp WordVec 16 W32) = 577+primOpTag (VecBroadcastOp WordVec 8 W64) = 578+primOpTag (VecBroadcastOp FloatVec 4 W32) = 579+primOpTag (VecBroadcastOp FloatVec 2 W64) = 580+primOpTag (VecBroadcastOp FloatVec 8 W32) = 581+primOpTag (VecBroadcastOp FloatVec 4 W64) = 582+primOpTag (VecBroadcastOp FloatVec 16 W32) = 583+primOpTag (VecBroadcastOp FloatVec 8 W64) = 584+primOpTag (VecPackOp IntVec 16 W8) = 585+primOpTag (VecPackOp IntVec 8 W16) = 586+primOpTag (VecPackOp IntVec 4 W32) = 587+primOpTag (VecPackOp IntVec 2 W64) = 588+primOpTag (VecPackOp IntVec 32 W8) = 589+primOpTag (VecPackOp IntVec 16 W16) = 590+primOpTag (VecPackOp IntVec 8 W32) = 591+primOpTag (VecPackOp IntVec 4 W64) = 592+primOpTag (VecPackOp IntVec 64 W8) = 593+primOpTag (VecPackOp IntVec 32 W16) = 594+primOpTag (VecPackOp IntVec 16 W32) = 595+primOpTag (VecPackOp IntVec 8 W64) = 596+primOpTag (VecPackOp WordVec 16 W8) = 597+primOpTag (VecPackOp WordVec 8 W16) = 598+primOpTag (VecPackOp WordVec 4 W32) = 599+primOpTag (VecPackOp WordVec 2 W64) = 600+primOpTag (VecPackOp WordVec 32 W8) = 601+primOpTag (VecPackOp WordVec 16 W16) = 602+primOpTag (VecPackOp WordVec 8 W32) = 603+primOpTag (VecPackOp WordVec 4 W64) = 604+primOpTag (VecPackOp WordVec 64 W8) = 605+primOpTag (VecPackOp WordVec 32 W16) = 606+primOpTag (VecPackOp WordVec 16 W32) = 607+primOpTag (VecPackOp WordVec 8 W64) = 608+primOpTag (VecPackOp FloatVec 4 W32) = 609+primOpTag (VecPackOp FloatVec 2 W64) = 610+primOpTag (VecPackOp FloatVec 8 W32) = 611+primOpTag (VecPackOp FloatVec 4 W64) = 612+primOpTag (VecPackOp FloatVec 16 W32) = 613+primOpTag (VecPackOp FloatVec 8 W64) = 614+primOpTag (VecUnpackOp IntVec 16 W8) = 615+primOpTag (VecUnpackOp IntVec 8 W16) = 616+primOpTag (VecUnpackOp IntVec 4 W32) = 617+primOpTag (VecUnpackOp IntVec 2 W64) = 618+primOpTag (VecUnpackOp IntVec 32 W8) = 619+primOpTag (VecUnpackOp IntVec 16 W16) = 620+primOpTag (VecUnpackOp IntVec 8 W32) = 621+primOpTag (VecUnpackOp IntVec 4 W64) = 622+primOpTag (VecUnpackOp IntVec 64 W8) = 623+primOpTag (VecUnpackOp IntVec 32 W16) = 624+primOpTag (VecUnpackOp IntVec 16 W32) = 625+primOpTag (VecUnpackOp IntVec 8 W64) = 626+primOpTag (VecUnpackOp WordVec 16 W8) = 627+primOpTag (VecUnpackOp WordVec 8 W16) = 628+primOpTag (VecUnpackOp WordVec 4 W32) = 629+primOpTag (VecUnpackOp WordVec 2 W64) = 630+primOpTag (VecUnpackOp WordVec 32 W8) = 631+primOpTag (VecUnpackOp WordVec 16 W16) = 632+primOpTag (VecUnpackOp WordVec 8 W32) = 633+primOpTag (VecUnpackOp WordVec 4 W64) = 634+primOpTag (VecUnpackOp WordVec 64 W8) = 635+primOpTag (VecUnpackOp WordVec 32 W16) = 636+primOpTag (VecUnpackOp WordVec 16 W32) = 637+primOpTag (VecUnpackOp WordVec 8 W64) = 638+primOpTag (VecUnpackOp FloatVec 4 W32) = 639+primOpTag (VecUnpackOp FloatVec 2 W64) = 640+primOpTag (VecUnpackOp FloatVec 8 W32) = 641+primOpTag (VecUnpackOp FloatVec 4 W64) = 642+primOpTag (VecUnpackOp FloatVec 16 W32) = 643+primOpTag (VecUnpackOp FloatVec 8 W64) = 644+primOpTag (VecInsertOp IntVec 16 W8) = 645+primOpTag (VecInsertOp IntVec 8 W16) = 646+primOpTag (VecInsertOp IntVec 4 W32) = 647+primOpTag (VecInsertOp IntVec 2 W64) = 648+primOpTag (VecInsertOp IntVec 32 W8) = 649+primOpTag (VecInsertOp IntVec 16 W16) = 650+primOpTag (VecInsertOp IntVec 8 W32) = 651+primOpTag (VecInsertOp IntVec 4 W64) = 652+primOpTag (VecInsertOp IntVec 64 W8) = 653+primOpTag (VecInsertOp IntVec 32 W16) = 654+primOpTag (VecInsertOp IntVec 16 W32) = 655+primOpTag (VecInsertOp IntVec 8 W64) = 656+primOpTag (VecInsertOp WordVec 16 W8) = 657+primOpTag (VecInsertOp WordVec 8 W16) = 658+primOpTag (VecInsertOp WordVec 4 W32) = 659+primOpTag (VecInsertOp WordVec 2 W64) = 660+primOpTag (VecInsertOp WordVec 32 W8) = 661+primOpTag (VecInsertOp WordVec 16 W16) = 662+primOpTag (VecInsertOp WordVec 8 W32) = 663+primOpTag (VecInsertOp WordVec 4 W64) = 664+primOpTag (VecInsertOp WordVec 64 W8) = 665+primOpTag (VecInsertOp WordVec 32 W16) = 666+primOpTag (VecInsertOp WordVec 16 W32) = 667+primOpTag (VecInsertOp WordVec 8 W64) = 668+primOpTag (VecInsertOp FloatVec 4 W32) = 669+primOpTag (VecInsertOp FloatVec 2 W64) = 670+primOpTag (VecInsertOp FloatVec 8 W32) = 671+primOpTag (VecInsertOp FloatVec 4 W64) = 672+primOpTag (VecInsertOp FloatVec 16 W32) = 673+primOpTag (VecInsertOp FloatVec 8 W64) = 674+primOpTag (VecAddOp IntVec 16 W8) = 675+primOpTag (VecAddOp IntVec 8 W16) = 676+primOpTag (VecAddOp IntVec 4 W32) = 677+primOpTag (VecAddOp IntVec 2 W64) = 678+primOpTag (VecAddOp IntVec 32 W8) = 679+primOpTag (VecAddOp IntVec 16 W16) = 680+primOpTag (VecAddOp IntVec 8 W32) = 681+primOpTag (VecAddOp IntVec 4 W64) = 682+primOpTag (VecAddOp IntVec 64 W8) = 683+primOpTag (VecAddOp IntVec 32 W16) = 684+primOpTag (VecAddOp IntVec 16 W32) = 685+primOpTag (VecAddOp IntVec 8 W64) = 686+primOpTag (VecAddOp WordVec 16 W8) = 687+primOpTag (VecAddOp WordVec 8 W16) = 688+primOpTag (VecAddOp WordVec 4 W32) = 689+primOpTag (VecAddOp WordVec 2 W64) = 690+primOpTag (VecAddOp WordVec 32 W8) = 691+primOpTag (VecAddOp WordVec 16 W16) = 692+primOpTag (VecAddOp WordVec 8 W32) = 693+primOpTag (VecAddOp WordVec 4 W64) = 694+primOpTag (VecAddOp WordVec 64 W8) = 695+primOpTag (VecAddOp WordVec 32 W16) = 696+primOpTag (VecAddOp WordVec 16 W32) = 697+primOpTag (VecAddOp WordVec 8 W64) = 698+primOpTag (VecAddOp FloatVec 4 W32) = 699+primOpTag (VecAddOp FloatVec 2 W64) = 700+primOpTag (VecAddOp FloatVec 8 W32) = 701+primOpTag (VecAddOp FloatVec 4 W64) = 702+primOpTag (VecAddOp FloatVec 16 W32) = 703+primOpTag (VecAddOp FloatVec 8 W64) = 704+primOpTag (VecSubOp IntVec 16 W8) = 705+primOpTag (VecSubOp IntVec 8 W16) = 706+primOpTag (VecSubOp IntVec 4 W32) = 707+primOpTag (VecSubOp IntVec 2 W64) = 708+primOpTag (VecSubOp IntVec 32 W8) = 709+primOpTag (VecSubOp IntVec 16 W16) = 710+primOpTag (VecSubOp IntVec 8 W32) = 711+primOpTag (VecSubOp IntVec 4 W64) = 712+primOpTag (VecSubOp IntVec 64 W8) = 713+primOpTag (VecSubOp IntVec 32 W16) = 714+primOpTag (VecSubOp IntVec 16 W32) = 715+primOpTag (VecSubOp IntVec 8 W64) = 716+primOpTag (VecSubOp WordVec 16 W8) = 717+primOpTag (VecSubOp WordVec 8 W16) = 718+primOpTag (VecSubOp WordVec 4 W32) = 719+primOpTag (VecSubOp WordVec 2 W64) = 720+primOpTag (VecSubOp WordVec 32 W8) = 721+primOpTag (VecSubOp WordVec 16 W16) = 722+primOpTag (VecSubOp WordVec 8 W32) = 723+primOpTag (VecSubOp WordVec 4 W64) = 724+primOpTag (VecSubOp WordVec 64 W8) = 725+primOpTag (VecSubOp WordVec 32 W16) = 726+primOpTag (VecSubOp WordVec 16 W32) = 727+primOpTag (VecSubOp WordVec 8 W64) = 728+primOpTag (VecSubOp FloatVec 4 W32) = 729+primOpTag (VecSubOp FloatVec 2 W64) = 730+primOpTag (VecSubOp FloatVec 8 W32) = 731+primOpTag (VecSubOp FloatVec 4 W64) = 732+primOpTag (VecSubOp FloatVec 16 W32) = 733+primOpTag (VecSubOp FloatVec 8 W64) = 734+primOpTag (VecMulOp IntVec 16 W8) = 735+primOpTag (VecMulOp IntVec 8 W16) = 736+primOpTag (VecMulOp IntVec 4 W32) = 737+primOpTag (VecMulOp IntVec 2 W64) = 738+primOpTag (VecMulOp IntVec 32 W8) = 739+primOpTag (VecMulOp IntVec 16 W16) = 740+primOpTag (VecMulOp IntVec 8 W32) = 741+primOpTag (VecMulOp IntVec 4 W64) = 742+primOpTag (VecMulOp IntVec 64 W8) = 743+primOpTag (VecMulOp IntVec 32 W16) = 744+primOpTag (VecMulOp IntVec 16 W32) = 745+primOpTag (VecMulOp IntVec 8 W64) = 746+primOpTag (VecMulOp WordVec 16 W8) = 747+primOpTag (VecMulOp WordVec 8 W16) = 748+primOpTag (VecMulOp WordVec 4 W32) = 749+primOpTag (VecMulOp WordVec 2 W64) = 750+primOpTag (VecMulOp WordVec 32 W8) = 751+primOpTag (VecMulOp WordVec 16 W16) = 752+primOpTag (VecMulOp WordVec 8 W32) = 753+primOpTag (VecMulOp WordVec 4 W64) = 754+primOpTag (VecMulOp WordVec 64 W8) = 755+primOpTag (VecMulOp WordVec 32 W16) = 756+primOpTag (VecMulOp WordVec 16 W32) = 757+primOpTag (VecMulOp WordVec 8 W64) = 758+primOpTag (VecMulOp FloatVec 4 W32) = 759+primOpTag (VecMulOp FloatVec 2 W64) = 760+primOpTag (VecMulOp FloatVec 8 W32) = 761+primOpTag (VecMulOp FloatVec 4 W64) = 762+primOpTag (VecMulOp FloatVec 16 W32) = 763+primOpTag (VecMulOp FloatVec 8 W64) = 764+primOpTag (VecDivOp FloatVec 4 W32) = 765+primOpTag (VecDivOp FloatVec 2 W64) = 766+primOpTag (VecDivOp FloatVec 8 W32) = 767+primOpTag (VecDivOp FloatVec 4 W64) = 768+primOpTag (VecDivOp FloatVec 16 W32) = 769+primOpTag (VecDivOp FloatVec 8 W64) = 770+primOpTag (VecQuotOp IntVec 16 W8) = 771+primOpTag (VecQuotOp IntVec 8 W16) = 772+primOpTag (VecQuotOp IntVec 4 W32) = 773+primOpTag (VecQuotOp IntVec 2 W64) = 774+primOpTag (VecQuotOp IntVec 32 W8) = 775+primOpTag (VecQuotOp IntVec 16 W16) = 776+primOpTag (VecQuotOp IntVec 8 W32) = 777+primOpTag (VecQuotOp IntVec 4 W64) = 778+primOpTag (VecQuotOp IntVec 64 W8) = 779+primOpTag (VecQuotOp IntVec 32 W16) = 780+primOpTag (VecQuotOp IntVec 16 W32) = 781+primOpTag (VecQuotOp IntVec 8 W64) = 782+primOpTag (VecQuotOp WordVec 16 W8) = 783+primOpTag (VecQuotOp WordVec 8 W16) = 784+primOpTag (VecQuotOp WordVec 4 W32) = 785+primOpTag (VecQuotOp WordVec 2 W64) = 786+primOpTag (VecQuotOp WordVec 32 W8) = 787+primOpTag (VecQuotOp WordVec 16 W16) = 788+primOpTag (VecQuotOp WordVec 8 W32) = 789+primOpTag (VecQuotOp WordVec 4 W64) = 790+primOpTag (VecQuotOp WordVec 64 W8) = 791+primOpTag (VecQuotOp WordVec 32 W16) = 792+primOpTag (VecQuotOp WordVec 16 W32) = 793+primOpTag (VecQuotOp WordVec 8 W64) = 794+primOpTag (VecRemOp IntVec 16 W8) = 795+primOpTag (VecRemOp IntVec 8 W16) = 796+primOpTag (VecRemOp IntVec 4 W32) = 797+primOpTag (VecRemOp IntVec 2 W64) = 798+primOpTag (VecRemOp IntVec 32 W8) = 799+primOpTag (VecRemOp IntVec 16 W16) = 800+primOpTag (VecRemOp IntVec 8 W32) = 801+primOpTag (VecRemOp IntVec 4 W64) = 802+primOpTag (VecRemOp IntVec 64 W8) = 803+primOpTag (VecRemOp IntVec 32 W16) = 804+primOpTag (VecRemOp IntVec 16 W32) = 805+primOpTag (VecRemOp IntVec 8 W64) = 806+primOpTag (VecRemOp WordVec 16 W8) = 807+primOpTag (VecRemOp WordVec 8 W16) = 808+primOpTag (VecRemOp WordVec 4 W32) = 809+primOpTag (VecRemOp WordVec 2 W64) = 810+primOpTag (VecRemOp WordVec 32 W8) = 811+primOpTag (VecRemOp WordVec 16 W16) = 812+primOpTag (VecRemOp WordVec 8 W32) = 813+primOpTag (VecRemOp WordVec 4 W64) = 814+primOpTag (VecRemOp WordVec 64 W8) = 815+primOpTag (VecRemOp WordVec 32 W16) = 816+primOpTag (VecRemOp WordVec 16 W32) = 817+primOpTag (VecRemOp WordVec 8 W64) = 818+primOpTag (VecNegOp IntVec 16 W8) = 819+primOpTag (VecNegOp IntVec 8 W16) = 820+primOpTag (VecNegOp IntVec 4 W32) = 821+primOpTag (VecNegOp IntVec 2 W64) = 822+primOpTag (VecNegOp IntVec 32 W8) = 823+primOpTag (VecNegOp IntVec 16 W16) = 824+primOpTag (VecNegOp IntVec 8 W32) = 825+primOpTag (VecNegOp IntVec 4 W64) = 826+primOpTag (VecNegOp IntVec 64 W8) = 827+primOpTag (VecNegOp IntVec 32 W16) = 828+primOpTag (VecNegOp IntVec 16 W32) = 829+primOpTag (VecNegOp IntVec 8 W64) = 830+primOpTag (VecNegOp FloatVec 4 W32) = 831+primOpTag (VecNegOp FloatVec 2 W64) = 832+primOpTag (VecNegOp FloatVec 8 W32) = 833+primOpTag (VecNegOp FloatVec 4 W64) = 834+primOpTag (VecNegOp FloatVec 16 W32) = 835+primOpTag (VecNegOp FloatVec 8 W64) = 836+primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 837+primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 838+primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 839+primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 840+primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 841+primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 842+primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 843+primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 844+primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 845+primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 846+primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 847+primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 848+primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 849+primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 850+primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 851+primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 852+primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 853+primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 854+primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 855+primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 856+primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 857+primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 858+primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 859+primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 860+primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 861+primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 862+primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 863+primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 864+primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 865+primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 866+primOpTag (VecReadByteArrayOp IntVec 16 W8) = 867+primOpTag (VecReadByteArrayOp IntVec 8 W16) = 868+primOpTag (VecReadByteArrayOp IntVec 4 W32) = 869+primOpTag (VecReadByteArrayOp IntVec 2 W64) = 870+primOpTag (VecReadByteArrayOp IntVec 32 W8) = 871+primOpTag (VecReadByteArrayOp IntVec 16 W16) = 872+primOpTag (VecReadByteArrayOp IntVec 8 W32) = 873+primOpTag (VecReadByteArrayOp IntVec 4 W64) = 874+primOpTag (VecReadByteArrayOp IntVec 64 W8) = 875+primOpTag (VecReadByteArrayOp IntVec 32 W16) = 876+primOpTag (VecReadByteArrayOp IntVec 16 W32) = 877+primOpTag (VecReadByteArrayOp IntVec 8 W64) = 878+primOpTag (VecReadByteArrayOp WordVec 16 W8) = 879+primOpTag (VecReadByteArrayOp WordVec 8 W16) = 880+primOpTag (VecReadByteArrayOp WordVec 4 W32) = 881+primOpTag (VecReadByteArrayOp WordVec 2 W64) = 882+primOpTag (VecReadByteArrayOp WordVec 32 W8) = 883+primOpTag (VecReadByteArrayOp WordVec 16 W16) = 884+primOpTag (VecReadByteArrayOp WordVec 8 W32) = 885+primOpTag (VecReadByteArrayOp WordVec 4 W64) = 886+primOpTag (VecReadByteArrayOp WordVec 64 W8) = 887+primOpTag (VecReadByteArrayOp WordVec 32 W16) = 888+primOpTag (VecReadByteArrayOp WordVec 16 W32) = 889+primOpTag (VecReadByteArrayOp WordVec 8 W64) = 890+primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 891+primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 892+primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 893+primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 894+primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 895+primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 896+primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 897+primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 898+primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 899+primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 900+primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 901+primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 902+primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 903+primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 904+primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 905+primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 906+primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 907+primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 908+primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 909+primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 910+primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 911+primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 912+primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 913+primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 914+primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 915+primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 916+primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 917+primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 918+primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 919+primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 920+primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 921+primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 922+primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 923+primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 924+primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 925+primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 926+primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 927+primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 928+primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 929+primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 930+primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 931+primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 932+primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 933+primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 934+primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 935+primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 936+primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 937+primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 938+primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 939+primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 940+primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 941+primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 942+primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 943+primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 944+primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 945+primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 946+primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 947+primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 948+primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 949+primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 950+primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 951+primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 952+primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 953+primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 954+primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 955+primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 956+primOpTag (VecReadOffAddrOp IntVec 16 W8) = 957+primOpTag (VecReadOffAddrOp IntVec 8 W16) = 958+primOpTag (VecReadOffAddrOp IntVec 4 W32) = 959+primOpTag (VecReadOffAddrOp IntVec 2 W64) = 960+primOpTag (VecReadOffAddrOp IntVec 32 W8) = 961+primOpTag (VecReadOffAddrOp IntVec 16 W16) = 962+primOpTag (VecReadOffAddrOp IntVec 8 W32) = 963+primOpTag (VecReadOffAddrOp IntVec 4 W64) = 964+primOpTag (VecReadOffAddrOp IntVec 64 W8) = 965+primOpTag (VecReadOffAddrOp IntVec 32 W16) = 966+primOpTag (VecReadOffAddrOp IntVec 16 W32) = 967+primOpTag (VecReadOffAddrOp IntVec 8 W64) = 968+primOpTag (VecReadOffAddrOp WordVec 16 W8) = 969+primOpTag (VecReadOffAddrOp WordVec 8 W16) = 970+primOpTag (VecReadOffAddrOp WordVec 4 W32) = 971+primOpTag (VecReadOffAddrOp WordVec 2 W64) = 972+primOpTag (VecReadOffAddrOp WordVec 32 W8) = 973+primOpTag (VecReadOffAddrOp WordVec 16 W16) = 974+primOpTag (VecReadOffAddrOp WordVec 8 W32) = 975+primOpTag (VecReadOffAddrOp WordVec 4 W64) = 976+primOpTag (VecReadOffAddrOp WordVec 64 W8) = 977+primOpTag (VecReadOffAddrOp WordVec 32 W16) = 978+primOpTag (VecReadOffAddrOp WordVec 16 W32) = 979+primOpTag (VecReadOffAddrOp WordVec 8 W64) = 980+primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 981+primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 982+primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 983+primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 984+primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 985+primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 986+primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 987+primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 988+primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 989+primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 990+primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 991+primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 992+primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 993+primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 994+primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 995+primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 996+primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 997+primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 998+primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 999+primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 1000+primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 1001+primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 1002+primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 1003+primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 1004+primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 1005+primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 1006+primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 1007+primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 1008+primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1009+primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1010+primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1011+primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1012+primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1013+primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1014+primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1015+primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1016+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1017+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1018+primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1019+primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1020+primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1021+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1022+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1023+primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1024+primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1025+primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1026+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1027+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1028+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1029+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1030+primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1031+primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1032+primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1033+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1034+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1035+primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1036+primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1037+primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1038+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1039+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1040+primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1041+primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1042+primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1043+primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1044+primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1045+primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1046+primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1047+primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1048+primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1049+primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1050+primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1051+primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1052+primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1053+primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1054+primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1055+primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1056+primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1057+primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1058+primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1059+primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1060+primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1061+primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1062+primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1063+primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1064+primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1065+primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1066+primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1067+primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1068+primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1069+primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1070+primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1071+primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1072+primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1073+primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1074+primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1075+primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1076+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1077+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1078+primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1079+primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1080+primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1081+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1082+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1083+primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1084+primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1085+primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1086+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1087+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1088+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1089+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1090+primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1091+primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1092+primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1093+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1094+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1095+primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1096+primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1097+primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1098+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1099+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1100+primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1101+primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1102+primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1103+primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1104+primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1105+primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1106+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1107+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1108+primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1109+primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1110+primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1111+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1112+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1113+primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1114+primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1115+primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1116+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1117+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1118+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1119+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1120+primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1121+primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1122+primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1123+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1124+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1125+primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1126+primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1127+primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1128+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1129+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1130+primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1131+primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1132+primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1133+primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1134+primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1135+primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1136+primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1137+primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1138+primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1139+primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1140+primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1141+primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1142+primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1143+primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1144+primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1145+primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1146+primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1147+primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1148+primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1149+primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1150+primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1151+primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1152+primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1153+primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1154+primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1155+primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1156+primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1157+primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1158+primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1159+primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1160+primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1161+primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1162+primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1163+primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1164+primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1165+primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1166+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1167+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1168+primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1169+primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1170+primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1171+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1172+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1173+primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1174+primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1175+primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1176+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1177+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1178+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1179+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1180+primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1181+primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1182+primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1183+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1184+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1185+primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1186+primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1187+primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1188+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1189+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1190+primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1191+primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1192+primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1193+primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1194+primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1195+primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1196+primOpTag PrefetchByteArrayOp3 = 1197+primOpTag PrefetchMutableByteArrayOp3 = 1198+primOpTag PrefetchAddrOp3 = 1199+primOpTag PrefetchValueOp3 = 1200+primOpTag PrefetchByteArrayOp2 = 1201+primOpTag PrefetchMutableByteArrayOp2 = 1202+primOpTag PrefetchAddrOp2 = 1203+primOpTag PrefetchValueOp2 = 1204+primOpTag PrefetchByteArrayOp1 = 1205+primOpTag PrefetchMutableByteArrayOp1 = 1206+primOpTag PrefetchAddrOp1 = 1207+primOpTag PrefetchValueOp1 = 1208+primOpTag PrefetchByteArrayOp0 = 1209+primOpTag PrefetchMutableByteArrayOp0 = 1210+primOpTag PrefetchAddrOp0 = 1211+primOpTag PrefetchValueOp0 = 1212
ghc-lib/stage0/lib/ghcautoconf.h view
@@ -541,7 +541,7 @@ /* #undef pid_t */ /* The supported LLVM version number */-#define sUPPORTED_LLVM_VERSION (9)+#define sUPPORTED_LLVM_VERSION (10) /* Define to `unsigned int' if <sys/types.h> does not define. */ /* #undef size_t */
ghc-lib/stage0/lib/ghcversion.h view
@@ -5,11 +5,11 @@ #define __GLASGOW_HASKELL__ 901 #endif #if !defined(__GLASGOW_HASKELL_FULL_VERSION__)-#define __GLASGOW_HASKELL_FULL_VERSION__ "9.1.0.20201001"+#define __GLASGOW_HASKELL_FULL_VERSION__ "9.1.0.20201101" #endif #define __GLASGOW_HASKELL_PATCHLEVEL1__ 0-#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20201001+#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20201101 #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\ ((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \
ghc-lib/stage0/lib/settings view
@@ -47,7 +47,5 @@ ,("Tables next to code", "YES") ,("Leading underscore", "YES") ,("Use LibFFI", "NO")-,("Use Threads", "YES")-,("Use Debugging", "NO") ,("RTS expects libdw", "NO") ]