ghc-lib 0.20200704 → 0.20200801
raw patch · 172 files changed
+6184/−5440 lines, 172 filesdep ~basedep ~ghc-lib-parser
Dependency ranges changed: base, ghc-lib-parser
Files
- compiler/GHC.hs +8/−7
- compiler/GHC/Builtin/Names/TH.hs +24/−34
- compiler/GHC/Builtin/RebindableNames.hs +6/−0
- compiler/GHC/Builtin/Utils.hs +8/−3
- compiler/GHC/ByteCode/InfoTable.hs +9/−6
- compiler/GHC/Cmm/CallConv.hs +64/−62
- compiler/GHC/Cmm/Graph.hs +43/−42
- compiler/GHC/Cmm/Info.hs +90/−86
- compiler/GHC/Cmm/Info/Build.hs +81/−75
- compiler/GHC/Cmm/LayoutStack.hs +13/−10
- compiler/GHC/Cmm/Monad.hs +22/−0
- compiler/GHC/Cmm/Parser.y +74/−75
- compiler/GHC/Cmm/Pipeline.hs +8/−8
- compiler/GHC/Cmm/ProcPoint.hs +1/−1
- compiler/GHC/Cmm/Sink.hs +2/−2
- compiler/GHC/Cmm/Switch/Implement.hs +1/−1
- compiler/GHC/Cmm/Utils.hs +14/−12
- compiler/GHC/CmmToAsm.hs +5/−4
- compiler/GHC/CmmToAsm/BlockLayout.hs +2/−3
- compiler/GHC/CmmToAsm/Dwarf/Types.hs +13/−7
- compiler/GHC/CmmToAsm/Monad.hs +1/−3
- compiler/GHC/CmmToAsm/PIC.hs +28/−34
- compiler/GHC/CmmToAsm/Reg/Graph.hs +2/−2
- compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs +2/−2
- compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs +13/−9
- compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs +15/−19
- compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs +3/−3
- compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs +3/−3
- compiler/GHC/CmmToAsm/Reg/Linear.hs +39/−24
- compiler/GHC/CmmToAsm/Reg/Linear/Base.hs +3/−1
- compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs +2/−2
- compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs +2/−1
- compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs +5/−2
- compiler/GHC/CmmToAsm/Reg/Liveness.hs +21/−10
- compiler/GHC/CmmToAsm/Reg/Utils.hs +59/−0
- compiler/GHC/CmmToAsm/X86/RegInfo.hs +4/−4
- compiler/GHC/CmmToC.hs +113/−134
- compiler/GHC/CmmToLlvm.hs +2/−2
- compiler/GHC/CmmToLlvm/Base.hs +8/−7
- compiler/GHC/CmmToLlvm/CodeGen.hs +34/−1
- compiler/GHC/Core/Opt/DmdAnal.hs +22/−3
- compiler/GHC/Core/Opt/SetLevels.hs +10/−2
- compiler/GHC/Core/Opt/Simplify.hs +258/−226
- compiler/GHC/Core/Opt/Simplify/Env.hs +121/−43
- compiler/GHC/Core/Opt/Simplify/Monad.hs +18/−6
- compiler/GHC/Core/Opt/Simplify/Utils.hs +242/−134
- compiler/GHC/Core/Opt/SpecConstr.hs +1/−1
- compiler/GHC/Core/Opt/Specialise.hs +2/−2
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs +2/−3
- compiler/GHC/Core/Ppr/TyThing.hs +2/−1
- compiler/GHC/Core/Tidy.hs +2/−1
- compiler/GHC/CoreToByteCode.hs +33/−27
- compiler/GHC/CoreToStg.hs +2/−2
- compiler/GHC/CoreToStg/Prep.hs +1/−1
- compiler/GHC/Data/Graph/Base.hs +2/−2
- compiler/GHC/Data/Graph/Color.hs +17/−8
- compiler/GHC/Data/Graph/Ops.hs +5/−5
- compiler/GHC/Driver/Backpack.hs +6/−6
- compiler/GHC/Driver/CodeOutput.hs +12/−13
- compiler/GHC/Driver/Finder.hs +1/−1
- compiler/GHC/Driver/Main.hs +15/−14
- compiler/GHC/Driver/Make.hs +84/−85
- compiler/GHC/Driver/Pipeline.hs +52/−36
- compiler/GHC/Hs/Stats.hs +1/−1
- compiler/GHC/HsToCore.hs +7/−6
- compiler/GHC/HsToCore/Binds.hs +1/−0
- compiler/GHC/HsToCore/Coverage.hs +15/−10
- compiler/GHC/HsToCore/Docs.hs +21/−19
- compiler/GHC/HsToCore/Expr.hs +6/−9
- compiler/GHC/HsToCore/Match.hs +5/−2
- compiler/GHC/HsToCore/Match/Literal.hs +26/−6
- compiler/GHC/HsToCore/Monad.hs +5/−2
- compiler/GHC/HsToCore/PmCheck/Oracle.hs +1/−1
- compiler/GHC/HsToCore/PmCheck/Ppr.hs +1/−1
- compiler/GHC/HsToCore/Quote.hs +6/−7
- compiler/GHC/HsToCore/Usage.hs +1/−1
- compiler/GHC/HsToCore/Utils.hs +2/−3
- compiler/GHC/Iface/Binary.hs +47/−55
- compiler/GHC/Iface/Ext/Ast.hs +67/−65
- compiler/GHC/Iface/Ext/Binary.hs +9/−7
- compiler/GHC/Iface/Load.hs +13/−7
- compiler/GHC/Iface/Make.hs +13/−10
- compiler/GHC/Iface/Recomp.hs +2/−1
- compiler/GHC/Iface/Tidy.hs +3/−2
- compiler/GHC/Rename/Bind.hs +15/−9
- compiler/GHC/Rename/Env.hs +28/−1
- compiler/GHC/Rename/Expr.hs +38/−8
- compiler/GHC/Rename/HsType.hs +10/−39
- compiler/GHC/Rename/Module.hs +145/−125
- compiler/GHC/Rename/Names.hs +17/−10
- compiler/GHC/Rename/Pat.hs +21/−10
- compiler/GHC/Rename/Splice.hs +63/−0
- compiler/GHC/Rename/Utils.hs +135/−1
- compiler/GHC/Runtime/Eval.hs +1/−1
- compiler/GHC/Runtime/Heap/Inspect.hs +15/−14
- compiler/GHC/Runtime/Interpreter.hs +1/−1
- compiler/GHC/Runtime/Linker.hs +63/−16
- compiler/GHC/Settings/IO.hs +39/−6
- compiler/GHC/Stg/DepAnal.hs +5/−2
- compiler/GHC/Stg/Lift.hs +1/−1
- compiler/GHC/Stg/Lift/Analysis.hs +8/−5
- compiler/GHC/Stg/Lint.hs +49/−37
- compiler/GHC/Stg/Pipeline.hs +3/−2
- compiler/GHC/Stg/Unarise.hs +14/−6
- compiler/GHC/StgToCmm.hs +13/−12
- compiler/GHC/StgToCmm/Bind.hs +69/−59
- compiler/GHC/StgToCmm/CgUtils.hs +90/−89
- compiler/GHC/StgToCmm/Closure.hs +76/−73
- compiler/GHC/StgToCmm/DataCon.hs +31/−22
- compiler/GHC/StgToCmm/Env.hs +8/−10
- compiler/GHC/StgToCmm/Expr.hs +23/−22
- compiler/GHC/StgToCmm/ExtCode.hs +17/−4
- compiler/GHC/StgToCmm/Foreign.hs +98/−94
- compiler/GHC/StgToCmm/Heap.hs +36/−32
- compiler/GHC/StgToCmm/Layout.hs +35/−32
- compiler/GHC/StgToCmm/Monad.hs +35/−9
- compiler/GHC/StgToCmm/Prim.hs +479/−477
- compiler/GHC/StgToCmm/Prof.hs +67/−77
- compiler/GHC/StgToCmm/Ticky.hs +17/−17
- compiler/GHC/StgToCmm/Utils.hs +12/−14
- compiler/GHC/SysTools.hs +4/−2
- compiler/GHC/SysTools/Info.hs +1/−1
- compiler/GHC/SysTools/Tasks.hs +1/−1
- compiler/GHC/Tc/Deriv.hs +5/−2
- compiler/GHC/Tc/Deriv/Functor.hs +12/−12
- compiler/GHC/Tc/Deriv/Generate.hs +123/−34
- compiler/GHC/Tc/Deriv/Infer.hs +1/−3
- compiler/GHC/Tc/Deriv/Utils.hs +13/−10
- compiler/GHC/Tc/Gen/Expr.hs +27/−27
- compiler/GHC/Tc/Gen/Foreign.hs +25/−20
- compiler/GHC/Tc/Gen/HsType.hs +4/−2
- compiler/GHC/Tc/Gen/Match.hs +25/−58
- compiler/GHC/Tc/Gen/Pat.hs +17/−20
- compiler/GHC/Tc/Gen/Sig.hs +7/−6
- compiler/GHC/Tc/Gen/Splice.hs +5/−5
- compiler/GHC/Tc/Instance/Class.hs +3/−2
- compiler/GHC/Tc/Instance/Family.hs +1/−1
- compiler/GHC/Tc/Module.hs +4/−4
- compiler/GHC/Tc/Solver/Flatten.hs +5/−2
- compiler/GHC/Tc/Solver/Monad.hs +8/−8
- compiler/GHC/Tc/TyCl.hs +27/−11
- compiler/GHC/Tc/TyCl/Build.hs +3/−4
- compiler/GHC/Tc/TyCl/Class.hs +2/−1
- compiler/GHC/Tc/TyCl/PatSyn.hs +3/−3
- compiler/GHC/Tc/Utils/Env.hs +2/−1
- compiler/GHC/Tc/Utils/Instantiate.hs +189/−8
- compiler/GHC/Tc/Utils/Monad.hs +54/−13
- compiler/GHC/Tc/Utils/TcMType.hs +270/−211
- compiler/GHC/Tc/Utils/Unify.hs +70/−249
- compiler/GHC/Tc/Utils/Zonk.hs +10/−8
- compiler/GHC/ThToHs.hs +1/−1
- ghc-lib.cabal +12/−9
- ghc-lib/stage0/compiler/build/GHC/Platform/Constants.hs +135/−0
- ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl +4/−0
- ghc-lib/stage0/compiler/build/primop-docs.hs-incl +4/−0
- ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl +3/−0
- ghc-lib/stage0/compiler/build/primop-list.hs-incl +4/−0
- ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl +3/−0
- ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl +4/−0
- ghc-lib/stage0/compiler/build/primop-tag.hs-incl +1212/−1208
- ghc-lib/stage0/lib/DerivedConstants.h +4/−4
- ghc-lib/stage0/lib/GHCConstantsHaskellExports.hs +0/−123
- ghc-lib/stage0/lib/GHCConstantsHaskellType.hs +0/−131
- ghc-lib/stage0/lib/GHCConstantsHaskellWrappers.hs +0/−246
- ghc-lib/stage0/lib/ghcautoconf.h +3/−0
- ghc-lib/stage0/lib/ghcversion.h +2/−2
- ghc-lib/stage0/lib/settings +0/−1
- ghc-lib/stage0/libraries/ghc-boot/build/GHC/Platform/Host.hs +7/−10
- libraries/ghc-boot/GHC/Settings/Platform.hs +0/−99
- libraries/ghc-boot/GHC/Settings/Utils.hs +57/−0
- libraries/ghci/GHCi/ResolvedBCO.hs +2/−2
- libraries/template-haskell/Language/Haskell/TH/CodeDo.hs +20/−0
compiler/GHC.hs view
@@ -27,8 +27,8 @@ needsTemplateHaskellOrQQ, -- * Flags and settings- DynFlags(..), GeneralFlag(..), Severity(..), HscTarget(..), gopt,- GhcMode(..), GhcLink(..), defaultObjectTarget,+ DynFlags(..), GeneralFlag(..), Severity(..), Backend(..), gopt,+ GhcMode(..), GhcLink(..), parseDynamicFlags, getSessionDynFlags, setSessionDynFlags, getProgramDynFlags, setProgramDynFlags, setLogAction,@@ -302,6 +302,7 @@ import GHCi.RemoteTypes import GHC.Core.Ppr.TyThing ( pprFamInst )+import GHC.Driver.Backend import GHC.Driver.Main import GHC.Driver.Make import GHC.Driver.Hooks@@ -336,7 +337,7 @@ import GHC.Driver.Types import GHC.Driver.CmdLine import GHC.Driver.Session hiding (WarnReason(..))-import GHC.Driver.Ways+import GHC.Platform.Ways import GHC.SysTools import GHC.SysTools.BaseDir import GHC.Types.Annotations@@ -1012,7 +1013,7 @@ -- -- A module must be loaded before dependent modules can be typechecked. This -- always includes generating a 'ModIface' and, depending on the--- @DynFlags@\'s 'GHC.Driver.Session.hscTarget', may also include code generation.+-- @DynFlags@\'s 'GHC.Driver.Session.backend', may also include code generation. -- -- This function will always cause recompilation and will always overwrite -- previous compilation results (potentially files on disk).@@ -1682,11 +1683,11 @@ where -- Loading environments (by name or by location) - platformArchOs = platformMini (targetPlatform dflags)+ archOS = platformArchOS (targetPlatform dflags) namedEnvPath :: String -> MaybeT IO FilePath namedEnvPath name = do- appdir <- versionedAppDir (programName dflags) platformArchOs+ appdir <- versionedAppDir (programName dflags) archOS return $ appdir </> "environments" </> name probeEnvName :: String -> MaybeT IO FilePath@@ -1723,7 +1724,7 @@ -- e.g. .ghc.environment.x86_64-linux-7.6.3 localEnvFileName :: FilePath- localEnvFileName = ".ghc.environment" <.> versionedFilePath platformArchOs+ localEnvFileName = ".ghc.environment" <.> versionedFilePath archOS -- Search for an env file, starting in the current dir and looking upwards. -- Fail if we get to the users home dir or the filesystem root. That is,
compiler/GHC/Builtin/Names/TH.hs view
@@ -32,9 +32,8 @@ mkNameSName, mkModNameName, liftStringName,- unTypeName,- unTypeQName,- unsafeTExpCoerceName,+ unTypeName, unTypeCodeName,+ unsafeCodeCoerceName, -- Lit charLName, stringLName, integerLName, intPrimLName, wordPrimLName,@@ -135,8 +134,6 @@ -- DerivStrategy stockStrategyName, anyclassStrategyName, newtypeStrategyName, viaStrategyName,- -- TExp- tExpDataConName, -- RuleBndr ruleVarName, typedRuleVarName, -- FunDep@@ -159,7 +156,7 @@ typeTyConName, tyVarBndrUnitTyConName, tyVarBndrSpecTyConName, clauseTyConName, patQTyConName, funDepTyConName, decsQTyConName, ruleBndrTyConName, tySynEqnTyConName,- roleTyConName, tExpTyConName, injAnnTyConName, kindTyConName,+ roleTyConName, codeTyConName, injAnnTyConName, kindTyConName, overlapTyConName, derivClauseTyConName, derivStrategyTyConName, modNameTyConName, @@ -193,7 +190,7 @@ qTyConName, nameTyConName, fieldExpTyConName, patTyConName, fieldPatTyConName, expTyConName, decTyConName, typeTyConName, matchTyConName, clauseTyConName, funDepTyConName, predTyConName,- tExpTyConName, injAnnTyConName, overlapTyConName, decsTyConName,+ codeTyConName, injAnnTyConName, overlapTyConName, decsTyConName, modNameTyConName :: Name qTyConName = thTc (fsLit "Q") qTyConKey nameTyConName = thTc (fsLit "Name") nameTyConKey@@ -208,15 +205,15 @@ clauseTyConName = thTc (fsLit "Clause") clauseTyConKey funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey predTyConName = thTc (fsLit "Pred") predTyConKey-tExpTyConName = thTc (fsLit "TExp") tExpTyConKey+codeTyConName = thTc (fsLit "Code") codeTyConKey injAnnTyConName = thTc (fsLit "InjectivityAnn") injAnnTyConKey overlapTyConName = thTc (fsLit "Overlap") overlapTyConKey modNameTyConName = thTc (fsLit "ModName") modNameTyConKey returnQName, bindQName, sequenceQName, newNameName, liftName, mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,- mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeQName,- unsafeTExpCoerceName, liftTypedName, mkModNameName :: Name+ mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeCodeName,+ unsafeCodeCoerceName, liftTypedName, mkModNameName :: Name returnQName = thFun (fsLit "returnQ") returnQIdKey bindQName = thFun (fsLit "bindQ") bindQIdKey sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey@@ -231,8 +228,8 @@ mkNameSName = thFun (fsLit "mkNameS") mkNameSIdKey mkModNameName = thFun (fsLit "mkModName") mkModNameIdKey unTypeName = thFun (fsLit "unType") unTypeIdKey-unTypeQName = thFun (fsLit "unTypeQ") unTypeQIdKey-unsafeTExpCoerceName = thFun (fsLit "unsafeTExpCoerce") unsafeTExpCoerceIdKey+unTypeCodeName = thFun (fsLit "unTypeCode") unTypeCodeIdKey+unsafeCodeCoerceName = thFun (fsLit "unsafeCodeCoerce") unsafeCodeCoerceIdKey liftTypedName = thFun (fsLit "liftTyped") liftTypedIdKey @@ -525,10 +522,6 @@ safeName = libFun (fsLit "safe") safeIdKey interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey --- newtype TExp a = ...-tExpDataConName :: Name-tExpDataConName = thCon (fsLit "TExp") tExpDataConKey- -- data RuleBndr = ... ruleVarName, typedRuleVarName :: Name ruleVarName = libFun (fsLit ("ruleVar")) ruleVarIdKey@@ -653,7 +646,7 @@ fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey, funDepTyConKey, predTyConKey, predQTyConKey, decsQTyConKey, ruleBndrTyConKey, tySynEqnTyConKey,- roleTyConKey, tExpTyConKey, injAnnTyConKey, kindTyConKey,+ roleTyConKey, codeTyConKey, injAnnTyConKey, kindTyConKey, overlapTyConKey, derivClauseTyConKey, derivStrategyTyConKey, decsTyConKey, modNameTyConKey :: Unique expTyConKey = mkPreludeTyConUnique 200@@ -667,7 +660,7 @@ typeQTyConKey = mkPreludeTyConUnique 211 typeTyConKey = mkPreludeTyConUnique 212 decTyConKey = mkPreludeTyConUnique 213-bangTypeTyConKey = mkPreludeTyConUnique 214+bangTypeTyConKey = mkPreludeTyConUnique 214 varBangTypeTyConKey = mkPreludeTyConUnique 215 fieldExpTyConKey = mkPreludeTyConUnique 216 fieldPatTyConKey = mkPreludeTyConUnique 217@@ -677,19 +670,19 @@ predTyConKey = mkPreludeTyConUnique 223 predQTyConKey = mkPreludeTyConUnique 224 tyVarBndrUnitTyConKey = mkPreludeTyConUnique 225-tyVarBndrSpecTyConKey = mkPreludeTyConUnique 237 decsQTyConKey = mkPreludeTyConUnique 226-ruleBndrTyConKey = mkPreludeTyConUnique 227+ruleBndrTyConKey = mkPreludeTyConUnique 227 tySynEqnTyConKey = mkPreludeTyConUnique 228 roleTyConKey = mkPreludeTyConUnique 229-tExpTyConKey = mkPreludeTyConUnique 230 injAnnTyConKey = mkPreludeTyConUnique 231-kindTyConKey = mkPreludeTyConUnique 232+kindTyConKey = mkPreludeTyConUnique 232 overlapTyConKey = mkPreludeTyConUnique 233-derivClauseTyConKey = mkPreludeTyConUnique 234-derivStrategyTyConKey = mkPreludeTyConUnique 235+derivClauseTyConKey = mkPreludeTyConUnique 234+derivStrategyTyConKey = mkPreludeTyConUnique 235 decsTyConKey = mkPreludeTyConUnique 236-modNameTyConKey = mkPreludeTyConUnique 238+tyVarBndrSpecTyConKey = mkPreludeTyConUnique 237+codeTyConKey = mkPreludeTyConUnique 238+modNameTyConKey = mkPreludeTyConUnique 239 {- ********************************************************************* * *@@ -717,10 +710,6 @@ fromPhaseDataConKey = mkPreludeDataConUnique 206 beforePhaseDataConKey = mkPreludeDataConUnique 207 --- newtype TExp a = ...-tExpDataConKey :: Unique-tExpDataConKey = mkPreludeDataConUnique 208- -- data Overlap = .. overlappableDataConKey, overlappingDataConKey,@@ -742,8 +731,8 @@ returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey, mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,- mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeQIdKey,- unsafeTExpCoerceIdKey, liftTypedIdKey, mkModNameIdKey :: Unique+ mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeCodeIdKey,+ unsafeCodeCoerceIdKey, liftTypedIdKey, mkModNameIdKey :: Unique returnQIdKey = mkPreludeMiscIdUnique 200 bindQIdKey = mkPreludeMiscIdUnique 201 sequenceQIdKey = mkPreludeMiscIdUnique 202@@ -756,10 +745,10 @@ mkNameLIdKey = mkPreludeMiscIdUnique 209 mkNameSIdKey = mkPreludeMiscIdUnique 210 unTypeIdKey = mkPreludeMiscIdUnique 211-unTypeQIdKey = mkPreludeMiscIdUnique 212-unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 213+unTypeCodeIdKey = mkPreludeMiscIdUnique 212 liftTypedIdKey = mkPreludeMiscIdUnique 214 mkModNameIdKey = mkPreludeMiscIdUnique 215+unsafeCodeCoerceIdKey = mkPreludeMiscIdUnique 216 -- data Lit = ...@@ -1105,9 +1094,10 @@ ************************************************************************ -} -lift_RDR, liftTyped_RDR, mkNameG_dRDR, mkNameG_vRDR :: RdrName+lift_RDR, liftTyped_RDR, mkNameG_dRDR, mkNameG_vRDR, unsafeCodeCoerce_RDR :: RdrName lift_RDR = nameRdrName liftName liftTyped_RDR = nameRdrName liftTypedName+unsafeCodeCoerce_RDR = nameRdrName unsafeCodeCoerceName mkNameG_dRDR = nameRdrName mkNameG_dName mkNameG_vRDR = nameRdrName mkNameG_vName
+ compiler/GHC/Builtin/RebindableNames.hs view
@@ -0,0 +1,6 @@+module GHC.Builtin.RebindableNames where++import GHC.Data.FastString++reboundIfSymbol :: FastString+reboundIfSymbol = fsLit "ifThenElse"
compiler/GHC/Builtin/Utils.hs view
@@ -198,15 +198,20 @@ -- known-key thing. lookupKnownKeyName :: Unique -> Maybe Name lookupKnownKeyName u =- knownUniqueName u <|> lookupUFM knownKeysMap u+ knownUniqueName u <|> lookupUFM_Directly knownKeysMap u -- | Is a 'Name' known-key? isKnownKeyName :: Name -> Bool isKnownKeyName n = isJust (knownUniqueName $ nameUnique n) || elemUFM n knownKeysMap -knownKeysMap :: UniqFM Name-knownKeysMap = listToUFM [ (nameUnique n, n) | n <- knownKeyNames ]+-- | Maps 'Unique's to known-key names.+--+-- The type is @UniqFM Name Name@ to denote that the 'Unique's used+-- in the domain are 'Unique's associated with 'Name's (as opposed+-- to some other namespace of 'Unique's).+knownKeysMap :: UniqFM Name Name+knownKeysMap = listToIdentityUFM knownKeyNames -- | Given a 'Unique' lookup any associated arbitrary SDoc's to be displayed by -- GHCi's ':info' command.
compiler/GHC/ByteCode/InfoTable.hs view
@@ -12,6 +12,8 @@ import GHC.Prelude import GHC.Platform+import GHC.Platform.Profile+ import GHC.ByteCode.Types import GHC.Runtime.Interpreter import GHC.Driver.Session@@ -54,7 +56,7 @@ make_constr_itbls hsc_env cons = mkItblEnv <$> mapM (uncurry mk_itbl) (zip cons [0..]) where- dflags = hsc_dflags hsc_env+ profile = targetProfile (hsc_dflags hsc_env) mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr) mk_itbl dcon conNo = do@@ -63,19 +65,20 @@ , prim_rep <- typePrimRep (scaledThing arg) ] (tot_wds, ptr_wds) =- mkVirtConstrSizes dflags rep_args+ mkVirtConstrSizes profile rep_args ptrs' = ptr_wds nptrs' = tot_wds - ptr_wds nptrs_really- | ptrs' + nptrs' >= mIN_PAYLOAD_SIZE dflags = nptrs'- | otherwise = mIN_PAYLOAD_SIZE dflags - ptrs'+ | ptrs' + nptrs' >= pc_MIN_PAYLOAD_SIZE constants = nptrs'+ | otherwise = pc_MIN_PAYLOAD_SIZE constants - ptrs' descr = dataConIdentity dcon - platform = targetPlatform dflags+ platform = profilePlatform profile+ constants = platformConstants platform tables_next_to_code = platformTablesNextToCode platform r <- iservCmd hsc_env (MkConInfoTable tables_next_to_code ptrs' nptrs_really- conNo (tagForCon dflags dcon) descr)+ conNo (tagForCon platform dcon) descr) return (getName dcon, ItblPtr r)
compiler/GHC/Cmm/CallConv.hs view
@@ -14,6 +14,7 @@ import GHC.Driver.Session import GHC.Platform+import GHC.Platform.Profile import GHC.Utils.Outputable -- Calculate the 'GlobalReg' or stack locations for function call@@ -31,7 +32,7 @@ -- Given a list of arguments, and a function that tells their types, -- return a list showing where each argument is passed ---assignArgumentsPos :: DynFlags+assignArgumentsPos :: Profile -> ByteOff -- stack offset to start with -> Convention -> (a -> CmmType) -- how to get a type from an arg@@ -41,16 +42,16 @@ , [(a, ParamLocation)] -- args and locations ) -assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)+assignArgumentsPos profile off conv arg_ty reps = (stk_off, assignments) where- platform = targetPlatform dflags+ platform = profilePlatform profile regs = case (reps, conv) of- (_, NativeNodeCall) -> getRegsWithNode dflags- (_, NativeDirectCall) -> getRegsWithoutNode dflags- ([_], NativeReturn) -> allRegs dflags- (_, NativeReturn) -> getRegsWithNode dflags+ (_, NativeNodeCall) -> getRegsWithNode platform+ (_, NativeDirectCall) -> getRegsWithoutNode platform+ ([_], NativeReturn) -> allRegs platform+ (_, NativeReturn) -> getRegsWithNode platform -- GC calling convention *must* put values in registers- (_, GC) -> allRegs dflags+ (_, GC) -> allRegs platform (_, Slow) -> nodeOnly -- The calling conventions first assign arguments to registers, -- then switch to the stack when we first run out of registers@@ -67,11 +68,11 @@ | otherwise = int where vec = case (w, regs) of (W128, (vs, fs, ds, ls, s:ss))- | passVectorInReg W128 dflags -> k (RegisterParam (XmmReg s), (vs, fs, ds, ls, ss))+ | passVectorInReg W128 profile -> k (RegisterParam (XmmReg s), (vs, fs, ds, ls, ss)) (W256, (vs, fs, ds, ls, s:ss))- | passVectorInReg W256 dflags -> k (RegisterParam (YmmReg s), (vs, fs, ds, ls, ss))+ | passVectorInReg W256 profile -> k (RegisterParam (YmmReg s), (vs, fs, ds, ls, ss)) (W512, (vs, fs, ds, ls, s:ss))- | passVectorInReg W512 dflags -> k (RegisterParam (ZmmReg s), (vs, fs, ds, ls, ss))+ | passVectorInReg W512 profile -> k (RegisterParam (ZmmReg s), (vs, fs, ds, ls, ss)) _ -> (assts, (r:rs)) float = case (w, regs) of (W32, (vs, fs, ds, ls, s:ss))@@ -107,7 +108,7 @@ -- support vector registers in its calling convention. However, this has now -- been fixed. This function remains only as a convenient way to re-enable -- spilling when debugging code generation.-passVectorInReg :: Width -> DynFlags -> Bool+passVectorInReg :: Width -> Profile -> Bool passVectorInReg _ _ = True assignStack :: Platform -> ByteOff -> (a -> CmmType) -> [a]@@ -142,56 +143,57 @@ -- We take these register supplies from the *real* registers, i.e. those -- that are guaranteed to map to machine registers. -getRegsWithoutNode, getRegsWithNode :: DynFlags -> AvailRegs-getRegsWithoutNode dflags =- ( filter (\r -> r VGcPtr /= node) (realVanillaRegs dflags)- , realFloatRegs dflags- , realDoubleRegs dflags- , realLongRegs dflags- , realXmmRegNos dflags)+getRegsWithoutNode, getRegsWithNode :: Platform -> AvailRegs+getRegsWithoutNode platform =+ ( filter (\r -> r VGcPtr /= node) (realVanillaRegs platform)+ , realFloatRegs platform+ , realDoubleRegs platform+ , realLongRegs platform+ , realXmmRegNos platform) -- getRegsWithNode uses R1/node even if it isn't a register-getRegsWithNode dflags =- ( if null (realVanillaRegs dflags)+getRegsWithNode platform =+ ( if null (realVanillaRegs platform) then [VanillaReg 1]- else realVanillaRegs dflags- , realFloatRegs dflags- , realDoubleRegs dflags- , realLongRegs dflags- , realXmmRegNos dflags)+ else realVanillaRegs platform+ , realFloatRegs platform+ , realDoubleRegs platform+ , realLongRegs platform+ , realXmmRegNos platform) -allFloatRegs, allDoubleRegs, allLongRegs :: DynFlags -> [GlobalReg]-allVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]-allXmmRegs :: DynFlags -> [Int]+allFloatRegs, allDoubleRegs, allLongRegs :: Platform -> [GlobalReg]+allVanillaRegs :: Platform -> [VGcPtr -> GlobalReg]+allXmmRegs :: Platform -> [Int] -allVanillaRegs dflags = map VanillaReg $ regList (mAX_Vanilla_REG dflags)-allFloatRegs dflags = map FloatReg $ regList (mAX_Float_REG dflags)-allDoubleRegs dflags = map DoubleReg $ regList (mAX_Double_REG dflags)-allLongRegs dflags = map LongReg $ regList (mAX_Long_REG dflags)-allXmmRegs dflags = regList (mAX_XMM_REG dflags)+allVanillaRegs platform = map VanillaReg $ regList (pc_MAX_Vanilla_REG (platformConstants platform))+allFloatRegs platform = map FloatReg $ regList (pc_MAX_Float_REG (platformConstants platform))+allDoubleRegs platform = map DoubleReg $ regList (pc_MAX_Double_REG (platformConstants platform))+allLongRegs platform = map LongReg $ regList (pc_MAX_Long_REG (platformConstants platform))+allXmmRegs platform = regList (pc_MAX_XMM_REG (platformConstants platform)) -realFloatRegs, realDoubleRegs, realLongRegs :: DynFlags -> [GlobalReg]-realVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]-realXmmRegNos :: DynFlags -> [Int]+realFloatRegs, realDoubleRegs, realLongRegs :: Platform -> [GlobalReg]+realVanillaRegs :: Platform -> [VGcPtr -> GlobalReg] -realVanillaRegs dflags = map VanillaReg $ regList (mAX_Real_Vanilla_REG dflags)-realFloatRegs dflags = map FloatReg $ regList (mAX_Real_Float_REG dflags)-realDoubleRegs dflags = map DoubleReg $ regList (mAX_Real_Double_REG dflags)-realLongRegs dflags = map LongReg $ regList (mAX_Real_Long_REG dflags)+realVanillaRegs platform = map VanillaReg $ regList (pc_MAX_Real_Vanilla_REG (platformConstants platform))+realFloatRegs platform = map FloatReg $ regList (pc_MAX_Real_Float_REG (platformConstants platform))+realDoubleRegs platform = map DoubleReg $ regList (pc_MAX_Real_Double_REG (platformConstants platform))+realLongRegs platform = map LongReg $ regList (pc_MAX_Real_Long_REG (platformConstants platform)) -realXmmRegNos dflags- | isSse2Enabled dflags = regList (mAX_Real_XMM_REG dflags)- | otherwise = []+realXmmRegNos :: Platform -> [Int]+realXmmRegNos platform+ | isSse2Enabled platform = regList (pc_MAX_Real_XMM_REG (platformConstants platform))+ | otherwise = [] regList :: Int -> [Int] regList n = [1 .. n] -allRegs :: DynFlags -> AvailRegs-allRegs dflags = (allVanillaRegs dflags,- allFloatRegs dflags,- allDoubleRegs dflags,- allLongRegs dflags,- allXmmRegs dflags)+allRegs :: Platform -> AvailRegs+allRegs platform = ( allVanillaRegs platform+ , allFloatRegs platform+ , allDoubleRegs platform+ , allLongRegs platform+ , allXmmRegs platform+ ) nodeOnly :: AvailRegs nodeOnly = ([VanillaReg 1], [], [], [], [])@@ -201,18 +203,18 @@ -- now just x86-64, where Float and Double registers overlap---passing this set -- of registers is guaranteed to preserve the contents of all live registers. We -- only use this functionality in hand-written C-- code in the RTS.-realArgRegsCover :: DynFlags -> [GlobalReg]-realArgRegsCover dflags- | passFloatArgsInXmm (targetPlatform dflags)- = map ($VGcPtr) (realVanillaRegs dflags) ++- realLongRegs dflags ++- realDoubleRegs dflags -- we only need to save the low Double part of XMM registers.- -- Moreover, the NCG can't load/store full XMM- -- registers for now...+realArgRegsCover :: Platform -> [GlobalReg]+realArgRegsCover platform+ | passFloatArgsInXmm platform+ = map ($VGcPtr) (realVanillaRegs platform) +++ realLongRegs platform +++ realDoubleRegs platform -- we only need to save the low Double part of XMM registers.+ -- Moreover, the NCG can't load/store full XMM+ -- registers for now... | otherwise- = map ($VGcPtr) (realVanillaRegs dflags) ++- realFloatRegs dflags ++- realDoubleRegs dflags ++- realLongRegs dflags+ = map ($VGcPtr) (realVanillaRegs platform) +++ realFloatRegs platform +++ realDoubleRegs platform +++ realLongRegs platform -- we don't save XMM registers if they are not used for parameter passing
compiler/GHC/Cmm/Graph.hs view
@@ -23,6 +23,8 @@ import GHC.Prelude hiding ( (<*>) ) -- avoid importing (<*>) +import GHC.Platform.Profile+ import GHC.Cmm.BlockId import GHC.Cmm import GHC.Cmm.CallConv@@ -31,7 +33,6 @@ import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label-import GHC.Driver.Session import GHC.Data.FastString import GHC.Types.ForeignCall import GHC.Data.OrdList@@ -196,28 +197,28 @@ mkStore l r = mkMiddle $ CmmStore l r ---------- Control transfer-mkJump :: DynFlags -> Convention -> CmmExpr+mkJump :: Profile -> Convention -> CmmExpr -> [CmmExpr] -> UpdFrameOffset -> CmmAGraph-mkJump dflags conv e actuals updfr_off =- lastWithArgs dflags Jump Old conv actuals updfr_off $+mkJump profile conv e actuals updfr_off =+ lastWithArgs profile Jump Old conv actuals updfr_off $ toCall e Nothing updfr_off 0 -- | A jump where the caller says what the live GlobalRegs are. Used -- for low-level hand-written Cmm.-mkRawJump :: DynFlags -> CmmExpr -> UpdFrameOffset -> [GlobalReg]+mkRawJump :: Profile -> CmmExpr -> UpdFrameOffset -> [GlobalReg] -> CmmAGraph-mkRawJump dflags e updfr_off vols =- lastWithArgs dflags Jump Old NativeNodeCall [] updfr_off $+mkRawJump profile e updfr_off vols =+ lastWithArgs profile Jump Old NativeNodeCall [] updfr_off $ \arg_space _ -> toCall e Nothing updfr_off 0 arg_space vols -mkJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmExpr]+mkJumpExtra :: Profile -> Convention -> CmmExpr -> [CmmExpr] -> UpdFrameOffset -> [CmmExpr] -> CmmAGraph-mkJumpExtra dflags conv e actuals updfr_off extra_stack =- lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $+mkJumpExtra profile conv e actuals updfr_off extra_stack =+ lastWithArgsAndExtraStack profile Jump Old conv actuals updfr_off extra_stack $ toCall e Nothing updfr_off 0 mkCbranch :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph@@ -227,42 +228,42 @@ mkSwitch :: CmmExpr -> SwitchTargets -> CmmAGraph mkSwitch e tbl = mkLast $ CmmSwitch e tbl -mkReturn :: DynFlags -> CmmExpr -> [CmmExpr] -> UpdFrameOffset+mkReturn :: Profile -> CmmExpr -> [CmmExpr] -> UpdFrameOffset -> CmmAGraph-mkReturn dflags e actuals updfr_off =- lastWithArgs dflags Ret Old NativeReturn actuals updfr_off $+mkReturn profile e actuals updfr_off =+ lastWithArgs profile Ret Old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0 mkBranch :: BlockId -> CmmAGraph mkBranch bid = mkLast (CmmBranch bid) -mkFinalCall :: DynFlags+mkFinalCall :: Profile -> CmmExpr -> CCallConv -> [CmmExpr] -> UpdFrameOffset -> CmmAGraph-mkFinalCall dflags f _ actuals updfr_off =- lastWithArgs dflags Call Old NativeDirectCall actuals updfr_off $+mkFinalCall profile f _ actuals updfr_off =+ lastWithArgs profile Call Old NativeDirectCall actuals updfr_off $ toCall f Nothing updfr_off 0 -mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr]+mkCallReturnsTo :: Profile -> CmmExpr -> Convention -> [CmmExpr] -> BlockId -> ByteOff -> UpdFrameOffset -> [CmmExpr] -> CmmAGraph-mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack = do- lastWithArgsAndExtraStack dflags Call (Young ret_lbl) callConv actuals+mkCallReturnsTo profile f callConv actuals ret_lbl ret_off updfr_off extra_stack = do+ lastWithArgsAndExtraStack profile Call (Young ret_lbl) callConv actuals 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).-mkJumpReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr]+mkJumpReturnsTo :: Profile -> CmmExpr -> Convention -> [CmmExpr] -> BlockId -> ByteOff -> UpdFrameOffset -> CmmAGraph-mkJumpReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off = do- lastWithArgs dflags JumpRet (Young ret_lbl) callConv actuals updfr_off $+mkJumpReturnsTo profile f callConv actuals ret_lbl ret_off updfr_off = do+ lastWithArgs profile JumpRet (Young ret_lbl) callConv actuals updfr_off $ toCall f (Just ret_lbl) updfr_off ret_off mkUnsafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph@@ -292,25 +293,25 @@ -- variables in their spill slots. Therefore, for copying arguments -- and results, we provide different functions to pass the arguments -- in an overflow area and to pass them in spill slots.-copyInOflow :: DynFlags -> Convention -> Area+copyInOflow :: Profile -> Convention -> Area -> [CmmFormal] -> [CmmFormal] -> (Int, [GlobalReg], CmmAGraph) -copyInOflow dflags conv area formals extra_stk+copyInOflow profile conv area formals extra_stk = (offset, gregs, catAGraphs $ map mkMiddle nodes)- where (offset, gregs, nodes) = copyIn dflags conv area formals extra_stk+ where (offset, gregs, nodes) = copyIn profile conv area formals extra_stk -- Return the number of bytes used for copying arguments, as well as the -- instructions to copy the arguments.-copyIn :: DynFlags -> Convention -> Area+copyIn :: Profile -> Convention -> Area -> [CmmFormal] -> [CmmFormal] -> (ByteOff, [GlobalReg], [CmmNode O O])-copyIn dflags conv area formals extra_stk+copyIn profile conv area formals extra_stk = (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args)) where- platform = targetPlatform dflags+ platform = profilePlatform profile -- See Note [Width of parameters] ci (reg, RegisterParam r@(VanillaReg {})) = let local = CmmLocal reg@@ -346,7 +347,7 @@ (stk_off, stk_args) = assignStack platform init_offset localRegType extra_stk - (stk_size, args) = assignArgumentsPos dflags stk_off conv+ (stk_size, args) = assignArgumentsPos profile stk_off conv localRegType formals -- Factoring out the common parts of the copyout functions yielded something@@ -354,7 +355,7 @@ data Transfer = Call | JumpRet | Jump | Ret deriving Eq -copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmExpr]+copyOutOflow :: Profile -> Convention -> Transfer -> Area -> [CmmExpr] -> UpdFrameOffset -> [CmmExpr] -- extra stack args -> (Int, [GlobalReg], CmmAGraph)@@ -368,10 +369,10 @@ -- the info table for return and adjust the offsets of the other -- parameters. If this is a call instruction, we adjust the offsets -- of the other parameters.-copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff+copyOutOflow profile conv transfer area actuals updfr_off extra_stack_stuff = (stk_size, regs, graph) where- platform = targetPlatform dflags+ platform = profilePlatform profile (regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params) -- See Note [Width of parameters]@@ -419,7 +420,7 @@ assignStack platform init_offset (cmmExprType platform) extra_stack_stuff args :: [(CmmExpr, ParamLocation)] -- The argument and where to put it- (stk_size, args) = assignArgumentsPos dflags extra_stack_off conv+ (stk_size, args) = assignArgumentsPos profile extra_stack_off conv (cmmExprType platform) actuals @@ -450,29 +451,29 @@ -- https://github.com/ghc-proposals/ghc-proposals/pull/74 -mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal]+mkCallEntry :: Profile -> Convention -> [CmmFormal] -> [CmmFormal] -> (Int, [GlobalReg], CmmAGraph)-mkCallEntry dflags conv formals extra_stk- = copyInOflow dflags conv Old formals extra_stk+mkCallEntry profile conv formals extra_stk+ = copyInOflow profile conv Old formals extra_stk -lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmExpr]+lastWithArgs :: Profile -> Transfer -> Area -> Convention -> [CmmExpr] -> UpdFrameOffset -> (ByteOff -> [GlobalReg] -> CmmAGraph) -> CmmAGraph-lastWithArgs dflags transfer area conv actuals updfr_off last =- lastWithArgsAndExtraStack dflags transfer area conv actuals+lastWithArgs profile transfer area conv actuals updfr_off last =+ lastWithArgsAndExtraStack profile transfer area conv actuals updfr_off noExtraStack last -lastWithArgsAndExtraStack :: DynFlags+lastWithArgsAndExtraStack :: Profile -> Transfer -> Area -> Convention -> [CmmExpr] -> UpdFrameOffset -> [CmmExpr] -> (ByteOff -> [GlobalReg] -> CmmAGraph) -> CmmAGraph-lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off+lastWithArgsAndExtraStack profile transfer area conv actuals updfr_off extra_stack last = copies <*> last outArgs regs where- (outArgs, regs, copies) = copyOutOflow dflags conv transfer area actuals+ (outArgs, regs, copies) = copyOutOflow profile conv transfer area actuals updfr_off extra_stack
compiler/GHC/Cmm/Info.hs view
@@ -5,6 +5,7 @@ srtEscape, -- info table accessors+ PtrOpts (..), closureInfoPtr, entryCode, getConstrTag,@@ -45,6 +46,7 @@ import GHC.Cmm.Dataflow.Collections import GHC.Platform+import GHC.Platform.Profile import GHC.Data.Maybe import GHC.Driver.Session import GHC.Utils.Error (withTimingSilent)@@ -251,7 +253,7 @@ ++ [ liveness_lit, slow_entry ] ; return (Nothing, Nothing, extra_bits, liveness_data) } where- slow_entry = CmmLabel (toSlowEntryLbl info_lbl)+ slow_entry = CmmLabel (toSlowEntryLbl platform info_lbl) srt_lit = case srt_label of [] -> mkIntCLit platform 0 (lit:_rest) -> ASSERT( null _rest ) lit@@ -367,7 +369,7 @@ [b] -> b _ -> panic "mkLiveness" bitmap_word = toStgWord platform (fromIntegral n_bits)- .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags)+ .|. (small_bitmap `shiftL` pc_BITMAP_BITS_SHIFT (platformConstants platform)) lits = mkWordCLit platform (fromIntegral n_bits) : map (mkStgWordCLit platform) bitmap@@ -441,20 +443,25 @@ -- ------------------------------------------------------------------------- +data PtrOpts = PtrOpts+ { po_profile :: !Profile -- ^ Platform profile+ , po_align_check :: !Bool -- ^ Insert alignment check (cf @-falignment-sanitisation@)+ }+ -- | Wrap a 'CmmExpr' in an alignment check when @-falignment-sanitisation@ is -- enabled.-wordAligned :: DynFlags -> CmmExpr -> CmmExpr-wordAligned dflags e- | gopt Opt_AlignmentSanitisation dflags+wordAligned :: PtrOpts -> CmmExpr -> CmmExpr+wordAligned opts e+ | po_align_check opts = CmmMachOp (MO_AlignmentCheck (platformWordSizeInBytes platform) (wordWidth platform)) [e] | otherwise = e- where platform = targetPlatform dflags+ where platform = profilePlatform (po_profile opts) -closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr--- Takes a closure pointer and returns the info table pointer-closureInfoPtr dflags e =- CmmLoad (wordAligned dflags e) (bWord (targetPlatform dflags))+-- | Takes a closure pointer and returns the info table pointer+closureInfoPtr :: PtrOpts -> CmmExpr -> CmmExpr+closureInfoPtr opts e =+ CmmLoad (wordAligned opts e) (bWord (profilePlatform (po_profile opts))) -- | Takes an info pointer (the first word of a closure) and returns its entry -- code@@ -464,94 +471,95 @@ then e else CmmLoad e (bWord platform) -getConstrTag :: DynFlags -> CmmExpr -> CmmExpr--- Takes a closure pointer, and return the *zero-indexed*+-- | Takes a closure pointer, and return the *zero-indexed* -- constructor tag obtained from the info table -- This lives in the SRT field of the info table -- (constructors don't need SRTs).-getConstrTag dflags closure_ptr- = CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableConstrTag dflags info_table]+getConstrTag :: PtrOpts -> CmmExpr -> CmmExpr+getConstrTag opts closure_ptr+ = CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableConstrTag profile info_table] where- info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)- platform = targetPlatform dflags+ info_table = infoTable profile (closureInfoPtr opts closure_ptr)+ platform = profilePlatform profile+ profile = po_profile opts -cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr--- Takes a closure pointer, and return the closure type+-- | Takes a closure pointer, and return the closure type -- obtained from the info table-cmmGetClosureType dflags closure_ptr- = CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableClosureType dflags info_table]+cmmGetClosureType :: PtrOpts -> CmmExpr -> CmmExpr+cmmGetClosureType opts closure_ptr+ = CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableClosureType profile info_table] where- info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)- platform = targetPlatform dflags+ info_table = infoTable profile (closureInfoPtr opts closure_ptr)+ platform = profilePlatform profile+ profile = po_profile opts -infoTable :: DynFlags -> CmmExpr -> CmmExpr--- Takes an info pointer (the first word of a closure)+-- | Takes an info pointer (the first word of a closure) -- and returns a pointer to the first word of the standard-form -- info table, excluding the entry-code word (if present)-infoTable dflags info_ptr- | platformTablesNextToCode platform = cmmOffsetB platform info_ptr (- stdInfoTableSizeB dflags)+infoTable :: Profile -> CmmExpr -> CmmExpr+infoTable profile info_ptr+ | platformTablesNextToCode platform = cmmOffsetB platform info_ptr (- stdInfoTableSizeB profile) | otherwise = cmmOffsetW platform info_ptr 1 -- Past the entry code pointer- where platform = targetPlatform dflags+ where platform = profilePlatform profile -infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr--- Takes an info table pointer (from infoTable) and returns the constr tag+-- | Takes an info table pointer (from infoTable) and returns the constr tag -- field of the info table (same as the srt_bitmap field)+infoTableConstrTag :: Profile -> CmmExpr -> CmmExpr infoTableConstrTag = infoTableSrtBitmap -infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr--- Takes an info table pointer (from infoTable) and returns the srt_bitmap+-- | Takes an info table pointer (from infoTable) and returns the srt_bitmap -- field of the info table-infoTableSrtBitmap dflags info_tbl- = CmmLoad (cmmOffsetB platform info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord platform)- where platform = targetPlatform dflags+infoTableSrtBitmap :: Profile -> CmmExpr -> CmmExpr+infoTableSrtBitmap profile info_tbl+ = CmmLoad (cmmOffsetB platform info_tbl (stdSrtBitmapOffset profile)) (bHalfWord platform)+ where platform = profilePlatform profile -infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr--- Takes an info table pointer (from infoTable) and returns the closure type+-- | Takes an info table pointer (from infoTable) and returns the closure type -- field of the info table.-infoTableClosureType dflags info_tbl- = CmmLoad (cmmOffsetB platform info_tbl (stdClosureTypeOffset dflags)) (bHalfWord platform)- where platform = targetPlatform dflags+infoTableClosureType :: Profile -> CmmExpr -> CmmExpr+infoTableClosureType profile info_tbl+ = CmmLoad (cmmOffsetB platform info_tbl (stdClosureTypeOffset profile)) (bHalfWord platform)+ where platform = profilePlatform profile -infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr-infoTablePtrs dflags info_tbl- = CmmLoad (cmmOffsetB platform info_tbl (stdPtrsOffset dflags)) (bHalfWord platform)- where platform = targetPlatform dflags+infoTablePtrs :: Profile -> CmmExpr -> CmmExpr+infoTablePtrs profile info_tbl+ = CmmLoad (cmmOffsetB platform info_tbl (stdPtrsOffset profile)) (bHalfWord platform)+ where platform = profilePlatform profile -infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr-infoTableNonPtrs dflags info_tbl- = CmmLoad (cmmOffsetB platform info_tbl (stdNonPtrsOffset dflags)) (bHalfWord platform)- where platform = targetPlatform dflags+infoTableNonPtrs :: Profile -> CmmExpr -> CmmExpr+infoTableNonPtrs profile info_tbl+ = CmmLoad (cmmOffsetB platform info_tbl (stdNonPtrsOffset profile)) (bHalfWord platform)+ where platform = profilePlatform profile -funInfoTable :: DynFlags -> CmmExpr -> CmmExpr--- Takes the info pointer of a function,--- and returns a pointer to the first word of the StgFunInfoExtra struct--- in the info table.-funInfoTable dflags info_ptr+-- | Takes the info pointer of a function, and returns a pointer to the first+-- word of the StgFunInfoExtra struct in the info table.+funInfoTable :: Profile -> CmmExpr -> CmmExpr+funInfoTable profile info_ptr | platformTablesNextToCode platform- = cmmOffsetB platform info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags)+ = cmmOffsetB platform info_ptr (- stdInfoTableSizeB profile - pc_SIZEOF_StgFunInfoExtraRev (platformConstants platform)) | otherwise- = cmmOffsetW platform info_ptr (1 + stdInfoTableSizeW dflags)+ = cmmOffsetW platform info_ptr (1 + stdInfoTableSizeW profile) -- Past the entry code pointer where- platform = targetPlatform dflags+ platform = profilePlatform profile --- Takes the info pointer of a function, returns the function's arity-funInfoArity :: DynFlags -> CmmExpr -> CmmExpr-funInfoArity dflags iptr+-- | Takes the info pointer of a function, returns the function's arity+funInfoArity :: Profile -> CmmExpr -> CmmExpr+funInfoArity profile iptr = cmmToWord platform (cmmLoadIndex platform rep fun_info (offset `div` rep_bytes)) where- platform = targetPlatform dflags- fun_info = funInfoTable dflags iptr+ platform = profilePlatform profile+ fun_info = funInfoTable profile iptr rep = cmmBits (widthFromBytes rep_bytes) tablesNextToCode = platformTablesNextToCode platform (rep_bytes, offset) | tablesNextToCode = ( pc_REP_StgFunInfoExtraRev_arity pc- , oFFSET_StgFunInfoExtraRev_arity dflags )+ , pc_OFFSET_StgFunInfoExtraRev_arity pc ) | otherwise = ( pc_REP_StgFunInfoExtraFwd_arity pc- , oFFSET_StgFunInfoExtraFwd_arity dflags )+ , pc_OFFSET_StgFunInfoExtraFwd_arity pc ) - pc = platformConstants dflags+ pc = platformConstants platform ----------------------------------------------------------------------------- --@@ -559,13 +567,13 @@ -- ----------------------------------------------------------------------------- -stdInfoTableSizeW :: DynFlags -> WordOff+stdInfoTableSizeW :: Profile -> WordOff -- The size of a standard info table varies with profiling/ticky etc, -- so we can't get it from Constants -- It must vary in sync with mkStdInfoTable-stdInfoTableSizeW dflags+stdInfoTableSizeW profile = fixedInfoTableSizeW- + if sccProfilingEnabled dflags+ + if profileIsProfiling profile then profInfoTableSizeW else 0 @@ -586,28 +594,24 @@ maxStdInfoTableSizeW + 1 {- srt label -} -stdInfoTableSizeB :: DynFlags -> ByteOff-stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * platformWordSizeInBytes platform- where platform = targetPlatform dflags+stdInfoTableSizeB :: Profile -> ByteOff+stdInfoTableSizeB profile = stdInfoTableSizeW profile * profileWordSizeInBytes profile -stdSrtBitmapOffset :: DynFlags -> ByteOff--- Byte offset of the SRT bitmap half-word which is--- in the *higher-addressed* part of the type_lit-stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - halfWordSize platform- where platform = targetPlatform dflags+-- | Byte offset of the SRT bitmap half-word which is in the *higher-addressed*+-- part of the type_lit+stdSrtBitmapOffset :: Profile -> ByteOff+stdSrtBitmapOffset profile = stdInfoTableSizeB profile - halfWordSize (profilePlatform profile) -stdClosureTypeOffset :: DynFlags -> ByteOff--- Byte offset of the closure type half-word-stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - platformWordSizeInBytes platform- where platform = targetPlatform dflags+-- | Byte offset of the closure type half-word+stdClosureTypeOffset :: Profile -> ByteOff+stdClosureTypeOffset profile = stdInfoTableSizeB profile - profileWordSizeInBytes profile -stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff-stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * platformWordSizeInBytes platform- where platform = targetPlatform dflags+stdPtrsOffset :: Profile -> ByteOff+stdPtrsOffset profile = stdInfoTableSizeB profile - 2 * profileWordSizeInBytes profile -stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * platformWordSizeInBytes platform + halfWordSize platform- where platform = targetPlatform dflags+stdNonPtrsOffset :: Profile -> ByteOff+stdNonPtrsOffset profile = stdInfoTableSizeB profile - 2 * profileWordSizeInBytes profile+ + halfWordSize (profilePlatform profile) -conInfoTableSizeB :: DynFlags -> Int-conInfoTableSizeB dflags = stdInfoTableSizeB dflags + platformWordSizeInBytes platform- where platform = targetPlatform dflags+conInfoTableSizeB :: Profile -> Int+conInfoTableSizeB profile = stdInfoTableSizeB profile + profileWordSizeInBytes profile
compiler/GHC/Cmm/Info/Build.hs view
@@ -10,6 +10,9 @@ import GHC.Prelude hiding (succ) +import GHC.Platform+import GHC.Platform.Profile+ import GHC.Types.Id import GHC.Types.Id.Info import GHC.Cmm.BlockId@@ -19,7 +22,6 @@ import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow import GHC.Unit.Module-import GHC.Platform import GHC.Data.Graph.Directed import GHC.Cmm.CLabel import GHC.Cmm@@ -32,7 +34,6 @@ import GHC.Types.CostCentre import GHC.StgToCmm.Heap import GHC.CmmToAsm.Monad-import GHC.CmmToAsm.Config import Control.Monad import Data.Map.Strict (Map)@@ -458,8 +459,8 @@ type CAFSet = Set CAFLabel type CAFEnv = LabelMap CAFSet -mkCAFLabel :: CLabel -> CAFLabel-mkCAFLabel lbl = CAFLabel (toClosureLbl lbl)+mkCAFLabel :: Platform -> CLabel -> CAFLabel+mkCAFLabel platform lbl = CAFLabel (toClosureLbl platform lbl) -- This is a label that we can put in an SRT. It *must* be a closure label, -- pointing to either a FUN_STATIC, THUNK_STATIC, or CONSTR.@@ -469,10 +470,10 @@ -- --------------------------------------------------------------------- -- CAF analysis -addCafLabel :: CLabel -> CAFSet -> CAFSet-addCafLabel l s+addCafLabel :: Platform -> CLabel -> CAFSet -> CAFSet+addCafLabel platform l s | Just _ <- hasHaskellName l- , let caf_label = mkCAFLabel l+ , let caf_label = mkCAFLabel platform l -- For imported Ids hasCAF will have accurate CafInfo -- Locals are initialized as CAFFY. We turn labels with empty SRTs into -- non-CAFFYs in doSRTs@@ -482,21 +483,20 @@ = s cafAnalData- :: CmmStatics+ :: Platform+ -> CmmStatics -> CAFSet--cafAnalData (CmmStaticsRaw _lbl _data) =- Set.empty--cafAnalData (CmmStatics _lbl _itbl _ccs payload) =- foldl' analyzeStatic Set.empty payload- where- analyzeStatic s lit =- case lit of- CmmLabel c -> addCafLabel c s- CmmLabelOff c _ -> addCafLabel c s- CmmLabelDiffOff c1 c2 _ _ -> addCafLabel c1 $! addCafLabel c2 s- _ -> s+cafAnalData platform st = case st of+ CmmStaticsRaw _lbl _data -> Set.empty+ CmmStatics _lbl _itbl _ccs payload ->+ foldl' analyzeStatic Set.empty payload+ where+ analyzeStatic s lit =+ case lit of+ CmmLabel c -> addCafLabel platform c s+ CmmLabelOff c _ -> addCafLabel platform c s+ CmmLabelDiffOff c1 c2 _ _ -> addCafLabel platform c1 $! addCafLabel platform c2 s+ _ -> s -- | -- For each code block:@@ -506,16 +506,17 @@ -- This gives us a `CAFEnv`: a mapping from code block to sets of labels -- cafAnal- :: LabelSet -- The blocks representing continuations, ie. those+ :: Platform+ -> LabelSet -- The blocks representing continuations, ie. those -- that will get RET info tables. These labels will -- get their own SRTs, so we don't aggregate CAFs from -- references to these labels, we just use the label. -> CLabel -- The top label of the proc -> CmmGraph -> CAFEnv-cafAnal contLbls topLbl cmmGraph =+cafAnal platform contLbls topLbl cmmGraph = analyzeCmmBwd cafLattice- (cafTransfers contLbls (g_entry cmmGraph) topLbl) cmmGraph mapEmpty+ (cafTransfers platform contLbls (g_entry cmmGraph) topLbl) cmmGraph mapEmpty cafLattice :: DataflowLattice CAFSet@@ -526,8 +527,8 @@ in changedIf (Set.size new' > Set.size old) new' -cafTransfers :: LabelSet -> Label -> CLabel -> TransferFun CAFSet-cafTransfers contLbls entry topLbl+cafTransfers :: Platform -> LabelSet -> Label -> CLabel -> TransferFun CAFSet+cafTransfers platform contLbls entry topLbl block@(BlockCC eNode middle xNode) fBase = let joined :: CAFSet joined = cafsInNode xNode $! live'@@ -545,11 +546,11 @@ successorFact s -- If this is a loop back to the entry, we can refer to the -- entry label.- | s == entry = Just (addCafLabel topLbl Set.empty)+ | s == entry = Just (addCafLabel platform topLbl Set.empty) -- If this is a continuation, we want to refer to the -- SRT for the continuation's info table | s `setMember` contLbls- = Just (Set.singleton (mkCAFLabel (infoTblLbl s)))+ = Just (Set.singleton (mkCAFLabel platform (infoTblLbl s))) -- Otherwise, takes the CAF references from the destination | otherwise = lookupFact s fBase@@ -561,11 +562,11 @@ addCafExpr expr !set = case expr of CmmLit (CmmLabel c) ->- addCafLabel c set+ addCafLabel platform c set CmmLit (CmmLabelOff c _) ->- addCafLabel c set+ addCafLabel platform c set CmmLit (CmmLabelDiffOff c1 c2 _ _) ->- addCafLabel c1 $! addCafLabel c2 set+ addCafLabel platform c1 $! addCafLabel platform c2 set _ -> set in@@ -648,35 +649,34 @@ -- where the label is -- - the info label for a continuation or dynamic closure -- - the closure label for a top-level function (not a CAF)-getLabelledBlocks :: CmmDecl -> [(SomeLabel, CAFLabel)]-getLabelledBlocks (CmmData _ (CmmStaticsRaw _ _)) =- []-getLabelledBlocks (CmmData _ (CmmStatics lbl _ _ _)) =- [ (DeclLabel lbl, mkCAFLabel lbl) ]-getLabelledBlocks (CmmProc top_info _ _ _) =- [ (BlockLabel blockId, caf_lbl)- | (blockId, info) <- mapToList (info_tbls top_info)- , let rep = cit_rep info- , not (isStaticRep rep) || not (isThunkRep rep)- , let !caf_lbl = mkCAFLabel (cit_lbl info)- ]+getLabelledBlocks :: Platform -> CmmDecl -> [(SomeLabel, CAFLabel)]+getLabelledBlocks platform decl = case decl of+ CmmData _ (CmmStaticsRaw _ _) -> []+ CmmData _ (CmmStatics lbl _ _ _) -> [ (DeclLabel lbl, mkCAFLabel platform lbl) ]+ CmmProc top_info _ _ _ -> [ (BlockLabel blockId, caf_lbl)+ | (blockId, info) <- mapToList (info_tbls top_info)+ , let rep = cit_rep info+ , not (isStaticRep rep) || not (isThunkRep rep)+ , let !caf_lbl = mkCAFLabel platform (cit_lbl info)+ ] -- | Put the labelled blocks that we will be annotating with SRTs into -- dependency order. This is so that we can process them one at a -- time, resolving references to earlier blocks to point to their -- SRTs. CAFs themselves are not included here; see getCAFs below. depAnalSRTs- :: CAFEnv+ :: Platform+ -> CAFEnv -> Map CLabel CAFSet -- CAFEnv for statics -> [CmmDecl] -> [SCC (SomeLabel, CAFLabel, Set CAFLabel)]-depAnalSRTs cafEnv cafEnv_static decls =+depAnalSRTs platform cafEnv cafEnv_static decls = srtTrace "depAnalSRTs" (text "decls:" <+> ppr decls $$ text "nodes:" <+> ppr (map node_payload nodes) $$ text "graph:" <+> ppr graph) graph where labelledBlocks :: [(SomeLabel, CAFLabel)]- labelledBlocks = concatMap getLabelledBlocks decls+ labelledBlocks = concatMap (getLabelledBlocks platform) decls labelToBlock :: Map CAFLabel SomeLabel labelToBlock = foldl' (\m (v,k) -> Map.insert k v m) Map.empty labelledBlocks @@ -700,9 +700,9 @@ -- SRT, since the point of SRTs is to keep CAFs alive. -- - CAFs therefore don't take part in the dependency analysis in depAnalSRTs. -- instead we generate their SRTs after everything else.-getCAFs :: CAFEnv -> [CmmDecl] -> [(Label, CAFLabel, Set CAFLabel)]-getCAFs cafEnv decls =- [ (g_entry g, mkCAFLabel topLbl, cafs)+getCAFs :: Platform -> CAFEnv -> [CmmDecl] -> [(Label, CAFLabel, Set CAFLabel)]+getCAFs platform cafEnv decls =+ [ (g_entry g, mkCAFLabel platform topLbl, cafs) | CmmProc top_info topLbl _ g <- decls , Just info <- [mapLookup (g_entry g) (info_tbls top_info)] , let rep = cit_rep info@@ -746,11 +746,11 @@ get_name (_l, Just _srt_entry) = Nothing -- | resolve a CAFLabel to its SRTEntry using the SRTMap-resolveCAF :: SRTMap -> CAFLabel -> Maybe SRTEntry-resolveCAF srtMap lbl@(CAFLabel l) =+resolveCAF :: Platform -> SRTMap -> CAFLabel -> Maybe SRTEntry+resolveCAF platform srtMap lbl@(CAFLabel l) = srtTrace "resolveCAF" ("l:" <+> ppr l <+> "resolved:" <+> ppr ret) ret where- ret = Map.findWithDefault (Just (SRTEntry (toClosureLbl l))) lbl srtMap+ ret = Map.findWithDefault (Just (SRTEntry (toClosureLbl platform l))) lbl srtMap -- | Attach SRTs to all info tables in the CmmDecls, and add SRT -- declarations to the ModuleSRTInfo.@@ -765,6 +765,8 @@ doSRTs dflags moduleSRTInfo procs data_ = do us <- mkSplitUniqSupply 'u' + let profile = targetProfile dflags+ -- Ignore the original grouping of decls, and combine all the -- CAFEnvs into a single CAFEnv. let static_data_env :: Map CLabel CAFSet@@ -788,6 +790,8 @@ decls = map snd data_ ++ concat procss staticFuns = mapFromList (getStaticFuns decls) + platform = targetPlatform dflags+ -- Put the decls in dependency order. Why? So that we can implement -- [Inline] and [Filter]. If we need to refer to an SRT that has -- a single entry, we use the entry itself, which means that we@@ -796,10 +800,10 @@ -- them. let sccs :: [SCC (SomeLabel, CAFLabel, Set CAFLabel)]- sccs = {-# SCC depAnalSRTs #-} depAnalSRTs cafEnv static_data_env decls+ sccs = {-# SCC depAnalSRTs #-} depAnalSRTs platform cafEnv static_data_env decls cafsWithSRTs :: [(Label, CAFLabel, Set CAFLabel)]- cafsWithSRTs = getCAFs cafEnv decls+ cafsWithSRTs = getCAFs platform cafEnv decls srtTraceM "doSRTs" (text "data:" <+> ppr data_ $$ text "procs:" <+> ppr procs $$@@ -834,7 +838,7 @@ funSRTMap = mapFromList (concat funSRTs) has_caf_refs' = or has_caf_refs decls' =- concatMap (updInfoSRTs dflags srtFieldMap funSRTMap has_caf_refs') decls+ concatMap (updInfoSRTs profile srtFieldMap funSRTMap has_caf_refs') decls -- Finally update CafInfos for raw static literals (CmmStaticsRaw). Those are -- not analysed in oneSRT so we never add entries for them to the SRTMap.@@ -850,7 +854,7 @@ -- be CAFFY. -- See Note [Ticky labels in SRT analysis] above for -- why we exclude ticky labels here.- Map.insert (mkCAFLabel lbl) Nothing srtMap+ Map.insert (mkCAFLabel platform lbl) Nothing srtMap | otherwise -> -- Not an IdLabel, ignore srtMap@@ -929,6 +933,8 @@ let config = initConfig dflags+ profile = targetProfile dflags+ platform = profilePlatform profile srtMap = moduleSRTMap topSRT blockids = getBlockLabels lbls@@ -947,7 +953,7 @@ -- Resolve references to their SRT entries resolved :: [SRTEntry]- resolved = mapMaybe (resolveCAF srtMap) (Set.toList nonRec)+ resolved = mapMaybe (resolveCAF platform srtMap) (Set.toList nonRec) -- The set of all SRTEntries in SRTs that we refer to from here. allBelow =@@ -1012,7 +1018,7 @@ -- We're going to build an SRT for this group, which should include function -- references in the group. See Note [recursive SRTs]. let allBelow_funs =- Set.fromList (map (SRTEntry . toClosureLbl) otherFunLabels)+ Set.fromList (map (SRTEntry . toClosureLbl platform) otherFunLabels) let filtered = filtered0 `Set.union` allBelow_funs srtTraceM "oneSRT" (text "filtered:" <+> ppr filtered $$ text "allBelow_funs:" <+> ppr allBelow_funs)@@ -1032,7 +1038,7 @@ -- MachO relocations can't express offsets between compilation units at -- all, so we are always forced to build a singleton SRT in this case.- && (not (osMachOTarget $ platformOS $ ncgPlatform config)+ && (not (osMachOTarget $ platformOS $ profilePlatform profile) || isLocalCLabel this_mod lbl) -> do -- If we have a static function closure, then it becomes the@@ -1070,7 +1076,7 @@ Just (fun,block) -> return ( [], [(block, cafList)], SRTEntry fun ) Nothing -> do- (decls, entry) <- lift $ buildSRTChain dflags cafList+ (decls, entry) <- lift $ buildSRTChain profile cafList return (decls, [], entry) updateSRTMap (Just srtEntry) let allBelowThis = Set.union allBelow filtered@@ -1089,38 +1095,38 @@ return (decls, map (,lbl) blockids, funSRTs, True) --- | build a static SRT object (or a chain of objects) from a list of+-- | Build a static SRT object (or a chain of objects) from a list of -- SRTEntries. buildSRTChain- :: DynFlags+ :: Profile -> [SRTEntry] -> UniqSM ( [CmmDeclSRTs] -- The SRT object(s) , SRTEntry -- label to use in the info table ) buildSRTChain _ [] = panic "buildSRT: empty"-buildSRTChain dflags cafSet =+buildSRTChain profile cafSet = case splitAt mAX_SRT_SIZE cafSet of (these, []) -> do- (decl,lbl) <- buildSRT dflags these+ (decl,lbl) <- buildSRT profile these return ([decl], lbl) (these,those) -> do- (rest, rest_lbl) <- buildSRTChain dflags (head these : those)- (decl,lbl) <- buildSRT dflags (rest_lbl : tail these)+ (rest, rest_lbl) <- buildSRTChain profile (head these : those)+ (decl,lbl) <- buildSRT profile (rest_lbl : tail these) return (decl:rest, lbl) where mAX_SRT_SIZE = 16 -buildSRT :: DynFlags -> [SRTEntry] -> UniqSM (CmmDeclSRTs, SRTEntry)-buildSRT dflags refs = do+buildSRT :: Profile -> [SRTEntry] -> UniqSM (CmmDeclSRTs, SRTEntry)+buildSRT profile refs = do id <- getUniqueM let lbl = mkSRTLabel id- platform = targetPlatform dflags+ platform = profilePlatform profile srt_n_info = mkSRTInfoLabel (length refs) fields =- mkStaticClosure dflags srt_n_info dontCareCCS+ mkStaticClosure profile srt_n_info dontCareCCS [ CmmLabel lbl | SRTEntry lbl <- refs ] [] -- no padding [mkIntCLit platform 0] -- link field@@ -1130,7 +1136,7 @@ -- | Update info tables with references to their SRTs. Also generate -- static closures, splicing in SRT fields as necessary. updInfoSRTs- :: DynFlags+ :: Profile -> LabelMap CLabel -- SRT labels for each block -> LabelMap [SRTEntry] -- SRTs to merge into FUN_STATIC closures -> Bool -- Whether the CmmDecl's group has CAF references@@ -1140,13 +1146,13 @@ updInfoSRTs _ _ _ _ (CmmData s (CmmStaticsRaw lbl statics)) = [CmmData s (CmmStaticsRaw lbl statics)] -updInfoSRTs dflags _ _ caffy (CmmData s (CmmStatics lbl itbl ccs payload))+updInfoSRTs profile _ _ caffy (CmmData s (CmmStatics lbl itbl ccs payload)) = [CmmData s (CmmStaticsRaw lbl (map CmmStaticLit field_lits))] where caf_info = if caffy then MayHaveCafRefs else NoCafRefs- field_lits = mkStaticClosureFields dflags itbl ccs caf_info payload+ field_lits = mkStaticClosureFields profile itbl ccs caf_info payload -updInfoSRTs dflags srt_env funSRTEnv caffy (CmmProc top_info top_l live g)+updInfoSRTs profile srt_env funSRTEnv caffy (CmmProc top_info top_l live g) | Just (_,closure) <- maybeStaticClosure = [ proc, closure ] | otherwise = [ proc ] where@@ -1175,7 +1181,7 @@ Just srtEntries -> srtTrace "maybeStaticFun" (ppr res) (info_tbl { cit_rep = new_rep }, res) where res = [ CmmLabel lbl | SRTEntry lbl <- srtEntries ]- fields = mkStaticClosureFields dflags info_tbl ccs caf_info srtEntries+ fields = mkStaticClosureFields profile info_tbl ccs caf_info srtEntries new_rep = case cit_rep of HeapRep sta ptrs nptrs ty -> HeapRep sta (ptrs + length srtEntries) nptrs ty
compiler/GHC/Cmm/LayoutStack.hs view
@@ -5,6 +5,9 @@ import GHC.Prelude hiding ((<*>)) +import GHC.Platform+import GHC.Platform.Profile+ import GHC.StgToCmm.Utils ( callerSaveVolatileRegs, newTemp ) -- XXX layering violation import GHC.StgToCmm.Foreign ( saveThreadState, loadThreadState ) -- XXX layering violation @@ -29,7 +32,6 @@ import GHC.Types.Unique.FM import GHC.Utils.Misc -import GHC.Platform import GHC.Driver.Session import GHC.Data.FastString import GHC.Utils.Outputable hiding ( isEmpty )@@ -224,7 +226,7 @@ , sm_ret_off :: ByteOff -- ^ Number of words of stack that we do not describe with an info -- table, because it contains an update frame.- , sm_regs :: UniqFM (LocalReg,StackLoc)+ , sm_regs :: UniqFM LocalReg (LocalReg,StackLoc) -- ^ regs on the stack } @@ -245,6 +247,7 @@ -- by the sinking pass. let liveness = cmmLocalLiveness dflags graph blocks = revPostorder graph+ profile = targetProfile dflags (final_stackmaps, _final_high_sp, new_blocks) <- mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) ->@@ -253,7 +256,7 @@ blocks_with_reloads <- insertReloadsAsNeeded dflags procpoints final_stackmaps entry new_blocks- new_blocks' <- mapM (lowerSafeForeignCall dflags) blocks_with_reloads+ new_blocks' <- mapM (lowerSafeForeignCall profile) blocks_with_reloads return (ofBlockList entry new_blocks', final_stackmaps) -- -----------------------------------------------------------------------------@@ -1131,18 +1134,18 @@ that safe foreign call is replace by an unsafe one in the Cmm graph. -} -lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock-lowerSafeForeignCall dflags block+lowerSafeForeignCall :: Profile -> CmmBlock -> UniqSM CmmBlock+lowerSafeForeignCall profile block | (entry@(CmmEntry _ tscp), middle, CmmForeignCall { .. }) <- blockSplit block = do- let platform = targetPlatform dflags+ let platform = profilePlatform profile -- Both 'id' and 'new_base' are KindNonPtr because they're -- RTS-only objects and are not subject to garbage collection id <- newTemp (bWord platform) new_base <- newTemp (cmmRegType platform baseReg)- let (caller_save, caller_load) = callerSaveVolatileRegs dflags- save_state_code <- saveThreadState dflags- load_state_code <- loadThreadState dflags+ let (caller_save, caller_load) = callerSaveVolatileRegs platform+ save_state_code <- saveThreadState profile+ load_state_code <- loadThreadState profile let suspend = save_state_code <*> caller_save <*> mkMiddle (callSuspendThread platform id intrbl)@@ -1155,7 +1158,7 @@ load_state_code (_, regs, copyout) =- copyOutOflow dflags NativeReturn Jump (Young succ)+ copyOutOflow profile NativeReturn Jump (Young succ) (map (CmmReg . CmmLocal) res) ret_off []
compiler/GHC/Cmm/Monad.hs view
@@ -11,10 +11,17 @@ 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@@ -49,3 +56,18 @@ 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
@@ -204,13 +204,15 @@ import GHC.Prelude +import GHC.Platform+import GHC.Platform.Profile+ import GHC.StgToCmm.ExtCode-import GHC.Cmm.CallConv import GHC.StgToCmm.Prof import GHC.StgToCmm.Heap import GHC.StgToCmm.Monad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit- , emitStore, emitAssign, emitOutOfLine, withUpdFrameOff- , getUpdFrameOff )+ , emitStore, emitAssign, emitOutOfLine, withUpdFrameOff+ , getUpdFrameOff, getProfile, getPlatform, getPtrOpts ) import qualified GHC.StgToCmm.Monad as F import GHC.StgToCmm.Utils import GHC.StgToCmm.Foreign@@ -219,6 +221,7 @@ import GHC.StgToCmm.Layout hiding (ArgRep(..)) import GHC.StgToCmm.Ticky import GHC.StgToCmm.Bind ( emitBlackHoleCode, emitUpdateFrame )+ import GHC.Core ( Tickish(SourceNote) ) import GHC.Cmm.Opt@@ -230,14 +233,15 @@ import GHC.Cmm.BlockId import GHC.Cmm.Lexer import GHC.Cmm.CLabel-import GHC.Cmm.Monad+import GHC.Cmm.Monad hiding (getPlatform, getProfile, getPtrOpts)+import qualified GHC.Cmm.Monad as PD+import GHC.Cmm.CallConv import GHC.Runtime.Heap.Layout import GHC.Parser.Lexer import GHC.Types.CostCentre import GHC.Types.ForeignCall import GHC.Unit.Module-import GHC.Platform import GHC.Types.Literal import GHC.Types.Unique import GHC.Types.Unique.FM@@ -418,9 +422,9 @@ fromIntegral $3)] } | 'CLOSURE' '(' NAME lits ')' { do { lits <- sequence $4- ; dflags <- getDynFlags+ ; profile <- getProfile ; return $ map CmmStaticLit $- mkStaticClosure dflags (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)+ mkStaticClosure profile (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData) -- mkForeignLabel because these are only used -- for CHARLIKE and INTLIKE closures in the RTS. dontCareCCS (map getLit lits) [] [] [] } }@@ -463,10 +467,10 @@ | 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' -- ptrs, nptrs, closure type, description, type {% liftP . withHomeUnitId $ \pkg ->- do dflags <- getDynFlags- let prof = profilingInfo dflags $11 $13+ do profile <- getProfile+ let prof = profilingInfo profile $11 $13 rep = mkRTSRep (fromIntegral $9) $- mkHeapRep dflags False (fromIntegral $5)+ mkHeapRep profile False (fromIntegral $5) (fromIntegral $7) Thunk -- not really Thunk, but that makes the info table -- we want.@@ -479,12 +483,12 @@ | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')' -- ptrs, nptrs, closure type, description, type, fun type {% liftP . withHomeUnitId $ \pkg ->- do dflags <- getDynFlags- let prof = profilingInfo dflags $11 $13+ 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 dflags False (fromIntegral $5)+ mkHeapRep profile False (fromIntegral $5) (fromIntegral $7) ty return (mkCmmEntryLabel pkg $3, Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3@@ -497,12 +501,12 @@ | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' -- ptrs, nptrs, tag, closure type, description, type {% liftP . withHomeUnitId $ \pkg ->- do dflags <- getDynFlags- let prof = profilingInfo dflags $13 $15+ do profile <- getProfile+ let prof = profilingInfo profile $13 $15 ty = Constr (fromIntegral $9) -- Tag (BS8.pack $13) rep = mkRTSRep (fromIntegral $11) $- mkHeapRep dflags False (fromIntegral $5)+ mkHeapRep profile False (fromIntegral $5) (fromIntegral $7) ty return (mkCmmEntryLabel pkg $3, Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3@@ -516,11 +520,11 @@ | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')' -- selector, closure type, description, type {% liftP . withHomeUnitId $ \pkg ->- do dflags <- getDynFlags- let prof = profilingInfo dflags $9 $11+ do profile <- getProfile+ let prof = profilingInfo profile $9 $11 ty = ThunkSelector (fromIntegral $5) rep = mkRTSRep (fromIntegral $7) $- mkHeapRep dflags False 0 0 ty+ mkHeapRep profile False 0 0 ty return (mkCmmEntryLabel pkg $3, Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 , cit_rep = rep@@ -541,8 +545,7 @@ | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')' -- closure type, live regs {% liftP . withHomeUnitId $ \pkg ->- do dflags <- getDynFlags- let platform = targetPlatform dflags+ do platform <- getPlatform live <- sequence $7 let prof = NoProfilingInfo -- drop one for the info pointer@@ -686,8 +689,8 @@ vols :: { [GlobalReg] } : '[' ']' { [] }- | '[' '*' ']' {% do df <- getDynFlags- ; return (realArgRegsCover df) }+ | '[' '*' ']' {% do platform <- PD.getPlatform+ ; return (realArgRegsCover platform) } -- All of them. See comment attached -- to realArgRegsCover | '[' globals ']' { $2 }@@ -771,7 +774,7 @@ -- leaving out the type of a literal gives you the native word size in C-- maybe_ty :: { CmmType }- : {- empty -} {% do dflags <- getDynFlags; return $ bWord (targetPlatform dflags) }+ : {- empty -} {% do platform <- PD.getPlatform; return $ bWord platform } | '::' type { $2 } cmm_hint_exprs0 :: { [CmmParse (CmmExpr, ForeignHint)] }@@ -860,7 +863,7 @@ | 'bits512' { b512 } | 'float32' { f32 } | 'float64' { f64 }- | 'gcptr' {% do dflags <- getDynFlags; return $ gcWord (targetPlatform dflags) }+ | 'gcptr' {% do platform <- PD.getPlatform; return $ gcWord platform } { section :: String -> SectionType@@ -880,8 +883,7 @@ -- the op. mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr mkMachOp fn args = do- dflags <- getDynFlags- let platform = targetPlatform dflags+ platform <- getPlatform arg_exprs <- sequence args return (CmmMachOp (fn (typeWidth (cmmExprType platform (head arg_exprs)))) arg_exprs) @@ -898,8 +900,8 @@ exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr) exprOp name args_code = do- dflags <- getDynFlags- case lookupUFM (exprMacros dflags) name of+ ptr_opts <- PD.getPtrOpts+ case lookupUFM (exprMacros ptr_opts) name of Just f -> return $ do args <- sequence args_code return (f args)@@ -907,20 +909,22 @@ mo <- nameToMachOp name return $ mkMachOp mo args_code -exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr)-exprMacros dflags = listToUFM [+exprMacros :: PtrOpts -> UniqFM FastString ([CmmExpr] -> CmmExpr)+exprMacros ptr_opts = listToUFM [ ( fsLit "ENTRY_CODE", \ [x] -> entryCode platform x ),- ( fsLit "INFO_PTR", \ [x] -> closureInfoPtr dflags x ),- ( fsLit "STD_INFO", \ [x] -> infoTable dflags x ),- ( fsLit "FUN_INFO", \ [x] -> funInfoTable dflags x ),- ( fsLit "GET_ENTRY", \ [x] -> entryCode platform (closureInfoPtr dflags x) ),- ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr dflags x) ),- ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr dflags x) ),- ( fsLit "INFO_TYPE", \ [x] -> infoTableClosureType dflags x ),- ( fsLit "INFO_PTRS", \ [x] -> infoTablePtrs dflags x ),- ( fsLit "INFO_NPTRS", \ [x] -> infoTableNonPtrs dflags x )+ ( fsLit "INFO_PTR", \ [x] -> closureInfoPtr ptr_opts x ),+ ( fsLit "STD_INFO", \ [x] -> infoTable profile x ),+ ( fsLit "FUN_INFO", \ [x] -> funInfoTable profile x ),+ ( fsLit "GET_ENTRY", \ [x] -> entryCode platform (closureInfoPtr ptr_opts x) ),+ ( fsLit "GET_STD_INFO", \ [x] -> infoTable profile (closureInfoPtr ptr_opts x) ),+ ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable profile (closureInfoPtr ptr_opts x) ),+ ( fsLit "INFO_TYPE", \ [x] -> infoTableClosureType profile x ),+ ( fsLit "INFO_PTRS", \ [x] -> infoTablePtrs profile x ),+ ( fsLit "INFO_NPTRS", \ [x] -> infoTableNonPtrs profile x ) ]- where platform = targetPlatform dflags+ where+ profile = po_profile ptr_opts+ platform = profilePlatform profile -- we understand a subset of C-- primitives: machOps = listToUFM $@@ -990,7 +994,7 @@ ( "i2f64", flip MO_SF_Conv W64 ) ] -callishMachOps :: UniqFM ([CmmExpr] -> (CallishMachOp, [CmmExpr]))+callishMachOps :: UniqFM FastString ([CmmExpr] -> (CallishMachOp, [CmmExpr])) callishMachOps = listToUFM $ map (\(x, y) -> (mkFastString x, y)) [ ( "read_barrier", (MO_ReadBarrier,)),@@ -1090,7 +1094,7 @@ args <- sequence args_code code (fcode args) -stmtMacros :: UniqFM ([CmmExpr] -> FCode ())+stmtMacros :: UniqFM FastString ([CmmExpr] -> FCode ()) stmtMacros = listToUFM [ ( fsLit "CCS_ALLOC", \[words,ccs] -> profAlloc words ccs ), ( fsLit "ENTER_CCS_THUNK", \[e] -> enterCostCentreThunk e ),@@ -1135,15 +1139,14 @@ emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode () emitPushUpdateFrame sp e = do- dflags <- getDynFlags- emitUpdateFrame dflags sp mkUpdInfoLabel e+ emitUpdateFrame sp mkUpdInfoLabel e pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse () pushStackFrame fields body = do- dflags <- getDynFlags+ profile <- getProfile exprs <- sequence fields updfr_off <- getUpdFrameOff- let (new_updfr_off, _, g) = copyOutOflow dflags NativeReturn Ret Old+ let (new_updfr_off, _, g) = copyOutOflow profile NativeReturn Ret Old [] updfr_off exprs emit g withUpdFrameOff new_updfr_off body@@ -1154,8 +1157,7 @@ -> CmmParse () -> CmmParse () reserveStackFrame psize preg body = do- dflags <- getDynFlags- let platform = targetPlatform dflags+ platform <- getPlatform old_updfr_off <- getUpdFrameOff reg <- preg esize <- psize@@ -1167,15 +1169,15 @@ emitAssign reg (CmmStackSlot Old frame) withUpdFrameOff frame body -profilingInfo dflags desc_str ty_str- = if not (sccProfilingEnabled dflags)+profilingInfo profile desc_str ty_str+ = if not (profileIsProfiling profile) then NoProfilingInfo else ProfilingInfo (BS8.pack desc_str) (BS8.pack ty_str) staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse () staticClosure pkg cl_label info payload- = do dflags <- getDynFlags- let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []+ = do profile <- getProfile+ let lits = mkStaticClosure profile (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] [] code $ emitDataLits (mkCmmDataLabel pkg (NeedExternDecl True) cl_label) lits foreignCall@@ -1192,12 +1194,11 @@ "stdcall" -> return StdCallConv _ -> failMsgPD ("unknown calling convention: " ++ conv_string) return $ do- dflags <- getDynFlags+ platform <- getPlatform results <- sequence results_code expr <- expr_code args <- sequence args_code let- platform = targetPlatform dflags expr' = adjCallTarget platform conv expr args (arg_exprs, arg_hints) = unzip args (res_regs, res_hints) = unzip results@@ -1209,34 +1210,34 @@ doReturn :: [CmmParse CmmExpr] -> CmmParse () doReturn exprs_code = do- dflags <- getDynFlags+ profile <- getProfile exprs <- sequence exprs_code updfr_off <- getUpdFrameOff- emit (mkReturnSimple dflags exprs updfr_off)+ emit (mkReturnSimple profile exprs updfr_off) -mkReturnSimple :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph-mkReturnSimple dflags actuals updfr_off =- mkReturn dflags e actuals updfr_off+mkReturnSimple :: Profile -> [CmmActual] -> UpdFrameOffset -> CmmAGraph+mkReturnSimple profile actuals updfr_off =+ mkReturn profile e actuals updfr_off where e = entryCode platform (CmmLoad (CmmStackSlot Old updfr_off) (gcWord platform))- platform = targetPlatform dflags+ platform = profilePlatform profile doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse () doRawJump expr_code vols = do- dflags <- getDynFlags+ profile <- getProfile expr <- expr_code updfr_off <- getUpdFrameOff- emit (mkRawJump dflags expr updfr_off vols)+ emit (mkRawJump profile expr updfr_off vols) doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr] -> [CmmParse CmmExpr] -> CmmParse () doJumpWithStack expr_code stk_code args_code = do- dflags <- getDynFlags+ profile <- getProfile expr <- expr_code stk_args <- sequence stk_code args <- sequence args_code updfr_off <- getUpdFrameOff- emit (mkJumpExtra dflags NativeNodeCall expr args updfr_off stk_args)+ emit (mkJumpExtra profile NativeNodeCall expr args updfr_off stk_args) doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr] -> CmmParse ()@@ -1276,7 +1277,7 @@ doStore :: CmmType -> CmmParse CmmExpr -> CmmParse CmmExpr -> CmmParse () doStore rep addr_code val_code- = do dflags <- getDynFlags+ = do platform <- getPlatform addr <- addr_code val <- val_code -- if the specified store type does not match the type of the expr@@ -1286,7 +1287,6 @@ -- be noticed. let val_width = typeWidth (cmmExprType platform val) rep_width = typeWidth rep- platform = targetPlatform dflags let coerce_val | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val] | otherwise = val@@ -1388,8 +1388,7 @@ table_entries <- mapM emitArm arms let table = M.fromList (concat table_entries) - dflags <- getDynFlags- let platform = targetPlatform dflags+ platform <- getPlatform let range = fromMaybe (0, platformMaxWord platform) mb_range expr <- scrut@@ -1414,14 +1413,14 @@ -- The initial environment: we define some constants that the compiler -- knows about here.-initEnv :: DynFlags -> Env-initEnv dflags = listToUFM [+initEnv :: Profile -> Env+initEnv profile = listToUFM [ ( fsLit "SIZEOF_StgHeader",- VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags)) (wordWidth platform)) )),+ VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize profile)) (wordWidth platform)) )), ( fsLit "SIZEOF_StgInfoTable",- VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth platform)) ))+ VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB profile)) (wordWidth platform)) )) ]- where platform = targetPlatform dflags+ where platform = profilePlatform profile parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup) parseCmmFile dflags filename = withTiming dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ do@@ -1436,7 +1435,7 @@ return (getMessages pst dflags, Nothing) POk pst code -> do st <- initC- let fcode = getCmm $ unEC code "global" (initEnv dflags) [] >> return ()+ 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)
compiler/GHC/Cmm/Pipeline.hs view
@@ -24,6 +24,7 @@ import GHC.Types.Unique.Supply import GHC.Driver.Session+import GHC.Driver.Backend import GHC.Utils.Error import GHC.Driver.Types import Control.Monad@@ -45,7 +46,7 @@ cmmPipeline hsc_env srtInfo prog = withTimingSilent dflags (text "Cmm pipeline") forceRes $ do let dflags = hsc_dflags hsc_env - tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog+ tops <- {-# SCC "tops" #-} mapM (cpsTop dflags) prog let (procs, data_) = partitionEithers tops (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo procs data_@@ -58,9 +59,9 @@ dflags = hsc_dflags hsc_env -cpsTop :: HscEnv -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl))-cpsTop _ p@(CmmData _ statics) = return (Right (cafAnalData statics, p))-cpsTop hsc_env proc =+cpsTop :: DynFlags -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl))+cpsTop dflags p@(CmmData _ statics) = return (Right (cafAnalData (targetPlatform dflags) statics, p))+cpsTop dflags proc = do ----------- Control-flow optimisations ---------------------------------- @@ -117,7 +118,7 @@ Opt_D_dump_cmm_sink "Sink assignments" ------------- CAF analysis ----------------------------------------------- let cafEnv = {-# SCC "cafAnal" #-} cafAnal call_pps l g+ let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform call_pps l g dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" FormatText (ppr cafEnv) g <- if splitting_proc_points@@ -152,8 +153,7 @@ return (Left (cafEnv, g)) - where dflags = hsc_dflags hsc_env- platform = targetPlatform dflags+ where platform = targetPlatform dflags dump = dumpGraph dflags dumps flag name@@ -171,7 +171,7 @@ -- tablesNextToCode is off. The latter is because we have no -- label to put on info tables for basic blocks that are not -- the entry point.- splitting_proc_points = hscTarget dflags /= HscAsm+ splitting_proc_points = backend dflags /= NCG || not (platformTablesNextToCode platform) || -- Note [inconsistent-pic-reg] usingInconsistentPicReg
compiler/GHC/Cmm/ProcPoint.hs view
@@ -319,7 +319,7 @@ tablesNextToCode = platformTablesNextToCode platform jump_label (Just info_lbl) _ | tablesNextToCode = info_lbl- | otherwise = toEntryLbl info_lbl+ | otherwise = toEntryLbl platform info_lbl jump_label Nothing block_lbl = block_lbl add_if_pp id rst = case mapLookup id procLabels of
compiler/GHC/Cmm/Sink.hs view
@@ -420,7 +420,7 @@ tryToInline dflags live node assigs = go usages node emptyLRegSet assigs where- usages :: UniqFM Int -- Maps each LocalReg to a count of how often it is used+ usages :: UniqFM LocalReg Int -- Maps each LocalReg to a count of how often it is used usages = foldLocalRegsUsed dflags addUsage emptyUFM node go _usages node _skipped [] = (node, [])@@ -553,7 +553,7 @@ -- inline y, and we have a dead assignment to x. If we don't notice -- that x is dead in tryToInline, we end up retaining it. -addUsage :: UniqFM Int -> LocalReg -> UniqFM Int+addUsage :: UniqFM LocalReg Int -> LocalReg -> UniqFM LocalReg Int addUsage m r = addToUFM_C (+) m r 1 regsUsedIn :: LRegSet -> CmmExpr -> Bool
compiler/GHC/Cmm/Switch/Implement.hs view
@@ -35,7 +35,7 @@ cmmImplementSwitchPlans :: DynFlags -> CmmGraph -> UniqSM CmmGraph cmmImplementSwitchPlans dflags g -- Switch generation done by backend (LLVM/C)- | targetSupportsSwitch (hscTarget dflags) = return g+ | backendSupportsSwitch (backend dflags) = return g | otherwise = do blocks' <- concatMapM (visitSwitches (targetPlatform dflags)) (toBlockList g) return $ ofBlockList (g_entry g) blocks'
compiler/GHC/Cmm/Utils.hs view
@@ -48,7 +48,7 @@ -- Tagging cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged,- cmmConstrTag1,+ cmmConstrTag1, mAX_PTR_TAG, tAG_MASK, -- Overlap and usage regsOverlap, regUsedIn,@@ -79,7 +79,6 @@ import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Utils.Outputable-import GHC.Driver.Session import GHC.Types.Unique import GHC.Platform.Regs @@ -428,26 +427,29 @@ -- --------------------------------------------------- +tAG_MASK :: Platform -> Int+tAG_MASK platform = (1 `shiftL` pc_TAG_BITS (platformConstants platform)) - 1++mAX_PTR_TAG :: Platform -> Int+mAX_PTR_TAG = tAG_MASK+ -- Tag bits mask-cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr-cmmTagMask dflags = mkIntExpr (targetPlatform dflags) (tAG_MASK dflags)-cmmPointerMask dflags = mkIntExpr (targetPlatform dflags) (complement (tAG_MASK dflags))+cmmTagMask, cmmPointerMask :: Platform -> CmmExpr+cmmTagMask platform = mkIntExpr platform (tAG_MASK platform)+cmmPointerMask platform = mkIntExpr platform (complement (tAG_MASK platform)) -- Used to untag a possibly tagged pointer -- A static label need not be untagged-cmmUntag, cmmIsTagged, cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr+cmmUntag, cmmIsTagged, cmmConstrTag1 :: Platform -> CmmExpr -> CmmExpr cmmUntag _ e@(CmmLit (CmmLabel _)) = e -- Default case-cmmUntag dflags e = cmmAndWord platform e (cmmPointerMask dflags)- where platform = targetPlatform dflags+cmmUntag platform e = cmmAndWord platform e (cmmPointerMask platform) -- Test if a closure pointer is untagged-cmmIsTagged dflags e = cmmNeWord platform (cmmAndWord platform e (cmmTagMask dflags)) (zeroExpr platform)- where platform = targetPlatform dflags+cmmIsTagged platform e = cmmNeWord platform (cmmAndWord platform e (cmmTagMask platform)) (zeroExpr platform) -- Get constructor tag, but one based.-cmmConstrTag1 dflags e = cmmAndWord platform e (cmmTagMask dflags)- where platform = targetPlatform dflags+cmmConstrTag1 platform e = cmmAndWord platform e (cmmTagMask platform) -----------------------------------------------------------------------------
compiler/GHC/CmmToAsm.hs view
@@ -66,6 +66,7 @@ import GHC.CmmToAsm.Instr import GHC.CmmToAsm.PIC import GHC.Platform.Reg+import GHC.Platform.Reg.Class (RegClass) import GHC.CmmToAsm.Monad import GHC.CmmToAsm.CFG import GHC.CmmToAsm.Dwarf@@ -558,7 +559,7 @@ -- rewrite assignments to global regs let fixed_cmm = {-# SCC "fixStgRegisters" #-}- fixStgRegisters dflags cmm+ fixStgRegisters platform cmm -- cmm to cmm optimisations let (opt_cmm, imports) =@@ -607,7 +608,7 @@ || gopt Opt_RegsIterative dflags ) then do -- the regs usable for allocation- let (alloc_regs :: UniqFM (UniqSet RealReg))+ let (alloc_regs :: UniqFM RegClass (UniqSet RealReg)) = foldr (\r -> plusUFM_C unionUniqSets $ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r)) emptyUFM@@ -890,7 +891,7 @@ | needImportedSymbols config = vcat $ (pprGotDeclaration config :) $- map ( pprImportedSymbol dflags config . fst . head) $+ map ( pprImportedSymbol config . fst . head) $ groupBy (\(_,a) (_,b) -> a == b) $ sortBy (\(_,a) (_,b) -> compare a b) $ map doPpr $@@ -900,7 +901,7 @@ doPpr lbl = (lbl, renderWithStyle (initSDocContext dflags astyle)- (pprCLabel dflags lbl))+ (pprCLabel_NCG platform lbl)) astyle = mkCodeStyle AsmStyle -- -----------------------------------------------------------------------------
compiler/GHC/CmmToAsm/BlockLayout.hs view
@@ -29,7 +29,6 @@ import GHC.Driver.Session (gopt, GeneralFlag(..), DynFlags, targetPlatform) import GHC.Types.Unique.FM import GHC.Utils.Misc-import GHC.Types.Unique import GHC.Data.Graph.Directed import GHC.Utils.Outputable@@ -926,8 +925,8 @@ = pprPanic "seqBlocks" (ppr tooManyNextNodes) -lookupDeleteUFM :: Uniquable key => UniqFM elt -> key- -> Maybe (elt, UniqFM elt)+lookupDeleteUFM :: UniqFM BlockId elt -> BlockId+ -> Maybe (elt, UniqFM BlockId elt) lookupDeleteUFM m k = do -- Maybe monad v <- lookupUFM m k return (v, delFromUFM m k)
compiler/GHC/CmmToAsm/Dwarf/Types.hs view
@@ -156,6 +156,13 @@ pprDwarfInfoClose noChildren = pprDwarfInfoOpen platform haveSrc d +-- | Print a CLabel name in a ".stringz \"LABEL\""+pprLabelString :: Platform -> CLabel -> SDoc+pprLabelString platform label =+ pprString' -- we don't need to escape the string as labels don't contain exotic characters+ $ withPprStyle (mkCodeStyle CStyle) -- force CStyle (foreign labels may be printed differently in AsmStyle)+ $ pprCLabel_NCG platform label+ -- | Prints assembler data corresponding to DWARF info records. Note -- that the binary format of this is parameterized in @abbrevDecls@ and -- has to be kept in synch.@@ -172,12 +179,11 @@ $$ if haveSrc then sectionOffset platform (ptext lineLbl) (ptext dwarfLineLabel) else empty-pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label- parent) = sdocWithDynFlags $ \df ->+pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label parent) = ppr (mkAsmTempDieLabel label) <> colon $$ pprAbbrev abbrev $$ pprString name- $$ pprString (renderWithStyle (initSDocContext df (mkCodeStyle CStyle)) (ppr label))+ $$ pprLabelString platform label $$ pprFlag (externallyVisibleCLabel label) $$ pprWord platform (ppr label) $$ pprWord platform (ppr $ mkAsmTempEndLabel label)@@ -189,14 +195,14 @@ Just _ -> DwAbbrSubprogramWithParent parentValue = maybe empty pprParentDie parent pprParentDie sym = sectionOffset platform (ppr sym) (ptext dwarfInfoLabel)-pprDwarfInfoOpen _ _ (DwarfBlock _ label Nothing) = sdocWithDynFlags $ \df ->+pprDwarfInfoOpen platform _ (DwarfBlock _ label Nothing) = ppr (mkAsmTempDieLabel label) <> colon $$ pprAbbrev DwAbbrBlockWithoutCode- $$ pprString (renderWithStyle (initSDocContext df (mkCodeStyle CStyle)) (ppr label))-pprDwarfInfoOpen platform _ (DwarfBlock _ label (Just marker)) = sdocWithDynFlags $ \df ->+ $$ pprLabelString platform label+pprDwarfInfoOpen platform _ (DwarfBlock _ label (Just marker)) = ppr (mkAsmTempDieLabel label) <> colon $$ pprAbbrev DwAbbrBlock- $$ pprString (renderWithStyle (initSDocContext df (mkCodeStyle CStyle)) (ppr label))+ $$ pprLabelString platform label $$ pprWord platform (ppr marker) $$ pprWord platform (ppr $ mkAsmTempEndLabel marker) pprDwarfInfoOpen _ _ (DwarfSrcNote ss) =
compiler/GHC/CmmToAsm/Monad.hs view
@@ -119,7 +119,7 @@ -- generated instructions. So instead we update the CFG as we go. } -type DwarfFiles = UniqFM (FastString, Int)+type DwarfFiles = UniqFM FastString (FastString, Int) newtype NatM result = NatM (NatM_State -> (result, NatM_State)) deriving (Functor)@@ -156,7 +156,6 @@ , ncgInlineThresholdMemcpy = fromIntegral $ maxInlineMemcpyInsns dflags , ncgInlineThresholdMemset = fromIntegral $ maxInlineMemsetInsns dflags , ncgSplitSections = gopt Opt_SplitSections dflags- , ncgSpillPreallocSize = rESERVED_C_STACK_BYTES dflags , ncgRegsIterative = gopt Opt_RegsIterative dflags , ncgAsmLinting = gopt Opt_DoAsmLinting dflags @@ -188,7 +187,6 @@ ArchX86 -> v _ -> Nothing }- initNat :: NatM_State -> NatM a -> (a, NatM_State) initNat init_st m
compiler/GHC/CmmToAsm/PIC.hs view
@@ -2,7 +2,7 @@ This module handles generation of position independent code and dynamic-linking related issues for the native code generator. - This depends both the architecture and OS, so we define it here+ This depends on both the architecture and OS, so we define it here instead of in one of the architecture specific modules. Things outside this module which are related to this:@@ -62,20 +62,13 @@ import GHC.Cmm.Dataflow.Collections import GHC.Cmm-import GHC.Cmm.CLabel ( CLabel, ForeignLabelSource(..), pprCLabel,- mkDynamicLinkerLabel, DynamicLinkerLabelInfo(..),- dynamicLinkerLabelInfo, mkPicBaseLabel,- labelDynamic, externallyVisibleCLabel )--import GHC.Cmm.CLabel ( mkForeignLabel )-+import GHC.Cmm.CLabel import GHC.Types.Basic import GHC.Unit.Module import GHC.Utils.Outputable -import GHC.Driver.Session import GHC.Data.FastString @@ -573,21 +566,21 @@ -- and one for non-PIC. -- -pprImportedSymbol :: DynFlags -> NCGConfig -> CLabel -> SDoc-pprImportedSymbol dflags config importedLbl = case (arch,os) of+pprImportedSymbol :: NCGConfig -> CLabel -> SDoc+pprImportedSymbol config importedLbl = case (arch,os) of (ArchX86, OSDarwin) | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl -> if not pic then vcat [ text ".symbol_stub",- text "L" <> pprCLabel dflags lbl <> ptext (sLit "$stub:"),- text "\t.indirect_symbol" <+> pprCLabel dflags lbl,- text "\tjmp *L" <> pprCLabel dflags lbl+ text "L" <> ppr_lbl lbl <> ptext (sLit "$stub:"),+ text "\t.indirect_symbol" <+> ppr_lbl lbl,+ text "\tjmp *L" <> ppr_lbl lbl <> text "$lazy_ptr",- text "L" <> pprCLabel dflags lbl+ text "L" <> ppr_lbl lbl <> text "$stub_binder:",- text "\tpushl $L" <> pprCLabel dflags lbl+ text "\tpushl $L" <> ppr_lbl lbl <> text "$lazy_ptr", text "\tjmp dyld_stub_binding_helper" ]@@ -595,16 +588,16 @@ vcat [ text ".section __TEXT,__picsymbolstub2," <> text "symbol_stubs,pure_instructions,25",- text "L" <> pprCLabel dflags lbl <> ptext (sLit "$stub:"),- text "\t.indirect_symbol" <+> pprCLabel dflags lbl,+ text "L" <> ppr_lbl lbl <> ptext (sLit "$stub:"),+ text "\t.indirect_symbol" <+> ppr_lbl lbl, text "\tcall ___i686.get_pc_thunk.ax", text "1:",- text "\tmovl L" <> pprCLabel dflags lbl+ text "\tmovl L" <> ppr_lbl lbl <> text "$lazy_ptr-1b(%eax),%edx", text "\tjmp *%edx",- text "L" <> pprCLabel dflags lbl+ text "L" <> ppr_lbl lbl <> text "$stub_binder:",- text "\tlea L" <> pprCLabel dflags lbl+ text "\tlea L" <> ppr_lbl lbl <> text "$lazy_ptr-1b(%eax),%eax", text "\tpushl %eax", text "\tjmp dyld_stub_binding_helper"@@ -612,16 +605,16 @@ $+$ vcat [ text ".section __DATA, __la_sym_ptr" <> (if pic then int 2 else int 3) <> text ",lazy_symbol_pointers",- text "L" <> pprCLabel dflags lbl <> ptext (sLit "$lazy_ptr:"),- text "\t.indirect_symbol" <+> pprCLabel dflags lbl,- text "\t.long L" <> pprCLabel dflags lbl+ text "L" <> ppr_lbl lbl <> ptext (sLit "$lazy_ptr:"),+ text "\t.indirect_symbol" <+> ppr_lbl lbl,+ text "\t.long L" <> ppr_lbl lbl <> text "$stub_binder"] | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl -> vcat [ text ".non_lazy_symbol_pointer",- char 'L' <> pprCLabel dflags lbl <> text "$non_lazy_ptr:",- text "\t.indirect_symbol" <+> pprCLabel dflags lbl,+ char 'L' <> ppr_lbl lbl <> text "$non_lazy_ptr:",+ text "\t.indirect_symbol" <+> ppr_lbl lbl, text "\t.long\t0"] | otherwise@@ -644,8 +637,8 @@ (_, OSAIX) -> case dynamicLinkerLabelInfo importedLbl of Just (SymbolPtr, lbl) -> vcat [- text "LC.." <> pprCLabel dflags lbl <> char ':',- text "\t.long" <+> pprCLabel dflags lbl ]+ text "LC.." <> ppr_lbl lbl <> char ':',+ text "\t.long" <+> ppr_lbl lbl ] _ -> empty -- ELF / Linux@@ -682,8 +675,8 @@ -> case dynamicLinkerLabelInfo importedLbl of Just (SymbolPtr, lbl) -> vcat [- text ".LC_" <> pprCLabel dflags lbl <> char ':',- text "\t.quad" <+> pprCLabel dflags lbl ]+ text ".LC_" <> ppr_lbl lbl <> char ':',+ text "\t.quad" <+> ppr_lbl lbl ] _ -> empty _ | osElfTarget os@@ -696,8 +689,8 @@ in vcat [ text ".section \".got2\", \"aw\"",- text ".LC_" <> pprCLabel dflags lbl <> char ':',- ptext symbolSize <+> pprCLabel dflags lbl ]+ text ".LC_" <> ppr_lbl lbl <> char ':',+ ptext symbolSize <+> ppr_lbl lbl ] -- PLT code stubs are generated automatically by the dynamic linker. _ -> empty@@ -705,8 +698,9 @@ _ -> panic "PIC.pprImportedSymbol: no match" where platform = ncgPlatform config- arch = platformArch platform- os = platformOS platform+ ppr_lbl = pprCLabel_NCG platform+ arch = platformArch platform+ os = platformOS platform pic = ncgPIC config --------------------------------------------------------------------------------
compiler/GHC/CmmToAsm/Reg/Graph.hs view
@@ -46,7 +46,7 @@ regAlloc :: (Outputable statics, Outputable instr, Instruction instr) => NCGConfig- -> UniqFM (UniqSet RealReg) -- ^ registers we can use for allocation+ -> UniqFM RegClass (UniqSet RealReg) -- ^ registers we can use for allocation -> UniqSet Int -- ^ set of available spill slots. -> Int -- ^ current number of spill slots -> [LiveCmmDecl statics instr] -- ^ code annotated with liveness information.@@ -96,7 +96,7 @@ -> Color.Triv VirtualReg RegClass RealReg -- ^ Function for calculating whether a register is trivially -- colourable.- -> UniqFM (UniqSet RealReg) -- ^ Free registers that we can allocate.+ -> UniqFM RegClass (UniqSet RealReg) -- ^ Free registers that we can allocate. -> UniqSet Int -- ^ Free stack slots that we can use. -> Int -- ^ Number of spill slots in use -> [RegAllocStats statics instr] -- ^ Current regalloc stats to add to.
compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs view
@@ -44,7 +44,7 @@ -- | Add a v1 = v2 register renaming to the map. -- The register with the lowest lexical name is set as the -- canonical version.-buildAlloc :: UniqFM Reg -> (Reg, Reg) -> UniqFM Reg+buildAlloc :: UniqFM Reg Reg -> (Reg, Reg) -> UniqFM Reg Reg buildAlloc fm (r1, r2) = let rmin = min r1 r2 rmax = max r1 r2@@ -53,7 +53,7 @@ -- | Determine the canonical name for a register by following -- v1 = v2 renamings in this map.-sinkReg :: UniqFM Reg -> Reg -> Reg+sinkReg :: UniqFM Reg Reg -> Reg -> Reg sinkReg fm r = case lookupUFM fm r of Nothing -> r
compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs view
@@ -10,6 +10,7 @@ import GHC.Prelude import GHC.CmmToAsm.Reg.Liveness+import GHC.CmmToAsm.Reg.Utils import GHC.CmmToAsm.Instr import GHC.Platform.Reg import GHC.Cmm hiding (RegSet)@@ -69,8 +70,11 @@ = do -- Allocate a slot for each of the spilled regs. let slots = take (sizeUniqSet regs) $ nonDetEltsUniqSet slotsFree- let regSlotMap = listToUFM- $ zip (nonDetEltsUniqSet regs) slots+ let+ regSlotMap = toRegMap -- Cast keys from VirtualReg to Reg+ -- See Note [UniqFM and the register allocator]+ $ listToUFM+ $ zip (nonDetEltsUniqSet regs) slots :: UniqFM Reg Int -- This is non-deterministic but we do not -- currently support deterministic code-generation. -- See Note [Unique Determinism and code generation]@@ -158,7 +162,7 @@ regSpill_block :: Instruction instr => Platform- -> UniqFM Int -- ^ map of vregs to slots they're being spilled to.+ -> UniqFM Reg Int -- ^ map of vregs to slots they're being spilled to. -> LiveBasicBlock instr -> SpillM (LiveBasicBlock instr) @@ -174,7 +178,7 @@ regSpill_instr :: Instruction instr => Platform- -> UniqFM Int -- ^ map of vregs to slots they're being spilled to.+ -> UniqFM Reg Int -- ^ map of vregs to slots they're being spilled to. -> LiveInstr instr -> SpillM [LiveInstr instr] @@ -223,7 +227,7 @@ -- writes to a vreg that is being spilled. spillRead :: Instruction instr- => UniqFM Int+ => UniqFM Reg Int -> instr -> Reg -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))@@ -246,7 +250,7 @@ -- writes to a vreg that is being spilled. spillWrite :: Instruction instr- => UniqFM Int+ => UniqFM Reg Int -> instr -> Reg -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))@@ -269,7 +273,7 @@ -- both reads and writes to a vreg that is being spilled. spillModify :: Instruction instr- => UniqFM Int+ => UniqFM Reg Int -> instr -> Reg -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))@@ -334,7 +338,7 @@ stateUS :: UniqSupply -- | Spilled vreg vs the number of times it was loaded, stored.- , stateSpillSL :: UniqFM (Reg, Int, Int) }+ , stateSpillSL :: UniqFM Reg (Reg, Int, Int) } -- | Create a new spiller state.@@ -366,7 +370,7 @@ -- Tells us what registers were spilled. data SpillStats = SpillStats- { spillStoreLoad :: UniqFM (Reg, Int, Int) }+ { spillStoreLoad :: UniqFM Reg (Reg, Int, Int) } -- | Extract spiller statistics from the spiller state.
compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-} -- | Clean out unneeded spill\/reload instructions. --@@ -340,7 +341,7 @@ cleanBackward' :: Instruction instr => BlockMap IntSet- -> UniqFM [BlockId]+ -> UniqFM Store [BlockId] -> UniqSet Int -> [LiveInstr instr] -> [LiveInstr instr]@@ -438,17 +439,17 @@ data CleanS = CleanS { -- | Regs which are valid at the start of each block.- sJumpValid :: UniqFM (Assoc Store)+ sJumpValid :: UniqFM BlockId (Assoc Store) -- | Collecting up what regs were valid across each jump. -- in the next pass we can collate these and write the results -- to sJumpValid.- , sJumpValidAcc :: UniqFM [Assoc Store]+ , sJumpValidAcc :: UniqFM BlockId [Assoc Store] -- | Map of (slot -> blocks which reload from this slot) -- used to decide if whether slot spilled to will ever be -- reloaded from on this path.- , sReloadedBy :: UniqFM [BlockId]+ , sReloadedBy :: UniqFM Store [BlockId] -- | Spills and reloads cleaned each pass (latest at front) , sCleanedCount :: [(Int, Int)]@@ -533,7 +534,8 @@ -- In the spill cleaner, two store locations are associated if they are known -- to hold the same value. ---type Assoc a = UniqFM (UniqSet a)+-- TODO: Monomorphize: I think we only ever use this with a ~ Store+type Assoc a = UniqFM a (UniqSet a) -- | An empty association emptyAssoc :: Assoc a@@ -541,8 +543,9 @@ -- | Add an association between these two things.-addAssoc :: Uniquable a- => a -> a -> Assoc a -> Assoc a+-- addAssoc :: Uniquable a+-- => a -> a -> Assoc a -> Assoc a+addAssoc :: Store -> Store -> Assoc Store -> Assoc Store addAssoc a b m = let m1 = addToUFM_C unionUniqSets m a (unitUniqSet b)@@ -551,9 +554,7 @@ -- | Delete all associations to a node.-delAssoc :: (Uniquable a)- => a -> Assoc a -> Assoc a-+delAssoc :: Store -> Assoc Store -> Assoc Store delAssoc a m | Just aSet <- lookupUFM m a , m1 <- delFromUFM m a@@ -565,9 +566,7 @@ -- | Delete a single association edge (a -> b).-delAssoc1 :: Uniquable a- => a -> a -> Assoc a -> Assoc a-+delAssoc1 :: Store -> Store -> Assoc Store -> Assoc Store delAssoc1 a b m | Just aSet <- lookupUFM m a = addToUFM m a (delOneFromUniqSet aSet b)@@ -576,17 +575,14 @@ -- | Check if these two things are associated.-elemAssoc :: (Uniquable a)- => a -> a -> Assoc a -> Bool+elemAssoc :: Store -> Store -> Assoc Store -> Bool elemAssoc a b m = elementOfUniqSet b (closeAssoc a m) -- | Find the refl. trans. closure of the association from this point.-closeAssoc :: (Uniquable a)- => a -> Assoc a -> UniqSet a-+closeAssoc :: Store -> Assoc Store -> UniqSet Store closeAssoc a assoc = closeAssoc' assoc emptyUniqSet (unitUniqSet a) where@@ -615,6 +611,6 @@ (unionUniqSets toVisit neighbors) -- | Intersect two associations.-intersectAssoc :: Assoc a -> Assoc a -> Assoc a+intersectAssoc :: Assoc Store -> Assoc Store -> Assoc Store intersectAssoc a b = intersectUFM_C (intersectUniqSets) a b
compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs view
@@ -48,9 +48,9 @@ -- | Map of `SpillCostRecord` type SpillCostInfo- = UniqFM SpillCostRecord+ = UniqFM VirtualReg SpillCostRecord -type SpillCostState = State (UniqFM SpillCostRecord) ()+type SpillCostState = State SpillCostInfo () -- | An empty map of spill costs. zeroSpillCostInfo :: SpillCostInfo@@ -264,7 +264,7 @@ -- | Extract a map of register lifetimes from a `SpillCostInfo`.-lifeMapFromSpillCostInfo :: SpillCostInfo -> UniqFM (VirtualReg, Int)+lifeMapFromSpillCostInfo :: SpillCostInfo -> UniqFM VirtualReg (VirtualReg, Int) lifeMapFromSpillCostInfo info = listToUFM $ map (\(r, _, _, life) -> (r, (r, life)))
compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs view
@@ -64,7 +64,7 @@ , raGraph :: Color.Graph VirtualReg RegClass RealReg -- | The regs that were coalesced.- , raCoalesced :: UniqFM VirtualReg+ , raCoalesced :: UniqFM VirtualReg VirtualReg -- | Spiller stats. , raSpillStats :: SpillStats@@ -88,7 +88,7 @@ , raGraphColored :: Color.Graph VirtualReg RegClass RealReg -- | Regs that were coalesced.- , raCoalesced :: UniqFM VirtualReg+ , raCoalesced :: UniqFM VirtualReg VirtualReg -- | Code with coalescings applied. , raCodeCoalesced :: [LiveCmmDecl statics instr]@@ -242,7 +242,7 @@ $$ text "\n") -binLifetimeCount :: UniqFM (VirtualReg, Int) -> UniqFM (Int, Int)+binLifetimeCount :: UniqFM VirtualReg (VirtualReg, Int) -> UniqFM Int (Int, Int) binLifetimeCount fm = let lifes = map (\l -> (l, (l, 1))) $ map snd
compiler/GHC/CmmToAsm/Reg/Linear.hs view
@@ -119,6 +119,7 @@ import qualified GHC.CmmToAsm.Reg.Linear.X86_64 as X86_64 import GHC.CmmToAsm.Reg.Target import GHC.CmmToAsm.Reg.Liveness+import GHC.CmmToAsm.Reg.Utils import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Config import GHC.Platform.Reg@@ -427,7 +428,7 @@ raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live)) = do- assig <- getAssigR+ assig <- getAssigR :: RegM freeRegs (UniqFM Reg Loc) -- If we have a reg->reg move between virtual registers, where the -- src register is not live after this instruction, and the dst@@ -486,7 +487,8 @@ | otherwise = False -genRaInsn :: OutputableRegConstraint freeRegs instr+genRaInsn :: forall freeRegs instr.+ OutputableRegConstraint freeRegs instr => BlockMap RegSet -> [instr] -> BlockId@@ -500,13 +502,13 @@ platform <- getPlatform case regUsageOfInstr platform instr of { RU read written -> do- let real_written = [ rr | (RegReal rr) <- written ]+ let real_written = [ rr | (RegReal rr) <- written ] :: [RealReg] let virt_written = [ vr | (RegVirtual vr) <- written ] -- we don't need to do anything with real registers that are -- only read by this instr. (the list is typically ~2 elements, -- so using nub isn't a problem).- let virt_read = nub [ vr | (RegVirtual vr) <- read ]+ let virt_read = nub [ vr | (RegVirtual vr) <- read ] :: [VirtualReg] -- debugging {- freeregs <- getFreeRegsR@@ -560,15 +562,20 @@ let -- (i) Patch the instruction+ patch_map :: UniqFM Reg Reg patch_map- = listToUFM+ = toRegMap $ -- Cast key from VirtualReg to Reg+ -- See Note [UniqFM and the register allocator]+ listToUFM [ (t, RegReal r) | (t, r) <- zip virt_read r_allocd ++ zip virt_written w_allocd ] + patched_instr :: instr patched_instr = patchRegsOfInstr adjusted_instr patchLookup + patchLookup :: Reg -> Reg patchLookup x = case lookupUFM patch_map x of Nothing -> x@@ -631,7 +638,8 @@ -- saveClobberedTemps- :: (Instruction instr, FR freeRegs)+ :: forall instr freeRegs.+ (Instruction instr, FR freeRegs) => [RealReg] -- real registers clobbered by this instruction -> [Reg] -- registers which are no longer live after this insn -> RegM freeRegs [instr] -- return: instructions to spill any temps that will@@ -642,8 +650,10 @@ saveClobberedTemps clobbered dying = do- assig <- getAssigR- let to_spill+ assig <- getAssigR :: RegM freeRegs (UniqFM Reg Loc)+ -- Unique represents the VirtualReg+ let to_spill :: [(Unique, RealReg)]+ to_spill = [ (temp,reg) | (temp, InReg reg) <- nonDetUFMToList assig -- This is non-deterministic but we do not@@ -657,6 +667,8 @@ return instrs where+ -- See Note [UniqFM and the register allocator]+ clobber :: RegMap Loc -> [instr] -> [(Unique,RealReg)] -> RegM freeRegs ([instr], RegMap Loc) clobber assig instrs [] = return (instrs, assig) @@ -675,7 +687,7 @@ (my_reg : _) -> do setFreeRegsR (frAllocateReg platform my_reg freeRegs) - let new_assign = addToUFM assig temp (InReg my_reg)+ let new_assign = addToUFM_Directly assig temp (InReg my_reg) let instr = mkRegRegMoveInstr platform (RegReal reg) (RegReal my_reg) @@ -688,7 +700,7 @@ -- record why this reg was spilled for profiling recordSpill (SpillClobber temp) - let new_assign = addToUFM assig temp (InBoth reg slot)+ let new_assign = addToUFM_Directly assig temp (InBoth reg slot) clobber new_assign (spill : instrs) rest @@ -719,12 +731,13 @@ -- also catches temps which were loaded up during allocation -- of read registers, not just those saved in saveClobberedTemps. + clobber :: RegMap Loc -> [(Unique,Loc)] -> RegMap Loc clobber assig [] = assig clobber assig ((temp, InBoth reg slot) : rest) | any (realRegsAlias reg) clobbered- = clobber (addToUFM assig temp (InMem slot)) rest+ = clobber (addToUFM_Directly assig temp (InMem slot)) rest clobber assig (_:rest) = clobber assig rest@@ -762,8 +775,9 @@ = return (spills, reverse alloc) allocateRegsAndSpill reading keep spills alloc (r:rs)- = do assig <- getAssigR :: RegM freeRegs (RegMap Loc)+ = do assig <- toVRegMap <$> getAssigR -- pprTraceM "allocateRegsAndSpill:assig" (ppr (r:rs) $$ ppr assig)+ -- See Note [UniqFM and the register allocator] let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig case lookupUFM assig r of -- case (1a): already in a register@@ -776,7 +790,7 @@ -- NB2. This is why we must process written registers here, even if they -- are also read by the same instruction. Just (InBoth my_reg _)- -> do when (not reading) (setAssigR (addToUFM assig r (InReg my_reg)))+ -> do when (not reading) (setAssigR $ toRegMap (addToUFM assig r (InReg my_reg))) allocateRegsAndSpill reading keep spills (my_reg:alloc) rs -- Not already in a register, so we need to find a free one...@@ -801,15 +815,14 @@ -- Note: I tried returning a list of past assignments, but that -- turned out to barely matter but added a few tenths of -- a percent to compile time.-findPrefRealReg :: forall freeRegs u. Uniquable u- => u -> RegM freeRegs (Maybe RealReg)+findPrefRealReg :: VirtualReg -> RegM freeRegs (Maybe RealReg) findPrefRealReg vreg = do bassig <- getBlockAssigR :: RegM freeRegs (BlockMap (freeRegs,RegMap Loc)) return $ foldr (findVirtRegAssig) Nothing bassig where findVirtRegAssig :: (freeRegs,RegMap Loc) -> Maybe RealReg -> Maybe RealReg findVirtRegAssig assig z =- z <|> case lookupUFM (snd assig) vreg of+ z <|> case lookupUFM (toVRegMap $ snd assig) vreg of Just (InReg real_reg) -> Just real_reg Just (InBoth real_reg _) -> Just real_reg _ -> z@@ -823,7 +836,7 @@ -> [RealReg] -> VirtualReg -> [VirtualReg]- -> UniqFM Loc+ -> UniqFM VirtualReg Loc -> SpillLoc -> RegM freeRegs ([instr], [RealReg]) allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc@@ -845,7 +858,8 @@ = first_free spills' <- loadTemp r spill_loc final_reg spills - setAssigR (addToUFM assig r $! newLocation spill_loc final_reg)+ setAssigR $ toRegMap+ $ (addToUFM assig r $! newLocation spill_loc final_reg) setFreeRegsR $ frAllocateReg platform final_reg freeRegs allocateRegsAndSpill reading keep spills' (final_reg : alloc) rs@@ -856,7 +870,7 @@ do let inRegOrBoth (InReg _) = True inRegOrBoth (InBoth _ _) = True inRegOrBoth _ = False- let candidates' :: UniqFM Loc+ let candidates' :: UniqFM VirtualReg Loc candidates' = flip delListFromUFM keep $ filterUFM inRegOrBoth $@@ -867,7 +881,8 @@ let candidates = nonDetUFMToList candidates' -- the vregs we could kick out that are already in a slot- let candidates_inBoth+ let candidates_inBoth :: [(Unique, RealReg, StackSlot)]+ candidates_inBoth = [ (temp, reg, mem) | (temp, InBoth reg mem) <- candidates , targetClassOfRealReg platform reg == classOfVirtualReg r ]@@ -885,10 +900,10 @@ -- just free up its register for use. | (temp, my_reg, slot) : _ <- candidates_inBoth = do spills' <- loadTemp r spill_loc my_reg spills- let assig1 = addToUFM assig temp (InMem slot)+ let assig1 = addToUFM_Directly assig temp (InMem slot) let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg - setAssigR assig2+ setAssigR $ toRegMap assig2 allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs -- otherwise, we need to spill a temporary that currently@@ -905,9 +920,9 @@ recordSpill (SpillAlloc temp_to_push_out) -- update the register assignment- let assig1 = addToUFM assig temp_to_push_out (InMem slot)+ let assig1 = addToUFM_Directly assig temp_to_push_out (InMem slot) let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg- setAssigR assig2+ setAssigR $ toRegMap assig2 -- if need be, load up a spilled temp into the reg we've just freed up. spills' <- loadTemp r spill_loc my_reg spills
compiler/GHC/CmmToAsm/Reg/Linear/Base.hs view
@@ -100,7 +100,9 @@ -- | Used to carry interesting stats out of the register allocator. data RegAllocStats = RegAllocStats- { ra_spillInstrs :: UniqFM [Int]+ { ra_spillInstrs :: UniqFM Unique [Int] -- Keys are the uniques of regs+ -- and taken from SpillReason+ -- See Note [UniqFM and the register allocator] , ra_fixupList :: [(BlockId,BlockId,BlockId)] -- ^ (from,fixup,to) : We inserted fixup code between from and to }
compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs view
@@ -146,8 +146,8 @@ -> instr -> BlockId -> [BlockId]- -> UniqFM Loc- -> UniqFM Loc+ -> UniqFM Reg Loc+ -> UniqFM Reg Loc -> RegM freeRegs ([NatBasicBlock instr], instr) joinToTargets_again block_live new_blocks block_id instr dest dests
compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs view
@@ -34,8 +34,9 @@ { -- | The slots that are still available to be allocated. stackMapNextFreeSlot :: !Int + -- See Note [UniqFM and the register allocator] -- | Assignment of vregs to stack slots.- , stackMapAssignment :: UniqFM StackSlot }+ , stackMapAssignment :: UniqFM Unique StackSlot } -- | An empty stack map, with all slots available.
compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs view
@@ -11,6 +11,7 @@ import GHC.CmmToAsm.Reg.Linear.Base import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Instr+import GHC.Types.Unique (Unique) import GHC.Types.Unique.FM import GHC.Utils.Outputable@@ -19,8 +20,8 @@ -- | Build a map of how many times each reg was alloced, clobbered, loaded etc. binSpillReasons- :: [SpillReason] -> UniqFM [Int]-+ :: [SpillReason] -> UniqFM Unique [Int]+ -- See Note [UniqFM and the register allocator] binSpillReasons reasons = addListToUFM_C (zipWith (+))@@ -61,6 +62,8 @@ pprStats code statss = let -- sum up all the instrs inserted by the spiller+ -- See Note [UniqFM and the register allocator]+ spills :: UniqFM Unique [Int] spills = foldl' (plusUFM_C (zipWith (+))) emptyUFM $ map ra_spillInstrs statss
compiler/GHC/CmmToAsm/Reg/Liveness.hs view
@@ -66,9 +66,14 @@ ----------------------------------------------------------------------------- type RegSet = UniqSet Reg -type RegMap a = UniqFM a+-- | Map from some kind of register to a.+--+-- While we give the type for keys as Reg which is the common case+-- sometimes we end up using VirtualReq or naked Uniques.+-- See Note [UniqFM and the register allocator]+type RegMap a = UniqFM Reg a -emptyRegMap :: UniqFM a+emptyRegMap :: RegMap a emptyRegMap = emptyUFM emptyRegSet :: RegSet@@ -76,7 +81,10 @@ type BlockMap a = LabelMap a +type SlotMap a = UniqFM Slot a +type Slot = Int+ -- | A top level thing which carries liveness information. type LiveCmmDecl statics instr = GenCmmDecl@@ -400,7 +408,7 @@ in unionManyBags (cs : moveBags) slurpCompM :: [LiveBasicBlock instr]- -> State (UniqFM [UniqFM Reg]) [Bag (Reg, Reg)]+ -> State (UniqFM BlockId [UniqFM Slot Reg]) [Bag (Reg, Reg)] slurpCompM blocks = do -- run the analysis once to record the mapping across jumps. mapM_ (slurpBlock False) blocks@@ -412,7 +420,7 @@ mapM (slurpBlock True) blocks slurpBlock :: Bool -> LiveBasicBlock instr- -> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg))+ -> State (UniqFM BlockId [UniqFM Slot Reg]) (Bag (Reg, Reg)) slurpBlock propagate (BasicBlock blockId instrs) = do -- grab the slot map for entry to this block slotMap <- if propagate@@ -422,12 +430,12 @@ (_, mMoves) <- mapAccumLM slurpLI slotMap instrs return $ listToBag $ catMaybes mMoves - slurpLI :: UniqFM Reg -- current slotMap+ slurpLI :: SlotMap Reg -- current slotMap -> LiveInstr instr- -> State (UniqFM [UniqFM Reg]) -- blockId -> [slot -> reg]+ -> State (UniqFM BlockId [SlotMap Reg]) -- blockId -> [slot -> reg] -- for tracking slotMaps across jumps - ( UniqFM Reg -- new slotMap+ ( SlotMap Reg -- new slotMap , Maybe (Reg, Reg)) -- maybe a new coalesce edge slurpLI slotMap li@@ -467,15 +475,18 @@ let slotMaps = fromMaybe [] (lookupUFM map blockId) return $ foldr mergeSlotMaps emptyUFM slotMaps - mergeSlotMaps :: UniqFM Reg -> UniqFM Reg -> UniqFM Reg+ mergeSlotMaps :: SlotMap Reg -> SlotMap Reg -> SlotMap Reg mergeSlotMaps map1 map2- = listToUFM+ -- toList sadly means we have to use the _Directly style+ -- functions.+ -- TODO: We shouldn't need to go through a list here.+ = listToUFM_Directly $ [ (k, r1) | (k, r1) <- nonDetUFMToList map1 -- This is non-deterministic but we do not -- currently support deterministic code-generation. -- See Note [Unique Determinism and code generation]- , case lookupUFM map2 k of+ , case lookupUFM_Directly map2 k of Nothing -> False Just r2 -> r1 == r2 ]
+ compiler/GHC/CmmToAsm/Reg/Utils.hs view
@@ -0,0 +1,59 @@+module GHC.CmmToAsm.Reg.Utils+ ( toRegMap, toVRegMap )+where++{- Note [UniqFM and the register allocator]+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++ Before UniqFM had a key type the register allocator+ wasn't picky about key types, using VirtualReg, Reg+ and Unique at various use sites for the same map.++ This is safe.+ * The Unique values come from registers at various+ points where we lose a reference to the original+ register value, but the unique is still valid.++ * VirtualReg is a subset of the registers in Reg's type.+ Making a value of VirtualReg into a Reg in fact doesn't+ change its unique. This is because Reg consists of virtual+ regs and real regs, whose unique values do not overlap.++ * Since the code was written in the assumption that keys are+ not typed it's hard to reverse this assumption now. So we get+ some gnarly but correct code where we often pass around Uniques+ and switch between using Uniques, VirtualReg and RealReg as keys+ of the same map. These issues were always there. But with the+ now-typed keys they become visible. It's a classic case of not all+ correct programs type checking.++ We reduce some of the burden by providing a way to cast++ UniqFM VirtualReg a++ to++ UniqFM Reg a++ in this module. This is safe as Reg is the sum of VirtualReg and+ RealReg. With each kind of register keeping the same unique when+ treated as Reg.++ TODO: If you take offense to this I encourage you to refactor this+ code. I'm sure we can do with less casting of keys and direct use+ of uniques. It might also be reasonable to just use a IntMap directly+ instead of dealing with UniqFM at all.+++-}+import GHC.Types.Unique.FM+import GHC.Platform.Reg++-- These should hopefully be zero cost.++toRegMap :: UniqFM VirtualReg elt -> UniqFM Reg elt+toRegMap = unsafeCastUFMKey++toVRegMap :: UniqFM Reg elt -> UniqFM VirtualReg elt+toVRegMap = unsafeCastUFMKey+
compiler/GHC/CmmToAsm/X86/RegInfo.hs view
@@ -38,13 +38,13 @@ Just str -> text str _ -> panic "Register not assigned a color" -regColors :: Platform -> UniqFM [Char]+regColors :: Platform -> UniqFM RealReg [Char] regColors platform = listToUFM (normalRegColors platform) -normalRegColors :: Platform -> [(Reg,String)]+normalRegColors :: Platform -> [(RealReg,String)] normalRegColors platform =- zip (map regSingle [0..lastint platform]) colors- ++ zip (map regSingle [firstxmm..lastxmm platform]) greys+ zip (map realRegSingle [0..lastint platform]) colors+ ++ zip (map realRegSingle [firstxmm..lastxmm platform]) greys where -- 16 colors - enough for amd64 gp regs colors = ["#800000","#ff0000","#808000","#ffff00","#008000"
compiler/GHC/CmmToC.hs view
@@ -19,9 +19,10 @@ -- ----------------------------------------------------------------------------- -module GHC.CmmToC (- writeC- ) where+module GHC.CmmToC+ ( cmmToC+ )+where #include "GhclibHsVersions.h" @@ -59,45 +60,38 @@ import Data.List (intersperse) import Data.Map (Map) import Data.Word-import System.IO import qualified Data.Map as Map import Control.Monad (ap) import qualified Data.Array.Unsafe as U ( castSTUArray ) import Data.Array.ST -- ----------------------------------------------------------------------------- Top level--writeC :: DynFlags -> Handle -> RawCmmGroup -> IO ()-writeC dflags handle cmm = printForC dflags handle (pprC dflags cmm $$ blankLine)---- -------------------------------------------------------------------------- -- Now do some real work -- -- for fun, we could call cmmToCmm over the tops... -- -pprC :: DynFlags -> RawCmmGroup -> SDoc-pprC dflags tops = vcat $ intersperse blankLine $ map (pprTop dflags) tops+cmmToC :: Platform -> RawCmmGroup -> SDoc+cmmToC platform tops = (vcat $ intersperse blankLine $ map (pprTop platform) tops) $$ blankLine -- -- top level procs ---pprTop :: DynFlags -> RawCmmDecl -> SDoc-pprTop dflags = \case+pprTop :: Platform -> RawCmmDecl -> SDoc+pprTop platform = \case (CmmProc infos clbl _in_live_regs graph) -> (case mapLookup (g_entry graph) infos of Nothing -> empty Just (CmmStaticsRaw info_clbl info_dat) -> pprDataExterns platform info_dat $$- pprWordArray dflags info_is_in_rodata info_clbl info_dat) $$+ pprWordArray platform info_is_in_rodata info_clbl info_dat) $$ (vcat [ blankLine, extern_decls, (if (externallyVisibleCLabel clbl) then mkFN_ else mkIF_) (ppr clbl) <+> lbrace, nest 8 temp_decls,- vcat (map (pprBBlock dflags) blocks),+ vcat (map (pprBBlock platform) blocks), rbrace ] ) where@@ -127,13 +121,12 @@ (CmmData section (CmmStaticsRaw lbl lits)) -> pprDataExterns platform lits $$- pprWordArray dflags (isSecConstant section) lbl lits+ pprWordArray platform (isSecConstant section) lbl lits where isSecConstant section = case sectionProtection section of ReadOnlySection -> True WriteProtectedSection -> True _ -> False- platform = targetPlatform dflags -- -------------------------------------------------------------------------- -- BasicBlocks are self-contained entities: they always end in a jump.@@ -142,10 +135,10 @@ -- as many jumps as possible into fall throughs. -- -pprBBlock :: DynFlags -> CmmBlock -> SDoc-pprBBlock dflags block =+pprBBlock :: Platform -> CmmBlock -> SDoc+pprBBlock platform block = nest 4 (pprBlockId (entryLabel block) <> colon) $$- nest 8 (vcat (map (pprStmt dflags) (blockToList nodes)) $$ pprStmt dflags last)+ nest 8 (vcat (map (pprStmt platform) (blockToList nodes)) $$ pprStmt platform last) where (_, nodes, last) = blockSplit block @@ -153,8 +146,8 @@ -- Info tables. Just arrays of words. -- See codeGen/ClosureInfo, and nativeGen/PprMach -pprWordArray :: DynFlags -> Bool -> CLabel -> [CmmStatic] -> SDoc-pprWordArray dflags is_ro lbl ds+pprWordArray :: Platform -> Bool -> CLabel -> [CmmStatic] -> SDoc+pprWordArray platform is_ro lbl ds = -- TODO: align closures only pprExternDecl platform lbl $$ hcat [ pprLocalness lbl, pprConstness is_ro, text "StgWord"@@ -162,10 +155,8 @@ -- See Note [StgWord alignment] , pprAlignment (wordWidth platform) , text "= {" ]- $$ nest 8 (commafy (pprStatics dflags ds))+ $$ nest 8 (commafy (pprStatics platform ds)) $$ text "};"- where- platform = targetPlatform dflags pprAlignment :: Width -> SDoc pprAlignment words =@@ -203,9 +194,8 @@ -- Statements. -- -pprStmt :: DynFlags -> CmmNode e x -> SDoc--pprStmt dflags stmt =+pprStmt :: Platform -> CmmNode e x -> SDoc+pprStmt platform stmt = case stmt of CmmEntry{} -> empty CmmComment _ -> empty -- (hang (text "/*") 3 (ftext s)) $$ ptext (sLit "*/")@@ -217,19 +207,18 @@ CmmTick _ -> empty CmmUnwind{} -> empty - CmmAssign dest src -> pprAssign dflags dest src+ CmmAssign dest src -> pprAssign platform dest src CmmStore dest src | typeWidth rep == W64 && wordWidth platform /= W64 -> (if isFloatType rep then text "ASSIGN_DBL" else ptext (sLit ("ASSIGN_Word64"))) <>- parens (mkP_ <> pprExpr1 dflags dest <> comma <> pprExpr dflags src) <> semi+ parens (mkP_ <> pprExpr1 platform dest <> comma <> pprExpr platform src) <> semi | otherwise- -> hsep [ pprExpr dflags (CmmLoad dest rep), equals, pprExpr dflags src <> semi ]+ -> hsep [ pprExpr platform (CmmLoad dest rep), equals, pprExpr platform src <> semi ] where rep = cmmExprType platform src- platform = targetPlatform dflags CmmUnsafeForeignCall target@(ForeignTarget fn conv) results args -> fnCall@@ -237,29 +226,28 @@ (res_hints, arg_hints) = foreignTargetHints target hresults = zip results res_hints hargs = zip args arg_hints- platform = targetPlatform dflags ForeignConvention cconv _ _ ret = conv - cast_fn = parens (cCast dflags (pprCFunType platform (char '*') cconv hresults hargs) fn)+ cast_fn = parens (cCast platform (pprCFunType platform (char '*') cconv hresults hargs) fn) -- See wiki:commentary/compiler/backends/ppr-c#prototypes fnCall = case fn of CmmLit (CmmLabel lbl) | StdCallConv <- cconv ->- pprCall dflags (ppr lbl) cconv hresults hargs+ pprCall platform (ppr lbl) cconv hresults hargs -- stdcall functions must be declared with -- a function type, otherwise the C compiler -- doesn't add the @n suffix to the label. We -- can't add the @n suffix ourselves, because -- it isn't valid C. | CmmNeverReturns <- ret ->- pprCall dflags cast_fn cconv hresults hargs <> semi+ pprCall platform cast_fn cconv hresults hargs <> semi | not (isMathFun lbl) ->- pprForeignCall dflags (ppr lbl) cconv hresults hargs+ pprForeignCall platform (ppr lbl) cconv hresults hargs _ ->- pprCall dflags cast_fn cconv hresults hargs <> semi+ pprCall platform cast_fn cconv hresults hargs <> semi -- for a dynamic call, no declaration is necessary. CmmUnsafeForeignCall (PrimTarget MO_Touch) _results _args -> empty@@ -282,28 +270,27 @@ -- builtins (see bug #5967). | Just _align <- machOpMemcpyishAlign op = (text ";EFF_(" <> fn <> char ')' <> semi) $$- pprForeignCall dflags fn cconv hresults hargs+ pprForeignCall platform fn cconv hresults hargs | otherwise- = pprCall dflags fn cconv hresults hargs+ = pprCall platform fn cconv hresults hargs CmmBranch ident -> pprBranch ident- CmmCondBranch expr yes no _ -> pprCondBranch dflags expr yes no- CmmCall { cml_target = expr } -> mkJMP_ (pprExpr dflags expr) <> semi- CmmSwitch arg ids -> pprSwitch dflags arg ids+ CmmCondBranch expr yes no _ -> pprCondBranch platform expr yes no+ CmmCall { cml_target = expr } -> mkJMP_ (pprExpr platform expr) <> semi+ CmmSwitch arg ids -> pprSwitch platform arg ids _other -> pprPanic "PprC.pprStmt" (ppr stmt) type Hinted a = (a, ForeignHint) -pprForeignCall :: DynFlags -> SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual]+pprForeignCall :: Platform -> SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc-pprForeignCall dflags fn cconv results args = fn_call+pprForeignCall platform fn cconv results args = fn_call where- platform = targetPlatform dflags fn_call = braces ( pprCFunType platform (char '*' <> text "ghcFunPtr") cconv results args <> semi $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi- $$ pprCall dflags (text "ghcFunPtr") cconv results args <> semi+ $$ pprCall platform (text "ghcFunPtr") cconv results args <> semi ) cast_fn = parens (parens (pprCFunType platform (char '*') cconv results args) <> fn) @@ -326,9 +313,9 @@ -- --------------------------------------------------------------------- -- conditional branches to local labels-pprCondBranch :: DynFlags -> CmmExpr -> BlockId -> BlockId -> SDoc-pprCondBranch dflags expr yes no- = hsep [ text "if" , parens(pprExpr dflags expr) ,+pprCondBranch :: Platform -> CmmExpr -> BlockId -> BlockId -> SDoc+pprCondBranch platform expr yes no+ = hsep [ text "if" , parens (pprExpr platform expr) , text "goto", pprBlockId yes <> semi, text "else goto", pprBlockId no <> semi ] @@ -337,23 +324,22 @@ -- -- we find the fall-through cases ---pprSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> SDoc-pprSwitch dflags e ids- = (hang (text "switch" <+> parens ( pprExpr dflags e ) <+> lbrace)+pprSwitch :: Platform -> CmmExpr -> SwitchTargets -> SDoc+pprSwitch platform e ids+ = (hang (text "switch" <+> parens ( pprExpr platform e ) <+> lbrace) 4 (vcat ( map caseify pairs ) $$ def)) $$ rbrace where (pairs, mbdef) = switchTargetsFallThrough ids- platform = targetPlatform dflags -- fall through case caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix where do_fallthrough ix =- hsep [ text "case" , pprHexVal dflags ix (wordWidth platform) <> colon ,+ hsep [ text "case" , pprHexVal platform ix (wordWidth platform) <> colon , text "/* fall through */" ] final_branch ix =- hsep [ text "case" , pprHexVal dflags ix (wordWidth platform) <> colon ,+ hsep [ text "case" , pprHexVal platform ix (wordWidth platform) <> colon , text "goto" , (pprBlockId ident) <> semi ] caseify (_ , _ ) = panic "pprSwitch: switch with no cases!"@@ -375,30 +361,28 @@ -- -- (similar invariants apply to the rest of the pretty printer). -pprExpr :: DynFlags -> CmmExpr -> SDoc-pprExpr dflags e = case e of- CmmLit lit -> pprLit dflags lit- CmmLoad e ty -> pprLoad dflags e ty+pprExpr :: Platform -> CmmExpr -> SDoc+pprExpr platform e = case e of+ CmmLit lit -> pprLit platform lit+ CmmLoad e ty -> pprLoad platform e ty CmmReg reg -> pprCastReg reg CmmRegOff reg 0 -> pprCastReg reg -- CmmRegOff is an alias of MO_Add CmmRegOff reg i -> pprCastReg reg <> char '+' <>- pprHexVal dflags (fromIntegral i) (wordWidth platform)+ pprHexVal platform (fromIntegral i) (wordWidth platform) - CmmMachOp mop args -> pprMachOpApp dflags mop args+ CmmMachOp mop args -> pprMachOpApp platform mop args CmmStackSlot _ _ -> panic "pprExpr: CmmStackSlot not supported!"- where- platform = targetPlatform dflags -pprLoad :: DynFlags -> CmmExpr -> CmmType -> SDoc-pprLoad dflags e ty+pprLoad :: Platform -> CmmExpr -> CmmType -> SDoc+pprLoad platform e ty | width == W64, wordWidth platform /= W64 = (if isFloatType ty then text "PK_DBL" else text "PK_Word64")- <> parens (mkP_ <> pprExpr1 dflags e)+ <> parens (mkP_ <> pprExpr1 platform e) | otherwise = case e of@@ -414,34 +398,33 @@ -- (For tagging to work, I had to avoid unaligned loads. --ARY) -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift platform)) - _other -> cLoad dflags e ty+ _other -> cLoad platform e ty where width = typeWidth ty- platform = targetPlatform dflags -pprExpr1 :: DynFlags -> CmmExpr -> SDoc-pprExpr1 dflags e = case e of- CmmLit lit -> pprLit1 dflags lit- CmmReg _reg -> pprExpr dflags e- _ -> parens (pprExpr dflags e)+pprExpr1 :: Platform -> CmmExpr -> SDoc+pprExpr1 platform e = case e of+ CmmLit lit -> pprLit1 platform lit+ CmmReg _reg -> pprExpr platform e+ _ -> parens (pprExpr platform e) -- -------------------------------------------------------------------------- -- MachOp applications -pprMachOpApp :: DynFlags -> MachOp -> [CmmExpr] -> SDoc+pprMachOpApp :: Platform -> MachOp -> [CmmExpr] -> SDoc -pprMachOpApp dflags op args+pprMachOpApp platform op args | isMulMayOfloOp op- = text "mulIntMayOflo" <> parens (commafy (map (pprExpr dflags) args))+ = text "mulIntMayOflo" <> parens (commafy (map (pprExpr platform) args)) where isMulMayOfloOp (MO_U_MulMayOflo _) = True isMulMayOfloOp (MO_S_MulMayOflo _) = True isMulMayOfloOp _ = False -pprMachOpApp dflags mop args+pprMachOpApp platform mop args | Just ty <- machOpNeedsCast mop- = ty <> parens (pprMachOpApp' dflags mop args)+ = ty <> parens (pprMachOpApp' platform mop args) | otherwise- = pprMachOpApp' dflags mop args+ = pprMachOpApp' platform mop args -- Comparisons in C have type 'int', but we want type W_ (this is what -- resultRepOfMachOp says). The other C operations inherit their type@@ -451,8 +434,8 @@ | isComparisonMachOp mop = Just mkW_ | otherwise = Nothing -pprMachOpApp' :: DynFlags -> MachOp -> [CmmExpr] -> SDoc-pprMachOpApp' dflags mop args+pprMachOpApp' :: Platform -> MachOp -> [CmmExpr] -> SDoc+pprMachOpApp' platform mop args = case args of -- dyadic [x,y] -> pprArg x <+> pprMachOp_for_C platform mop <+> pprArg y@@ -463,11 +446,10 @@ _ -> panic "PprC.pprMachOp : machop with wrong number of args" where- platform = targetPlatform dflags -- Cast needed for signed integer ops- pprArg e | signedOp mop = cCast dflags (machRep_S_CType platform (typeWidth (cmmExprType platform e))) e- | needsFCasts mop = cCast dflags (machRep_F_CType (typeWidth (cmmExprType platform e))) e- | otherwise = pprExpr1 dflags e+ pprArg e | signedOp mop = cCast platform (machRep_S_CType platform (typeWidth (cmmExprType platform e))) e+ | needsFCasts mop = cCast platform (machRep_F_CType (typeWidth (cmmExprType platform e))) e+ | otherwise = pprExpr1 platform e needsFCasts (MO_F_Eq _) = False needsFCasts (MO_F_Ne _) = False needsFCasts (MO_F_Neg _) = True@@ -477,9 +459,9 @@ -- -------------------------------------------------------------------------- -- Literals -pprLit :: DynFlags -> CmmLit -> SDoc-pprLit dflags lit = case lit of- CmmInt i rep -> pprHexVal dflags i rep+pprLit :: Platform -> CmmLit -> SDoc+pprLit platform lit = case lit of+ CmmInt i rep -> pprHexVal platform i rep CmmFloat f w -> parens (machRep_F_CType w) <> str where d = fromRational f :: Double@@ -505,38 +487,37 @@ where pprCLabelAddr lbl = char '&' <> ppr lbl -pprLit1 :: DynFlags -> CmmLit -> SDoc-pprLit1 dflags lit = case lit of- (CmmLabelOff _ _) -> parens (pprLit dflags lit)- (CmmLabelDiffOff _ _ _ _) -> parens (pprLit dflags lit)- (CmmFloat _ _) -> parens (pprLit dflags lit)- _ -> pprLit dflags lit+pprLit1 :: Platform -> CmmLit -> SDoc+pprLit1 platform lit = case lit of+ (CmmLabelOff _ _) -> parens (pprLit platform lit)+ (CmmLabelDiffOff _ _ _ _) -> parens (pprLit platform lit)+ (CmmFloat _ _) -> parens (pprLit platform lit)+ _ -> pprLit platform lit -- --------------------------------------------------------------------------- -- Static data -pprStatics :: DynFlags -> [CmmStatic] -> [SDoc]-pprStatics dflags = pprStatics'+pprStatics :: Platform -> [CmmStatic] -> [SDoc]+pprStatics platform = pprStatics' where- platform = targetPlatform dflags pprStatics' = \case [] -> [] (CmmStaticLit (CmmFloat f W32) : rest) -- odd numbers of floats are padded to a word by mkVirtHeapOffsetsWithPadding | wordWidth platform == W64, CmmStaticLit (CmmInt 0 W32) : rest' <- rest- -> pprLit1 dflags (floatToWord platform f) : pprStatics' rest'+ -> pprLit1 platform (floatToWord platform f) : pprStatics' rest' -- adjacent floats aren't padded but combined into a single word | wordWidth platform == W64, CmmStaticLit (CmmFloat g W32) : rest' <- rest- -> pprLit1 dflags (floatPairToWord platform f g) : pprStatics' rest'+ -> pprLit1 platform (floatPairToWord platform f g) : pprStatics' rest' | wordWidth platform == W32- -> pprLit1 dflags (floatToWord platform f) : pprStatics' rest+ -> pprLit1 platform (floatToWord platform f) : pprStatics' rest | otherwise -> pprPanic "pprStatics: float" (vcat (map ppr' rest)) where ppr' (CmmStaticLit l) = ppr (cmmLitType platform l) ppr' _other = text "bad static!" (CmmStaticLit (CmmFloat f W64) : rest)- -> map (pprLit1 dflags) (doubleToWords platform f) ++ pprStatics' rest+ -> map (pprLit1 platform) (doubleToWords platform f) ++ pprStatics' rest (CmmStaticLit (CmmInt i W64) : rest) | wordWidth platform == W32@@ -565,15 +546,15 @@ -> pprPanic "pprStatics: cannot emit a non-word-sized static literal" (ppr w) (CmmStaticLit lit : rest)- -> pprLit1 dflags lit : pprStatics' rest+ -> pprLit1 platform lit : pprStatics' rest (other : _)- -> pprPanic "pprStatics: other" (pprStatic dflags other)+ -> pprPanic "pprStatics: other" (pprStatic platform other) -pprStatic :: DynFlags -> CmmStatic -> SDoc-pprStatic dflags s = case s of+pprStatic :: Platform -> CmmStatic -> SDoc+pprStatic platform s = case s of - CmmStaticLit lit -> nest 4 (pprLit dflags lit)+ CmmStaticLit lit -> nest 4 (pprLit platform lit) CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i)) -- these should be inlined, like the old .hc@@ -881,7 +862,7 @@ -- -- Generating assignments is what we're all about, here ---pprAssign :: DynFlags -> CmmReg -> CmmExpr -> SDoc+pprAssign :: Platform -> CmmReg -> CmmExpr -> SDoc -- dest is a reg, rhs is a reg pprAssign _ r1 (CmmReg r2)@@ -889,11 +870,10 @@ = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ] -- dest is a reg, rhs is a CmmRegOff-pprAssign dflags r1 (CmmRegOff r2 off)+pprAssign platform r1 (CmmRegOff r2 off) | isPtrReg r1 && isPtrReg r2 && (off `rem` platformWordSizeInBytes platform == 0) = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ] where- platform = targetPlatform dflags off1 = off `shiftR` wordShift platform (op,off') | off >= 0 = (char '+', off1)@@ -902,10 +882,10 @@ -- dest is a reg, rhs is anything. -- We can't cast the lvalue, so we have to cast the rhs if necessary. Casting -- the lvalue elicits a warning from new GCC versions (3.4+).-pprAssign dflags r1 r2- | isFixedPtrReg r1 = mkAssign (mkP_ <> pprExpr1 dflags r2)- | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 dflags r2)- | otherwise = mkAssign (pprExpr dflags r2)+pprAssign platform r1 r2+ | isFixedPtrReg r1 = mkAssign (mkP_ <> pprExpr1 platform r2)+ | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 platform r2)+ | otherwise = mkAssign (pprExpr platform r2) where mkAssign x = if r1 == CmmGlobal BaseReg then text "ASSIGN_BaseReg" <> parens x <> semi else pprReg r1 <> text " = " <> x <> semi@@ -1004,8 +984,8 @@ -- ----------------------------------------------------------------------------- -- Foreign Calls -pprCall :: DynFlags -> SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc-pprCall dflags ppr_fn cconv results args+pprCall :: Platform -> SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc+pprCall platform ppr_fn cconv results args | not (is_cishCC cconv) = panic $ "pprCall: unknown calling convention" @@ -1013,8 +993,6 @@ = ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi where- platform = targetPlatform dflags- ppr_assign [] rhs = rhs ppr_assign [(one,hint)] rhs = pprLocalReg one <> text " = "@@ -1022,12 +1000,12 @@ ppr_assign _other _rhs = panic "pprCall: multiple results" pprArg (expr, AddrHint)- = cCast dflags (text "void *") expr+ = cCast platform (text "void *") expr -- see comment by machRepHintCType below pprArg (expr, SignedHint)- = cCast dflags (machRep_S_CType platform $ typeWidth $ cmmExprType platform expr) expr+ = cCast platform (machRep_S_CType platform $ typeWidth $ cmmExprType platform expr) expr pprArg (expr, _other)- = pprExpr dflags expr+ = pprExpr platform expr pprUnHint AddrHint rep = parens (machRepCType platform rep) pprUnHint SignedHint rep = parens (machRepCType platform rep)@@ -1159,18 +1137,18 @@ -- --------------------------------------------------------------------- -- C types for MachReps -cCast :: DynFlags -> SDoc -> CmmExpr -> SDoc-cCast dflags ty expr = parens ty <> pprExpr1 dflags expr+cCast :: Platform -> SDoc -> CmmExpr -> SDoc+cCast platform ty expr = parens ty <> pprExpr1 platform expr -cLoad :: DynFlags -> CmmExpr -> CmmType -> SDoc-cLoad dflags expr rep+cLoad :: Platform -> CmmExpr -> CmmType -> SDoc+cLoad platform expr rep = if bewareLoadStoreAlignment (platformArch platform) then let decl = machRepCType platform rep <+> text "x" <> semi struct = text "struct" <+> braces (decl) packed_attr = text "__attribute__((packed))" cast = parens (struct <+> packed_attr <> char '*')- in parens (cast <+> pprExpr1 dflags expr) <> text "->x"- else char '*' <> parens (cCast dflags (machRepPtrCType platform rep) expr)+ in parens (cast <+> pprExpr1 platform expr) <> text "->x"+ else char '*' <> parens (cCast platform (machRepPtrCType platform rep) expr) where -- On these platforms, unaligned loads are known to cause problems bewareLoadStoreAlignment ArchAlpha = True bewareLoadStoreAlignment ArchMipseb = True@@ -1183,7 +1161,6 @@ -- on unknown arches bewareLoadStoreAlignment ArchUnknown = True bewareLoadStoreAlignment _ = False- platform = targetPlatform dflags isCmmWordType :: Platform -> CmmType -> Bool -- True of GcPtrReg/NonGcReg of native word size@@ -1345,8 +1322,8 @@ commafy xs = hsep $ punctuate comma xs -- Print in C hex format: 0x13fa-pprHexVal :: DynFlags -> Integer -> Width -> SDoc-pprHexVal dflags w rep+pprHexVal :: Platform -> Integer -> Width -> SDoc+pprHexVal platform w rep | w < 0 = parens (char '-' <> text "0x" <> intToDoc (-w) <> repsuffix rep) | otherwise = text "0x" <> intToDoc w <> repsuffix rep@@ -1357,10 +1334,12 @@ -- times values are unsigned. This also helps eliminate occasional -- warnings about integer overflow from gcc. + constants = platformConstants platform+ repsuffix W64 =- if cINT_SIZE dflags == 8 then char 'U'- else if cLONG_SIZE dflags == 8 then text "UL"- else if cLONG_LONG_SIZE dflags == 8 then text "ULL"+ if pc_CINT_SIZE constants == 8 then char 'U'+ else if pc_CLONG_SIZE constants == 8 then text "UL"+ else if pc_CLONG_LONG_SIZE constants == 8 then text "ULL" else panic "pprHexVal: Can't find a 64-bit type" repsuffix _ = char 'U'
compiler/GHC/CmmToLlvm.hs view
@@ -159,8 +159,8 @@ cmmLlvmGen cmm@CmmProc{} = do -- rewrite assignments to global regs- dflags <- getDynFlags- let fixed_cmm = {-# SCC "llvm_fix_regs" #-} fixStgRegisters dflags cmm+ platform <- getPlatform+ let fixed_cmm = {-# SCC "llvm_fix_regs" #-} fixStgRegisters platform cmm dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm" FormatCMM (pprCmmGroup [fixed_cmm])
compiler/GHC/CmmToLlvm/Base.hs view
@@ -305,7 +305,7 @@ , envOutput :: BufHandle -- ^ Output buffer , envMask :: !Char -- ^ Mask for creating unique values , envFreshMeta :: MetaId -- ^ Supply of fresh metadata IDs- , envUniqMeta :: UniqFM MetaId -- ^ Global metadata nodes+ , envUniqMeta :: UniqFM Unique MetaId -- ^ Global metadata nodes , envFunMap :: LlvmEnvMap -- ^ Global functions so far, with type , envAliases :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References] , envUsedVars :: [LlvmVar] -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@)@@ -315,7 +315,7 @@ , envStackRegs :: [GlobalReg] -- ^ Non-constant registers (alloca'd in the function prelude) } -type LlvmEnvMap = UniqFM LlvmType+type LlvmEnvMap = UniqFM Unique LlvmType -- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) }@@ -397,13 +397,13 @@ -- | Insert variables or functions into the environment. varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmM ()-varInsert s t = modifyEnv $ \env -> env { envVarMap = addToUFM (envVarMap env) s t }-funInsert s t = modifyEnv $ \env -> env { envFunMap = addToUFM (envFunMap env) s t }+varInsert s t = modifyEnv $ \env -> env { envVarMap = addToUFM (envVarMap env) (getUnique s) t }+funInsert s t = modifyEnv $ \env -> env { envFunMap = addToUFM (envFunMap env) (getUnique s) t } -- | Lookup variables or functions in the environment. varLookup, funLookup :: Uniquable key => key -> LlvmM (Maybe LlvmType)-varLookup s = getEnv (flip lookupUFM s . envVarMap)-funLookup s = getEnv (flip lookupUFM s . envFunMap)+varLookup s = getEnv (flip lookupUFM (getUnique s) . envVarMap)+funLookup s = getEnv (flip lookupUFM (getUnique s) . envFunMap) -- | Set a register as allocated on the stack markStackReg :: GlobalReg -> LlvmM ()@@ -496,7 +496,8 @@ strCLabel_llvm :: CLabel -> LlvmM LMString strCLabel_llvm lbl = do dflags <- getDynFlags- let sdoc = pprCLabel dflags lbl+ platform <- getPlatform+ let sdoc = pprCLabel_LLVM platform lbl str = Outp.renderWithStyle (initSDocContext dflags (Outp.mkCodeStyle Outp.CStyle)) sdoc
compiler/GHC/CmmToLlvm/CodeGen.hs view
@@ -343,7 +343,7 @@ retV <- doExprW width2x $ LlvmOp LM_MO_Mul lhsExt rhsExt -- Extract the lower bits of the result into retL. retL <- doExprW width $ Cast LM_Trunc retV width- -- Now we right-shift the higher bits by width.+ -- Now we unsigned right-shift the higher bits by width. let widthLlvmLit = LMLitVar $ LMIntLit (fromIntegral bitWidth) width retShifted <- doExprW width2x $ LlvmOp LM_MO_LShr retV widthLlvmLit -- And extract them into retH.@@ -352,6 +352,39 @@ dstRegH <- getCmmRegW (CmmLocal dstH) statement $ Store retL dstRegL statement $ Store retH dstRegH++genCall (PrimTarget (MO_S_Mul2 w)) [dstC, dstH, dstL] [lhs, rhs] = runStmtsDecls $ do+ let width = widthToLlvmInt w+ bitWidth = widthInBits w+ width2x = LMInt (bitWidth * 2)+ -- First sign-extend the operands ('mul' instruction requires the operands+ -- and the result to be of the same type). Note that we don't use 'castVars'+ -- because it tries to do LM_Sext.+ lhsVar <- exprToVarW lhs+ rhsVar <- exprToVarW rhs+ lhsExt <- doExprW width2x $ Cast LM_Sext lhsVar width2x+ rhsExt <- doExprW width2x $ Cast LM_Sext rhsVar width2x+ -- Do the actual multiplication (note that the result is also 2x width).+ retV <- doExprW width2x $ LlvmOp LM_MO_Mul lhsExt rhsExt+ -- Extract the lower bits of the result into retL.+ retL <- doExprW width $ Cast LM_Trunc retV width+ -- Now we signed right-shift the higher bits by width.+ let widthLlvmLit = LMLitVar $ LMIntLit (fromIntegral bitWidth) width+ retShifted <- doExprW width2x $ LlvmOp LM_MO_AShr retV widthLlvmLit+ -- And extract them into retH.+ retH <- doExprW width $ Cast LM_Trunc retShifted width+ -- Check if the carry is useful by doing a full arithmetic right shift on+ -- retL and comparing the result with retH+ let widthLlvmLitm1 = LMLitVar $ LMIntLit (fromIntegral bitWidth - 1) width+ retH' <- doExprW width $ LlvmOp LM_MO_AShr retL widthLlvmLitm1+ retC1 <- doExprW i1 $ Compare LM_CMP_Ne retH retH' -- Compare op returns a 1-bit value (i1)+ retC <- doExprW width $ Cast LM_Zext retC1 width -- so we zero-extend it+ dstRegL <- getCmmRegW (CmmLocal dstL)+ dstRegH <- getCmmRegW (CmmLocal dstH)+ dstRegC <- getCmmRegW (CmmLocal dstC)+ statement $ Store retL dstRegL+ statement $ Store retH dstRegH+ statement $ Store retC dstRegC -- MO_U_QuotRem2 is another case we handle by widening the registers to double -- the width and use normal LLVM instructions (similarly to the MO_U_Mul2). The
compiler/GHC/Core/Opt/DmdAnal.hs view
@@ -486,8 +486,9 @@ | isDataConWorkId var = dmdTransformDataConSig (idArity var) dmd -- Dictionary component selectors- | gopt Opt_DmdTxDictSel (ae_dflags env),- Just _ <- isClassOpId_maybe var+ -- Used to be controlled by a flag.+ -- See #18429 for some perf measurements.+ | Just _ <- isClassOpId_maybe var = dmdTransformDictSelSig (idStrictness var) dmd -- Imported functions | isGlobalId var@@ -1179,8 +1180,26 @@ 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+ = AE { ae_dflags :: DynFlags -- See Note [dmdAnalEnv performance] , ae_sigs :: SigEnv , ae_virgin :: Bool -- True on first iteration only -- See Note [Initialising strictness]
compiler/GHC/Core/Opt/SetLevels.hs view
@@ -658,8 +658,8 @@ lvlMFE env strict_ctxt ann_expr | floatTopLvlOnly env && not (isTopLvl dest_lvl) -- Only floating to the top level is allowed.- || anyDVarSet isJoinId fvs -- If there is a free join, don't float- -- See Note [Free join points]+ || hasFreeJoin env fvs -- If there is a free join, don't float+ -- See Note [Free join points] || isExprLevPoly expr -- We can't let-bind levity polymorphic expressions -- See Note [Levity polymorphism invariants] in GHC.Core@@ -754,6 +754,14 @@ saves_alloc = isTopLvl dest_lvl && floatConsts env && (not strict_ctxt || is_bot || exprIsHNF expr)++hasFreeJoin :: LevelEnv -> DVarSet -> Bool+-- Has a free join point which is not being floated to top level.+-- (In the latter case it won't be a join point any more.)+-- Not treating top-level ones specially had a massive effect+-- on nofib/minimax/Prog.prog+hasFreeJoin env fvs+ = not (maxFvLevel isJoinId env fvs == tOP_LEVEL) isBottomThunk :: Maybe (Arity, s) -> Bool -- See Note [Bottoming floats] (2)
compiler/GHC/Core/Opt/Simplify.hs view
@@ -6,7 +6,7 @@ {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-incomplete-uni-patterns #-} module GHC.Core.Opt.Simplify ( simplTopBinds, simplExpr, simplRules ) where #include "GhclibHsVersions.h"@@ -39,14 +39,15 @@ import GHC.Core import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) import GHC.Builtin.Names( runRWKey )-import GHC.Types.Demand ( StrictSig(..), dmdTypeDepth, isStrictDmd- , mkClosedStrictSig, topDmd, botDiv )+import GHC.Types.Demand ( StrictSig(..), Demand, dmdTypeDepth, isStrictDmd+ , mkClosedStrictSig, topDmd, seqDmd, botDiv ) import GHC.Types.Cpr ( mkCprSig, botCpr ) import GHC.Core.Ppr ( pprCoreExpr ) import GHC.Types.Unique ( hasKey ) import GHC.Core.Unfold import GHC.Core.Utils-import GHC.Core.Opt.Arity ( etaExpand )+import GHC.Core.Opt.Arity ( ArityType(..), arityTypeArity, isBotArityType+ , idArityType, etaExpandAT ) import GHC.Core.SimpleOpt ( pushCoTyArg, pushCoValArg , joinPointBinding_maybe, joinPointBindings_maybe ) import GHC.Core.FVs ( mkRuleInfo )@@ -54,7 +55,7 @@ import GHC.Types.Basic import GHC.Utils.Monad ( mapAccumLM, liftIO ) import GHC.Types.Var ( isTyCoVar )-import GHC.Data.Maybe ( orElse, fromMaybe )+import GHC.Data.Maybe ( orElse ) import Control.Monad import GHC.Utils.Outputable import GHC.Data.FastString@@ -62,7 +63,6 @@ import GHC.Utils.Error import GHC.Unit.Module ( moduleName, pprModuleName ) import GHC.Core.Multiplicity-import GHC.Core.TyCo.Rep ( TyCoBinder(..) ) import GHC.Builtin.PrimOps ( PrimOp (SeqOp) ) @@ -360,44 +360,8 @@ simplJoinBind env cont old_bndr new_bndr rhs rhs_se = do { let rhs_env = rhs_se `setInScopeFromE` env ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont- ; let mult = contHoleScaling cont- arity = fromMaybe (pprPanic "simplJoinBind" (ppr new_bndr)) $- isJoinIdDetails_maybe (idDetails new_bndr)- new_type = scaleJoinPointType mult arity (varType new_bndr)- new_bndr' = setIdType new_bndr new_type- ; completeBind env NotTopLevel (Just cont) old_bndr new_bndr' rhs' }--{--Note [Scaling join point arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider a join point which is linear in its variable, in some context E:--E[join j :: a #-> a- j x = x- in case v of- A -> j 'x'- B -> <blah>]--The simplifier changes to:--join j :: a #-> a- j x = E[x]-in case v of- A -> j 'x'- B -> E[<blah>]--If E uses its argument in a nonlinear way (e.g. a case['Many]), then-this is wrong: the join point has to change its type to a -> a.-Otherwise, we'd get a linearity error.+ ; completeBind env NotTopLevel (Just cont) old_bndr new_bndr rhs' } -See also Note [Return type for join points] and Note [Join points and case-of-case].--}-scaleJoinPointType :: Mult -> Int -> Type -> Type-scaleJoinPointType mult arity ty | arity == 0 = ty- | otherwise = case splitPiTy ty of- (binder, ty') -> mkPiTy (scaleBinder binder) (scaleJoinPointType mult (arity-1) ty')- where scaleBinder (Anon af t) = Anon af (scaleScaled mult t)- scaleBinder b@(Named _) = b -------------------------- simplNonRecX :: SimplEnv -> InId -- Old binder; not a JoinId@@ -634,7 +598,7 @@ = do { (is_exp, floats1, fun') <- go (n_val_args+1) fun ; case is_exp of False -> return (False, emptyLetFloats, App fun arg)- True -> do { (floats2, arg') <- makeTrivial mode top_lvl occ arg+ True -> do { (floats2, arg') <- makeTrivial mode top_lvl topDmd occ arg ; return (True, floats1 `addLetFlts` floats2, App fun' arg') } } go n_val_args (Var fun) = return (is_exp, emptyLetFloats, Var fun)@@ -664,32 +628,34 @@ = return (False, emptyLetFloats, other) makeTrivialArg :: SimplMode -> ArgSpec -> SimplM (LetFloats, ArgSpec)-makeTrivialArg mode arg@(ValArg { as_arg = e })- = do { (floats, e') <- makeTrivial mode NotTopLevel (fsLit "arg") e+makeTrivialArg mode arg@(ValArg { as_arg = e, as_dmd = dmd })+ = do { (floats, e') <- makeTrivial mode NotTopLevel dmd (fsLit "arg") e ; return (floats, arg { as_arg = e' }) } makeTrivialArg _ arg = return (emptyLetFloats, arg) -- CastBy, TyArg -makeTrivial :: SimplMode -> TopLevelFlag+makeTrivial :: SimplMode -> TopLevelFlag -> Demand -> FastString -- ^ A "friendly name" to build the new binder from -> OutExpr -- ^ This expression satisfies the let/app invariant -> SimplM (LetFloats, OutExpr) -- Binds the expression to a variable, if it's not trivial, returning the variable-makeTrivial mode top_lvl occ_fs expr+-- For the Demand argument, see Note [Keeping demand info in StrictArg Plan A]+makeTrivial mode top_lvl dmd occ_fs expr | exprIsTrivial expr -- Already trivial || not (bindingOk top_lvl expr expr_ty) -- Cannot trivialise -- See Note [Cannot trivialise] = return (emptyLetFloats, expr) | Cast expr' co <- expr- = do { (floats, triv_expr) <- makeTrivial mode top_lvl occ_fs expr'+ = do { (floats, triv_expr) <- makeTrivial mode top_lvl dmd occ_fs expr' ; return (floats, Cast triv_expr co) } | otherwise = do { (floats, new_id) <- makeTrivialBinding mode top_lvl occ_fs- vanillaIdInfo expr expr_ty+ id_info expr expr_ty ; return (floats, Var new_id) } where+ id_info = vanillaIdInfo `setDemandInfo` dmd expr_ty = exprType expr makeTrivialBinding :: SimplMode -> TopLevelFlag@@ -706,10 +672,10 @@ -- Now something very like completeBind, -- but without the postInlineUnconditionally part- ; (arity, is_bot, expr2) <- tryEtaExpandRhs mode var expr1+ ; (arity_type, expr2) <- tryEtaExpandRhs mode var expr1 ; unf <- mkLetUnfolding (sm_dflags mode) top_lvl InlineRhs var expr2 - ; let final_id = addLetBndrInfo var arity is_bot unf+ ; let final_id = addLetBndrInfo var arity_type unf bind = NonRec final_id expr2 ; return ( floats `addLetFlts` unitLetFloat bind, final_id ) }@@ -799,14 +765,13 @@ -- Do eta-expansion on the RHS of the binding -- See Note [Eta-expanding at let bindings] in GHC.Core.Opt.Simplify.Utils- ; (new_arity, is_bot, final_rhs) <- tryEtaExpandRhs (getMode env)- new_bndr new_rhs+ ; (new_arity, final_rhs) <- tryEtaExpandRhs (getMode env) new_bndr new_rhs -- Simplify the unfolding ; new_unfolding <- simplLetUnfolding env top_lvl mb_cont old_bndr final_rhs (idType new_bndr) new_arity old_unf - ; let final_bndr = addLetBndrInfo new_bndr new_arity is_bot new_unfolding+ ; let final_bndr = addLetBndrInfo new_bndr new_arity new_unfolding -- See Note [In-scope set as a substitution] ; if postInlineUnconditionally env top_lvl final_bndr occ_info final_rhs@@ -823,10 +788,13 @@ -- pprTrace "Binding" (ppr final_bndr <+> ppr new_unfolding) $ return (mkFloatBind env (NonRec final_bndr final_rhs)) } -addLetBndrInfo :: OutId -> Arity -> Bool -> Unfolding -> OutId-addLetBndrInfo new_bndr new_arity is_bot new_unf+addLetBndrInfo :: OutId -> ArityType -> Unfolding -> OutId+addLetBndrInfo new_bndr new_arity_type new_unf = new_bndr `setIdInfo` info5 where+ new_arity = arityTypeArity new_arity_type+ is_bot = isBotArityType new_arity_type+ info1 = idInfo new_bndr `setArityInfo` new_arity -- Unfolding info: Note [Setting the new unfolding]@@ -844,12 +812,13 @@ = info2 -- Bottoming bindings: see Note [Bottoming bindings]- info4 | is_bot = info3- `setStrictnessInfo`- mkClosedStrictSig (replicate new_arity topDmd) botDiv- `setCprInfo` mkCprSig new_arity botCpr+ info4 | is_bot = info3 `setStrictnessInfo` bot_sig+ `setCprInfo` bot_cpr | otherwise = info3 + bot_sig = mkClosedStrictSig (replicate new_arity topDmd) botDiv+ bot_cpr = mkCprSig new_arity botCpr+ -- Zap call arity info. We have used it by now (via -- `tryEtaExpandRhs`), and the simplifier can invalidate this -- information, leading to broken code later (e.g. #13479)@@ -860,9 +829,9 @@ ~~~~~~~~~~~~~~~~~~~~~~~~ Generally speaking the arity of a binding should not decrease. But it *can* legitimately happen because of RULES. Eg- f = g Int+ f = g @Int where g has arity 2, will have arity 2. But if there's a rewrite rule- g Int --> h+ g @Int --> h where h has arity 1, then f's arity will decrease. Here's a real-life example, which is in the output of Specialise: @@ -892,7 +861,7 @@ propagate the info that x's RHS is bottom to x's IdInfo as rapidly as possible. -We use tryEtaExpandRhs on every binding, and it turns ou that the+We use tryEtaExpandRhs on every binding, and it turns out that the arity computation it performs (via GHC.Core.Opt.Arity.findRhsArity) already does a simple bottoming-expression analysis. So all we need to do is propagate that info to the binder's IdInfo.@@ -1035,7 +1004,7 @@ , sc_hole_ty = hole' , sc_cont = cont } } _ ->- -- crucially, these are /lazy/ bindings. They will+ -- Crucially, sc_hole_ty is a /lazy/ binding. It will -- be forced only if we need to run contHoleType. -- When these are forced, we might get quadratic behavior; -- this quadratic blowup could be avoided by drilling down@@ -1043,13 +1012,10 @@ -- (instead of one-at-a-time). But in practice, we have not -- observed the quadratic behavior, so this extra entanglement -- seems not worthwhile.- let fun_ty = exprType fun- (m, _, _) = splitFunTy fun_ty- in- simplExprF env fun $- ApplyToVal { sc_arg = arg, sc_env = env- , sc_hole_ty = substTy env (exprType fun)- , sc_dup = NoDup, sc_cont = cont, sc_mult = m }+ simplExprF env fun $+ ApplyToVal { sc_arg = arg, sc_env = env+ , sc_hole_ty = substTy env (exprType fun)+ , sc_dup = NoDup, sc_cont = cont } simplExprF1 env expr@(Lam {}) cont = {-#SCC "simplExprF1-Lam" #-}@@ -1354,8 +1320,8 @@ Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont } -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont - StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty, sc_mult = m }- -> rebuildCall env (addValArgTo fun (m, expr) fun_ty ) cont+ StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty }+ -> rebuildCall env (addValArgTo fun expr fun_ty ) cont StrictBind { sc_bndr = b, sc_bndrs = bs, sc_body = body , sc_env = se, sc_cont = cont } -> do { (floats1, env') <- simplNonRecX (se `setInScopeFromE` env) b expr@@ -1447,7 +1413,7 @@ -- co1 :: t1 ~ s1 -- co2 :: s2 ~ t2 addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se- , sc_dup = dup, sc_cont = tail, sc_mult = m })+ , sc_dup = dup, sc_cont = tail }) | Just (co1, m_co2) <- pushCoValArg co , let new_ty = coercionRKind co1 , not (isTypeLevPoly new_ty) -- Without this check, we get a lev-poly arg@@ -1471,8 +1437,7 @@ , sc_env = arg_se' , sc_dup = dup' , sc_cont = tail'- , sc_hole_ty = coercionLKind co- , sc_mult = m }) } }+ , sc_hole_ty = coercionLKind co }) } } addCoerce co cont | isReflexiveCo co = return cont -- Having this at the end makes a huge@@ -1551,7 +1516,7 @@ | isId bndr && hasCoreUnfolding old_unf -- Special case = do { (env1, bndr1) <- simplBinder env bndr ; unf' <- simplStableUnfolding env1 NotTopLevel Nothing bndr- (idType bndr1) (idArity bndr1) old_unf+ (idType bndr1) (idArityType bndr1) old_unf ; let bndr2 = bndr1 `setIdUnfolding` unf' ; return (modifyInScope env1 bndr2, bndr2) } @@ -1600,7 +1565,7 @@ simplLam env' bndrs body cont } -- Deal with strict bindings- | isStrictId bndr -- Includes coercions+ | isStrictId bndr -- Includes coercions, and unlifted types , sm_case_case (getMode env) = simplExprF (rhs_se `setInScopeFromE` env) rhs (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs, sc_body = body@@ -1722,8 +1687,9 @@ = wrapJoinCont env cont $ \ env cont -> do { -- We push join_cont into the join RHS and the body; -- and wrap wrap_cont around the whole thing- ; let res_ty = contResultType cont- ; (env1, bndr1) <- simplNonRecJoinBndr env res_ty bndr+ ; let mult = contHoleScaling cont+ res_ty = contResultType cont+ ; (env1, bndr1) <- simplNonRecJoinBndr env bndr mult res_ty ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (Just cont) ; (floats1, env3) <- simplJoinBind env2 cont bndr bndr2 rhs env ; (floats2, body') <- simplExprF env3 body cont@@ -1736,9 +1702,10 @@ -> SimplM (SimplFloats, OutExpr) simplRecJoinPoint env pairs body cont = wrapJoinCont env cont $ \ env cont ->- do { let bndrs = map fst pairs+ do { let bndrs = map fst pairs+ mult = contHoleScaling cont res_ty = contResultType cont- ; env1 <- simplRecJoinBndrs env res_ty bndrs+ ; env1 <- simplRecJoinBndrs env bndrs mult res_ty -- NB: bndrs' don't have unfoldings or rules -- We add them as we go down ; (floats1, env2) <- simplRecBind env1 NotTopLevel (Just cont) pairs@@ -1929,7 +1896,7 @@ log_inlining doc = liftIO $ dumpAction dflags- (mkUserStyle alwaysQualify AllTheWay)+ (mkDumpStyle alwaysQualify) (dumpOptionsFromFlag Opt_D_dump_inlinings) "" FormatText doc @@ -1955,7 +1922,7 @@ -- - and rebuild ---------- Bottoming applications ---------------rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) cont+rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_dmds = [] }) cont -- When we run out of strictness args, it means -- that the call is definitely bottom; see GHC.Core.Opt.Simplify.Utils.mkArgInfo -- Then we want to discard the entire strict continuation. E.g.@@ -2005,42 +1972,42 @@ ---------- The runRW# rule. Do this after absorbing all arguments ------ -- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o -- K[ runRW# rr ty body ] --> runRW rr' ty' (\s. K[ body s ])-rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args })- (ApplyToVal { sc_arg = arg, sc_env = arg_se, sc_cont = cont, sc_mult = m })- | fun `hasKey` runRWKey+rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args })+ (ApplyToVal { sc_arg = arg, sc_env = arg_se+ , sc_cont = cont, sc_hole_ty = fun_ty })+ | fun_id `hasKey` runRWKey , not (contIsStop cont) -- Don't fiddle around if the continuation is boring , [ TyArg {}, TyArg {} ] <- rev_args = do { s <- newId (fsLit "s") Many realWorldStatePrimTy- ; let env' = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s]+ ; let (m,_,_) = splitFunTy fun_ty+ env' = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s] ty' = contResultType cont cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s , sc_env = env', sc_cont = cont- , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty'- , sc_mult = m }+ , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' } -- cont' applies to s, then K ; body' <- simplExprC env' arg cont' ; let arg' = Lam s body' rr' = getRuntimeRep ty'- call' = mkApps (Var fun) [mkTyArg rr', mkTyArg ty', arg']+ call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg ty', arg'] ; return (emptyFloats env, call') } -rebuildCall env info@(ArgInfo { ai_encl = encl_rules- , ai_strs = str:strs, ai_discs = disc:discs })+rebuildCall env fun_info (ApplyToVal { sc_arg = arg, sc_env = arg_se , sc_dup = dup_flag, sc_hole_ty = fun_ty- , sc_cont = cont, sc_mult = m })+ , sc_cont = cont }) -- Argument is already simplified | isSimplified dup_flag -- See Note [Avoid redundant simplification]- = rebuildCall env (addValArgTo info' (m, arg) fun_ty) cont+ = rebuildCall env (addValArgTo fun_info arg fun_ty) cont -- Strict arguments- | str+ | isStrictArgInfo fun_info , sm_case_case (getMode env) = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ simplExprF (arg_se `setInScopeFromE` env) arg- (StrictArg { sc_fun = info', sc_cci = cci_strict- , sc_dup = Simplified, sc_fun_ty = fun_ty- , sc_cont = cont, sc_mult = m })+ (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty+ , sc_dup = Simplified+ , sc_cont = cont }) -- Note [Shadowing] -- Lazy arguments@@ -2050,28 +2017,12 @@ -- have to be very careful about bogus strictness through -- floating a demanded let. = do { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg- (mkLazyArgStop arg_ty cci_lazy)- ; rebuildCall env (addValArgTo info' (m, arg') fun_ty) cont }+ (mkLazyArgStop arg_ty (lazyArgContext fun_info))+ ; rebuildCall env (addValArgTo fun_info arg' fun_ty) cont } where- info' = info { ai_strs = strs, ai_discs = discs } arg_ty = funArgTy fun_ty - -- Use this for lazy arguments- cci_lazy | encl_rules = RuleArgCtxt- | disc > 0 = DiscArgCtxt -- Be keener here- | otherwise = BoringCtxt -- Nothing interesting - -- ..and this for strict arguments- cci_strict | encl_rules = RuleArgCtxt- | disc > 0 = DiscArgCtxt- | otherwise = RhsCtxt- -- Why RhsCtxt? if we see f (g x) (h x), and f is strict, we- -- want to be a bit more eager to inline g, because it may- -- expose an eval (on x perhaps) that can be eliminated or- -- shared. I saw this in nofib 'boyer2', RewriteFuns.onewayunify1- -- It's worth an 18% improvement in allocation for this- -- particular benchmark; 5% on 'mate' and 1.3% on 'multiplier'- ---------- No further useful info, revert to generic rebuild ------------ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont = rebuild env (argInfoExpr fun rev_args) cont@@ -2274,24 +2225,11 @@ , TyArg { as_arg_ty = rhs_ty , as_hole_ty = res2_ty } , ValArg { as_arg = no_cast_scrut- , as_hole_ty = res3_ty- , as_mult = Many } ]- -- The multiplicity of the scrutiny above is Many because the type- -- of seq requires that its first argument is unrestricted. The- -- typing rule of case also guarantees it though. In a more- -- general world, where the first argument of seq would have- -- affine multiplicity, then we could use the multiplicity of- -- the case (held in the case binder) instead.+ , as_dmd = seqDmd+ , as_hole_ty = res3_ty } ] rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs , sc_env = in_env, sc_cont = cont- , sc_hole_ty = res4_ty, sc_mult = Many }- -- The multiplicity in sc_mult above is the- -- multiplicity of the second argument of seq. Since- -- seq's type, as it stands, imposes that its second- -- argument be unrestricted, so is- -- sc_mult. However, a more precise typing rule,- -- for seq, would be to have it be linear. In which- -- case, sc_mult should be 1.+ , sc_hole_ty = res4_ty } -- Lazily evaluated, so we don't do most of this @@ -3299,31 +3237,41 @@ is_bot_alt (_,_,rhs) = exprIsDeadEnd rhs --------------------------mkDupableCont :: SimplEnv -> SimplCont+mkDupableCont :: SimplEnv+ -> SimplCont -> SimplM ( SimplFloats -- Incoming SimplEnv augmented with -- extra let/join-floats and in-scope variables , SimplCont) -- dup_cont: duplicable continuation- mkDupableCont env cont+ = mkDupableContWithDmds env (repeat topDmd) cont++mkDupableContWithDmds+ :: SimplEnv -> [Demand] -- Demands on arguments; always infinite+ -> SimplCont -> SimplM ( SimplFloats, SimplCont)++mkDupableContWithDmds env _ cont | contIsDupable cont = return (emptyFloats env, cont) -mkDupableCont _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn+mkDupableContWithDmds _ _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn -mkDupableCont env (CastIt ty cont)- = do { (floats, cont') <- mkDupableCont env cont+mkDupableContWithDmds env dmds (CastIt ty cont)+ = do { (floats, cont') <- mkDupableContWithDmds env dmds cont ; return (floats, CastIt ty cont') } -- Duplicating ticks for now, not sure if this is good or not-mkDupableCont env (TickIt t cont)- = do { (floats, cont') <- mkDupableCont env cont+mkDupableContWithDmds env dmds (TickIt t cont)+ = do { (floats, cont') <- mkDupableContWithDmds env dmds cont ; return (floats, TickIt t cont') } -mkDupableCont env (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs- , sc_body = body, sc_env = se, sc_cont = cont})- -- See Note [Duplicating StrictBind]+mkDupableContWithDmds env _+ (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs+ , sc_body = body, sc_env = se, sc_cont = cont})+-- See Note [Duplicating StrictBind]+-- K[ let x = <> in b ] --> join j x = K[ b ]+-- j <> = do { let sb_env = se `setInScopeFromE` env- ; (sb_env1, bndr') <- simplBinder sb_env bndr+ ; (sb_env1, bndr') <- simplBinder sb_env bndr ; (floats1, join_inner) <- simplLam sb_env1 bndrs body cont -- No need to use mkDupableCont before simplLam; we -- use cont once here, and then share the result if necessary@@ -3331,56 +3279,65 @@ ; let join_body = wrapFloats floats1 join_inner res_ty = contResultType cont - ; (floats2, body2)- <- if exprIsDupable (targetPlatform (seDynFlags env)) join_body- then return (emptyFloats env, join_body)- else do { join_bndr <- newJoinId [bndr'] res_ty- ; let join_call = App (Var join_bndr) (Var bndr')- join_rhs = Lam (setOneShotLambda bndr') join_body- join_bind = NonRec join_bndr join_rhs- floats = emptyFloats env `extendFloats` join_bind- ; return (floats, join_call) }- ; return ( floats2- , StrictBind { sc_bndr = bndr', sc_bndrs = []- , sc_body = body2- , sc_env = zapSubstEnv se `setInScopeFromF` floats2- -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils- , sc_dup = OkToDup- , sc_cont = mkBoringStop res_ty } ) }+ ; mkDupableStrictBind env bndr' join_body res_ty } -mkDupableCont env (StrictArg { sc_fun = info, sc_cci = cci- , sc_cont = cont, sc_fun_ty = fun_ty, sc_mult = m })- -- See Note [Duplicating StrictArg]- -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable- = do { (floats1, cont') <- mkDupableCont env cont+mkDupableContWithDmds env _+ (StrictArg { sc_fun = fun, sc_cont = cont+ , sc_fun_ty = fun_ty })+ -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable+ | thumbsUpPlanA cont+ = -- Use Plan A of Note [Duplicating StrictArg]+ do { let (_ : dmds) = ai_dmds fun+ ; (floats1, cont') <- mkDupableContWithDmds env dmds cont+ -- Use the demands from the function to add the right+ -- demand info on any bindings we make for further args ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg (getMode env))- (ai_args info)+ (ai_args fun) ; return ( foldl' addLetFloats floats1 floats_s- , StrictArg { sc_fun = info { ai_args = args' }+ , StrictArg { sc_fun = fun { ai_args = args' } , sc_cont = cont'- , sc_cci = cci , sc_fun_ty = fun_ty- , sc_mult = m , sc_dup = OkToDup} ) } -mkDupableCont env (ApplyToTy { sc_cont = cont- , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty })- = do { (floats, cont') <- mkDupableCont env cont+ | otherwise+ = -- Use Plan B of Note [Duplicating StrictArg]+ -- K[ f a b <> ] --> join j x = K[ f a b x ]+ -- j <>+ do { let rhs_ty = contResultType cont+ (m,arg_ty,_) = splitFunTy fun_ty+ ; arg_bndr <- newId (fsLit "arg") m arg_ty+ ; let env' = env `addNewInScopeIds` [arg_bndr]+ ; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (Var arg_bndr) fun_ty) cont+ ; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty }+ where+ thumbsUpPlanA (StrictArg {}) = False+ thumbsUpPlanA (CastIt _ k) = thumbsUpPlanA k+ thumbsUpPlanA (TickIt _ k) = thumbsUpPlanA k+ thumbsUpPlanA (ApplyToVal { sc_cont = k }) = thumbsUpPlanA k+ thumbsUpPlanA (ApplyToTy { sc_cont = k }) = thumbsUpPlanA k+ thumbsUpPlanA (Select {}) = True+ thumbsUpPlanA (StrictBind {}) = True+ thumbsUpPlanA (Stop {}) = True++mkDupableContWithDmds env dmds+ (ApplyToTy { sc_cont = cont, sc_arg_ty = arg_ty, sc_hole_ty = hole_ty })+ = do { (floats, cont') <- mkDupableContWithDmds env dmds cont ; return (floats, ApplyToTy { sc_cont = cont' , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) } -mkDupableCont env (ApplyToVal { sc_arg = arg, sc_dup = dup- , sc_env = se, sc_cont = cont- , sc_hole_ty = hole_ty, sc_mult = mult })+mkDupableContWithDmds env dmds+ (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se+ , sc_cont = cont, sc_hole_ty = hole_ty }) = -- e.g. [...hole...] (...arg...) -- ==> -- let a = ...arg... -- in [...hole...] a -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable- do { (floats1, cont') <- mkDupableCont env cont+ do { let (dmd:_) = dmds -- Never fails+ ; (floats1, cont') <- mkDupableContWithDmds env dmds cont ; let env' = env `setInScopeFromF` floats1 ; (_, se', arg') <- simplArg env' dup se arg- ; (let_floats2, arg'') <- makeTrivial (getMode env) NotTopLevel (fsLit "karg") arg'+ ; (let_floats2, arg'') <- makeTrivial (getMode env) NotTopLevel dmd (fsLit "karg") arg' ; let all_floats = floats1 `addLetFloats` let_floats2 ; return ( all_floats , ApplyToVal { sc_arg = arg''@@ -3390,10 +3347,10 @@ -- has turned arg'' into a fresh variable -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils , sc_dup = OkToDup, sc_cont = cont'- , sc_hole_ty = hole_ty, sc_mult = mult }) }+ , sc_hole_ty = hole_ty }) } -mkDupableCont env (Select { sc_bndr = case_bndr, sc_alts = alts- , sc_env = se, sc_cont = cont })+mkDupableContWithDmds env _+ (Select { sc_bndr = case_bndr, sc_alts = alts, sc_env = se, sc_cont = cont }) = -- e.g. (case [...hole...] of { pi -> ei }) -- ===> -- let ji = \xij -> ei@@ -3435,6 +3392,33 @@ -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils , sc_cont = mkBoringStop (contResultType cont) } ) } +mkDupableStrictBind :: SimplEnv -> OutId -> OutExpr -> OutType+ -> SimplM (SimplFloats, SimplCont)+mkDupableStrictBind env arg_bndr join_rhs res_ty+ | exprIsDupable (targetPlatform (seDynFlags env)) join_rhs+ = return (emptyFloats env+ , StrictBind { sc_bndr = arg_bndr, sc_bndrs = []+ , sc_body = join_rhs+ , sc_env = zapSubstEnv env+ -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils+ , sc_dup = OkToDup+ , sc_cont = mkBoringStop res_ty } )+ | otherwise+ = do { join_bndr <- newJoinId [arg_bndr] res_ty+ ; let arg_info = ArgInfo { ai_fun = join_bndr+ , ai_rules = Nothing, ai_args = []+ , ai_encl = False, ai_dmds = repeat topDmd+ , ai_discs = repeat 0 }+ ; return ( addJoinFloats (emptyFloats env) $+ unitJoinFloat $+ NonRec join_bndr $+ Lam (setOneShotLambda arg_bndr) join_rhs+ , StrictArg { sc_dup = OkToDup+ , sc_fun = arg_info+ , sc_fun_ty = idType join_bndr+ , sc_cont = mkBoringStop res_ty+ } ) }+ mkDupableAlt :: Platform -> OutId -> JoinFloats -> OutAlt -> SimplM (JoinFloats, OutAlt)@@ -3608,58 +3592,103 @@ Note [Duplicating StrictArg] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We make a StrictArg duplicable simply by making all its-stored-up arguments (in sc_fun) trivial, by let-binding-them. Thus:- f E [..hole..]- ==> let a = E- in f a [..hole..]-Now if the thing in the hole is a case expression (which is when-we'll call mkDupableCont), we'll push the function call into the-branches, which is what we want. Now RULES for f may fire, and-call-pattern specialisation. Here's an example from #3116+Dealing with making a StrictArg continuation duplicable has turned out+to be one of the trickiest corners of the simplifier, giving rise+to several cases in which the simplier expanded the program's size+*exponentially*. They include+ #13253 exponential inlining+ #10421 ditto+ #18140 strict constructors+ #18282 another nested-function call case++Suppose we have a call+ f e1 (case x of { True -> r1; False -> r2 }) e3+and f is strict in its second argument. Then we end up in+mkDupableCont with a StrictArg continuation for (f e1 <> e3).+There are two ways to make it duplicable.++* Plan A: move the entire call inwards, being careful not+ to duplicate e1 or e3, thus:+ let a1 = e1+ a3 = e3+ in case x of { True -> f a1 r1 a3+ ; False -> f a1 r2 a3 }++* Plan B: make a join point:+ join $j x = f e1 x e3+ in case x of { True -> jump $j r1+ ; False -> jump $j r2 }+ Notice that Plan B is very like the way we handle strict+ bindings; see Note [Duplicating StrictBind].++Plan A is good. Here's an example from #3116 go (n+1) (case l of 1 -> bs' _ -> Chunk p fpc (o+1) (l-1) bs')-If we can push the call for 'go' inside the case, we get++If we pushed the entire call for 'go' inside the case, we get call-pattern specialisation for 'go', which is *crucial* for-this program.+this particular program. -Here is the (&&) example:+Here is another example. && E (case x of { T -> F; F -> T })- ==> let a = E in- case x of { T -> && a F; F -> && a T }-Much better! -Notice that- * Arguments to f *after* the strict one are handled by- the ApplyToVal case of mkDupableCont. Eg- f [..hole..] E+Pushing the call inward (being careful not to duplicate E)+ let a = E+ in case x of { T -> && a F; F -> && a T } - * We can only do the let-binding of E because the function- part of a StrictArg continuation is an explicit syntax- tree. In earlier versions we represented it as a function- (CoreExpr -> CoreEpxr) which we couldn't take apart.+and now the (&& a F) etc can optimise. Moreover there might+be a RULE for the function that can fire when it "sees" the+particular case alterantive. -Historical aide: previously we did this (where E is a-big argument:- f E [..hole..]- ==> let $j = \a -> f E a- in $j [..hole..]+But Plan A can have terrible, terrible behaviour. Here is a classic+case:+ f (f (f (f (f True)))) -But this is terrible! Here's an example:- && E (case x of { T -> F; F -> T })-Now, && is strict so we end up simplifying the case with-an ArgOf continuation. If we let-bind it, we get- let $j = \v -> && E v- in simplExpr (case x of { T -> F; F -> T })- (ArgOf (\r -> $j r)-And after simplifying more we get- let $j = \v -> && E v- in case x of { T -> $j F; F -> $j T }-Which is a Very Bad Thing+Suppose f is strict, and has a body that is small enough to inline.+The innermost call inlines (seeing the True) to give+ f (f (f (f (case v of { True -> e1; False -> e2 })))) +Now, suppose we naively push the entire continuation into both+case branches (it doesn't look large, just f.f.f.f). We get+ case v of+ True -> f (f (f (f e1)))+ False -> f (f (f (f e2))) +And now the process repeats, so we end up with an exponentially large+number of copies of f. No good!++CONCLUSION: we want Plan A in general, but do Plan B is there a+danger of this nested call behaviour. The function that decides+this is called thumbsUpPlanA.++Note [Keeping demand info in StrictArg Plan A]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Following on from Note [Duplicating StrictArg], another common code+pattern that can go bad is this:+ f (case x1 of { T -> F; F -> T })+ (case x2 of { T -> F; F -> T })+ ...etc...+when f is strict in all its arguments. (It might, for example, be a+strict data constructor whose wrapper has not yet been inlined.)++We use Plan A (because there is no nesting) giving+ let a2 = case x2 of ...+ a3 = case x3 of ...+ in case x1 of { T -> f F a2 a3 ... ; F -> f T a2 a3 ... }++Now we must be careful! a2 and a3 are small, and the OneOcc code in+postInlineUnconditionally may inline them both at both sites; see Note+Note [Inline small things to avoid creating a thunk] in+Simplify.Utils. But if we do inline them, the entire process will+repeat -- back to exponential behaviour.++So we are careful to keep the demand-info on a2 and a3. Then they'll+be /strict/ let-bindings, which will be dealt with by StrictBind.+That's why contIsDupableWithDmds is careful to propagage demand+info to the auxiliary bindings it creates. See the Demand argument+to makeTrivial.+ Note [Duplicating StrictBind] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We make a StrictBind duplicable in a very similar way to@@ -3667,9 +3696,10 @@ let x* = e in b is similar to case e of x -> b So we potentially make a join-point for the body, thus:- let x = [] in b ==> join j x = b- in let x = [] in j x+ let x = <> in b ==> join j x = b+ in j <> +Just like StrictArg in fact -- and indeed they share code. Note [Join point abstraction] Historical note ~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -3736,7 +3766,7 @@ simplLetUnfolding :: SimplEnv-> TopLevelFlag -> MaybeJoinCont -> InId- -> OutExpr -> OutType -> Arity+ -> OutExpr -> OutType -> ArityType -> Unfolding -> SimplM Unfolding simplLetUnfolding env top_lvl cont_mb id new_rhs rhs_ty arity unf | isStableUnfolding unf@@ -3766,7 +3796,9 @@ simplStableUnfolding :: SimplEnv -> TopLevelFlag -> MaybeJoinCont -- Just k => a join point with continuation k -> InId- -> OutType -> Arity -> Unfolding+ -> OutType+ -> ArityType -- Used to eta expand, but only for non-join-points+ -> Unfolding ->SimplM Unfolding -- Note [Setting the new unfolding] simplStableUnfolding env top_lvl mb_cont id rhs_ty id_arity unf@@ -3829,7 +3861,7 @@ eta_expand expr | not eta_on = expr | exprIsTrivial expr = expr- | otherwise = etaExpand id_arity expr+ | otherwise = etaExpandAT id_arity expr eta_on = sm_eta_expand (getMode env) {- Note [Eta-expand stable unfoldings]
compiler/GHC/Core/Opt/Simplify/Env.hs view
@@ -51,6 +51,7 @@ import GHC.Core.Opt.Monad ( SimplMode(..) ) import GHC.Core import GHC.Core.Utils+import GHC.Core.Multiplicity ( scaleScaled ) import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set@@ -59,6 +60,7 @@ import GHC.Core.Make ( mkWildValBinder ) import GHC.Driver.Session ( DynFlags ) import GHC.Builtin.Types+import GHC.Core.TyCo.Rep ( TyCoBinder(..) ) import qualified GHC.Core.Type as Type import GHC.Core.Type hiding ( substTy, substTyVar, substTyVarBndr, extendTvSubst, extendCvSubst ) import qualified GHC.Core.Coercion as Coercion@@ -741,24 +743,14 @@ simplBinder env bndr | isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr ; seqTyVar tv `seq` return (env', tv) }- | otherwise = do { let (env', id) = substIdBndr Nothing env bndr+ | otherwise = do { let (env', id) = substIdBndr env bndr ; seqId id `seq` return (env', id) } --------------- simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) -- A non-recursive let binder simplNonRecBndr env id- = do { let (env1, id1) = substIdBndr Nothing env id- ; seqId id1 `seq` return (env1, id1) }------------------simplNonRecJoinBndr :: SimplEnv -> OutType -> InBndr- -> SimplM (SimplEnv, OutBndr)--- A non-recursive let binder for a join point;--- context being pushed inward may change the type--- See Note [Return type for join points]-simplNonRecJoinBndr env res_ty id- = do { let (env1, id1) = substIdBndr (Just res_ty) env id+ = do { let (env1, id1) = substIdBndr env id ; seqId id1 `seq` return (env1, id1) } ---------------@@ -766,31 +758,20 @@ -- Recursive let binders simplRecBndrs env@(SimplEnv {}) ids = ASSERT(all (not . isJoinId) ids)- do { let (env1, ids1) = mapAccumL (substIdBndr Nothing) env ids+ do { let (env1, ids1) = mapAccumL substIdBndr env ids ; seqIds ids1 `seq` return env1 } -----------------simplRecJoinBndrs :: SimplEnv -> OutType -> [InBndr] -> SimplM SimplEnv--- Recursive let binders for join points;--- context being pushed inward may change types--- See Note [Return type for join points]-simplRecJoinBndrs env@(SimplEnv {}) res_ty ids- = ASSERT(all isJoinId ids)- do { let (env1, ids1) = mapAccumL (substIdBndr (Just res_ty)) env ids- ; seqIds ids1 `seq` return env1 } ----------------substIdBndr :: Maybe OutType -> SimplEnv -> InBndr -> (SimplEnv, OutBndr)+substIdBndr :: SimplEnv -> InBndr -> (SimplEnv, OutBndr) -- Might be a coercion variable-substIdBndr new_res_ty env bndr+substIdBndr env bndr | isCoVar bndr = substCoVarBndr env bndr- | otherwise = substNonCoVarIdBndr new_res_ty env bndr+ | otherwise = substNonCoVarIdBndr env bndr --------------- substNonCoVarIdBndr- :: Maybe OutType -- New result type, if a join binder- -- See Note [Return type for join points]- -> SimplEnv+ :: SimplEnv -> InBndr -- Env and binder to transform -> (SimplEnv, OutBndr) -- Clone Id if necessary, substitute its type@@ -810,25 +791,28 @@ -- Similar to GHC.Core.Subst.substIdBndr, except that -- the type of id_subst differs -- all fragile info is zapped-substNonCoVarIdBndr new_res_ty- env@(SimplEnv { seInScope = in_scope- , seIdSubst = id_subst })- old_id+substNonCoVarIdBndr env id = subst_id_bndr env id (\x -> x)++subst_id_bndr :: SimplEnv+ -> InBndr -- Env and binder to transform+ -> (OutId -> OutId) -- Adjust the type+ -> (SimplEnv, OutBndr)+subst_id_bndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })+ old_id adjust_type = 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+ -- 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+ -- afresh with both seInScope and seIdSubst where- id1 = uniqAway in_scope old_id- id2 = substIdType env id1-- id3 | Just res_ty <- new_res_ty- = id2 `setIdType` setJoinResTy (idJoinArity id2) res_ty (idType id2)- -- See Note [Return type for join points]- | otherwise- = id2-- new_id = zapFragileIdInfo id3 -- Zaps rules, worker-info, unfolding- -- and fragile OccInfo+ id1 = uniqAway in_scope old_id+ id2 = substIdType env id1+ id3 = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding+ -- and fragile OccInfo+ new_id = adjust_type id3 -- Extend the substitution if the unique has changed, -- or there's some useful occurrence information@@ -888,6 +872,100 @@ the letrec. -} ++{- *********************************************************************+* *+ Join points+* *+********************************************************************* -}++simplNonRecJoinBndr :: SimplEnv -> InBndr+ -> Mult -> OutType+ -> SimplM (SimplEnv, OutBndr)++-- A non-recursive let binder for a join point;+-- context being pushed inward may change the type+-- See Note [Return type for join points]+simplNonRecJoinBndr env id mult res_ty+ = do { let (env1, id1) = simplJoinBndr mult res_ty env id+ ; seqId id1 `seq` return (env1, id1) }++simplRecJoinBndrs :: SimplEnv -> [InBndr]+ -> Mult -> OutType+ -> SimplM SimplEnv+-- Recursive let binders for join points;+-- context being pushed inward may change types+-- See Note [Return type for join points]+simplRecJoinBndrs env@(SimplEnv {}) ids mult res_ty+ = ASSERT(all isJoinId ids)+ do { let (env1, ids1) = mapAccumL (simplJoinBndr mult res_ty) env ids+ ; seqIds ids1 `seq` return env1 }++---------------+simplJoinBndr :: Mult -> OutType+ -> SimplEnv -> InBndr+ -> (SimplEnv, OutBndr)+simplJoinBndr mult res_ty env id+ = subst_id_bndr env id (adjustJoinPointType mult res_ty)++---------------+adjustJoinPointType :: Mult+ -> Type -- New result type+ -> Id -- Old join-point Id+ -> Id -- Adjusted jont-point Id+-- (adjustJoinPointType mult new_res_ty join_id) does two things:+--+-- 1. Set the return type of the join_id to new_res_ty+-- See Note [Return type for join points]+--+-- 2. Adjust the multiplicity of arrows in join_id's type, as+-- directed by 'mult'. See Note [Scaling join point arguments]+--+-- INVARIANT: If any of the first n binders are foralls, those tyvars+-- cannot appear in the original result type. See isValidJoinPointType.+adjustJoinPointType mult new_res_ty join_id+ = ASSERT( isJoinId join_id )+ setIdType join_id new_join_ty+ where+ orig_ar = idJoinArity join_id+ orig_ty = idType join_id++ new_join_ty = go orig_ar orig_ty++ go 0 _ = new_res_ty+ go n ty | Just (arg_bndr, res_ty) <- splitPiTy_maybe ty+ = mkPiTy (scale_bndr arg_bndr) $+ go (n-1) res_ty+ | otherwise+ = pprPanic "adjustJoinPointType" (ppr orig_ar <+> ppr orig_ty)++ scale_bndr (Anon af t) = Anon af (scaleScaled mult t)+ scale_bndr b@(Named _) = b++{- Note [Scaling join point arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a join point which is linear in its variable, in some context E:++E[join j :: a #-> a+ j x = x+ in case v of+ A -> j 'x'+ B -> <blah>]++The simplifier changes to:++join j :: a #-> a+ j x = E[x]+in case v of+ A -> j 'x'+ B -> E[<blah>]++If E uses its argument in a nonlinear way (e.g. a case['Many]), then+this is wrong: the join point has to change its type to a -> a.+Otherwise, we'd get a linearity error.++See also Note [Return type for join points] and Note [Join points and case-of-case].+-} {- ************************************************************************
compiler/GHC/Core/Opt/Simplify/Monad.hs view
@@ -43,6 +43,7 @@ import GHC.Types.Basic ( IntWithInf, treatZeroAsInf, mkIntWithInf ) import Control.Monad ( ap ) import GHC.Core.Multiplicity ( pattern Many )+import GHC.Exts( oneShot ) {- ************************************************************************@@ -56,13 +57,24 @@ -} newtype SimplM result- = SM { unSM :: SimplTopEnv -- Envt that does not change much- -> UniqSupply -- We thread the unique supply because- -- constantly splitting it is rather expensive- -> SimplCount- -> IO (result, UniqSupply, SimplCount)}- -- we only need IO here for dump output+ = SM' { unSM :: SimplTopEnv -- Envt that does not change much+ -> UniqSupply -- We thread the unique supply because+ -- constantly splitting it is rather expensive+ -> SimplCount+ -> IO (result, UniqSupply, SimplCount)}+ -- We only need IO here for dump output deriving (Functor)++pattern SM :: (SimplTopEnv -> UniqSupply -> SimplCount+ -> IO (result, UniqSupply, SimplCount))+ -> SimplM result+-- This pattern synonym makes the simplifier monad eta-expand,+-- which as a very beneficial effect on compiler performance+-- (worth a 1-2% reduction in bytes-allocated). See #18202.+-- See Note [The one-shot state monad trick] in GHC.Core.Unify+pattern SM m <- SM' m+ where+ SM m = SM' (oneShot m) data SimplTopEnv = STE { st_flags :: DynFlags
compiler/GHC/Core/Opt/Simplify/Utils.hs view
@@ -29,6 +29,7 @@ ArgInfo(..), ArgSpec(..), mkArgInfo, addValArgTo, addCastTo, addTyArgTo, argInfoExpr, argInfoAppArgs, pushSimplifiedArgs,+ isStrictArgInfo, lazyArgContext, abstractFloats, @@ -124,8 +125,7 @@ -- See Note [The hole type in ApplyToTy/Val] , sc_arg :: InExpr -- The argument, , sc_env :: StaticEnv -- see Note [StaticEnv invariant]- , sc_cont :: SimplCont- , sc_mult :: Mult }+ , sc_cont :: SimplCont } | ApplyToTy -- (ApplyToTy ty K)[e] = K[ e ty ] { sc_arg_ty :: OutType -- Argument type@@ -153,13 +153,13 @@ | StrictArg -- (StrictArg (f e1 ..en) K)[e] = K[ f e1 .. en e ] { sc_dup :: DupFlag -- Always Simplified or OkToDup , sc_fun :: ArgInfo -- Specifies f, e1..en, Whether f has rules, etc- -- plus strictness flags for *further* args- , sc_cci :: CallCtxt -- Whether *this* argument position is interesting+ -- plus demands and discount flags for *this* arg+ -- and further args+ -- So ai_dmds and ai_discs are never empty , sc_fun_ty :: OutType -- Type of the function (f e1 .. en), -- presumably (arg_ty -> res_ty) -- where res_ty is expected by sc_cont- , sc_cont :: SimplCont- , sc_mult :: Mult }+ , sc_cont :: SimplCont } | TickIt -- (TickIt t K)[e] = K[ tick t e ] (Tickish Id) -- Tick tickish <hole>@@ -269,32 +269,50 @@ -- or an enclosing one has rules (recursively) -- True => be keener to inline in all args - ai_strs :: [Bool], -- Strictness of remaining arguments+ ai_dmds :: [Demand], -- Demands on remaining value arguments (beyond ai_args) -- Usually infinite, but if it is finite it guarantees -- that the function diverges after being given -- that number of args- ai_discs :: [Int] -- Discounts for remaining arguments; non-zero => be keener to inline++ ai_discs :: [Int] -- Discounts for remaining value arguments (beyong ai_args)+ -- non-zero => be keener to inline -- Always infinite } data ArgSpec- = ValArg { as_mult :: Mult- , as_arg :: OutExpr -- Apply to this (coercion or value); c.f. ApplyToVal+ = ValArg { as_dmd :: Demand -- Demand placed on this argument+ , as_arg :: OutExpr -- Apply to this (coercion or value); c.f. ApplyToVal , as_hole_ty :: OutType } -- Type of the function (presumably t1 -> t2)+ | TyArg { as_arg_ty :: OutType -- Apply to this type; c.f. ApplyToTy , as_hole_ty :: OutType } -- Type of the function (presumably forall a. blah)+ | CastBy OutCoercion -- Cast by this; c.f. CastIt +instance Outputable ArgInfo where+ ppr (ArgInfo { ai_fun = fun, ai_args = args, ai_dmds = dmds })+ = text "ArgInfo" <+> braces+ (sep [ text "fun =" <+> ppr fun+ , text "dmds =" <+> ppr dmds+ , text "args =" <+> ppr args ])+ instance Outputable ArgSpec where- ppr (ValArg { as_mult = mult, as_arg = arg }) = text "ValArg" <+> ppr mult <+> ppr arg+ ppr (ValArg { as_arg = arg }) = text "ValArg" <+> ppr arg ppr (TyArg { as_arg_ty = ty }) = text "TyArg" <+> ppr ty ppr (CastBy c) = text "CastBy" <+> ppr c -addValArgTo :: ArgInfo -> (Mult, OutExpr) -> OutType -> ArgInfo-addValArgTo ai (w, arg) hole_ty = ai { ai_args = arg_spec : ai_args ai- , ai_rules = decRules (ai_rules ai) }- where- arg_spec = ValArg { as_arg = arg, as_hole_ty = hole_ty, as_mult = w }+addValArgTo :: ArgInfo -> OutExpr -> OutType -> ArgInfo+addValArgTo ai arg hole_ty+ | ArgInfo { ai_dmds = dmd:dmds, ai_discs = _:discs, ai_rules = rules } <- ai+ -- Pop the top demand and and discounts off+ , let arg_spec = ValArg { as_arg = arg, as_hole_ty = hole_ty, as_dmd = dmd }+ = ai { ai_args = arg_spec : ai_args ai+ , ai_dmds = dmds+ , ai_discs = discs+ , ai_rules = decRules rules }+ | otherwise+ = pprPanic "addValArgTo" (ppr ai $$ ppr arg)+ -- There should always be enough demands and discounts addTyArgTo :: ArgInfo -> OutType -> OutType -> ArgInfo addTyArgTo ai arg_ty hole_ty = ai { ai_args = arg_spec : ai_args ai@@ -305,6 +323,12 @@ addCastTo :: ArgInfo -> OutCoercion -> ArgInfo addCastTo ai co = ai { ai_args = CastBy co : ai_args ai } +isStrictArgInfo :: ArgInfo -> Bool+-- True if the function is strict in the next argument+isStrictArgInfo (ArgInfo { ai_dmds = dmds })+ | dmd:_ <- dmds = isStrictDmd dmd+ | otherwise = False+ argInfoAppArgs :: [ArgSpec] -> [OutExpr] argInfoAppArgs [] = [] argInfoAppArgs (CastBy {} : _) = [] -- Stop at a cast@@ -317,9 +341,9 @@ = case arg of TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty } -> ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = rest }- ValArg { as_arg = arg, as_hole_ty = hole_ty, as_mult = w }+ ValArg { as_arg = arg, as_hole_ty = hole_ty } -> ApplyToVal { sc_arg = arg, sc_env = env, sc_dup = Simplified- , sc_hole_ty = hole_ty, sc_cont = rest, sc_mult = w }+ , sc_hole_ty = hole_ty, sc_cont = rest } CastBy c -> CastIt c rest where rest = pushSimplifiedArgs env args k@@ -418,7 +442,7 @@ contHoleType (CastIt co _) = coercionLKind co contHoleType (StrictBind { sc_bndr = b, sc_dup = dup, sc_env = se }) = perhapsSubstTy dup se (idType b)-contHoleType (StrictArg { sc_fun_ty = ty, sc_mult = _m }) = funArgTy ty+contHoleType (StrictArg { sc_fun_ty = ty }) = funArgTy ty contHoleType (ApplyToTy { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy] contHoleType (ApplyToVal { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy/Val] contHoleType (Select { sc_dup = d, sc_bndr = b, sc_env = se })@@ -436,12 +460,14 @@ contHoleScaling :: SimplCont -> Mult contHoleScaling (Stop _ _) = One contHoleScaling (CastIt _ k) = contHoleScaling k-contHoleScaling (StrictBind { sc_bndr = id, sc_cont = k }) =- (idMult id) `mkMultMul` contHoleScaling k-contHoleScaling (StrictArg { sc_mult = w, sc_cont = k }) =- w `mkMultMul` contHoleScaling k-contHoleScaling (Select { sc_bndr = id, sc_cont = k }) =- (idMult id) `mkMultMul` contHoleScaling k+contHoleScaling (StrictBind { sc_bndr = id, sc_cont = k })+ = idMult id `mkMultMul` contHoleScaling k+contHoleScaling (Select { sc_bndr = id, sc_cont = k })+ = idMult id `mkMultMul` contHoleScaling k+contHoleScaling (StrictArg { sc_fun_ty = fun_ty, sc_cont = k })+ = w `mkMultMul` contHoleScaling k+ where+ (w, _, _) = splitFunTy fun_ty contHoleScaling (ApplyToTy { sc_cont = k }) = contHoleScaling k contHoleScaling (ApplyToVal { sc_cont = k }) = contHoleScaling k contHoleScaling (TickIt _ k) = contHoleScaling k@@ -461,8 +487,8 @@ | otherwise = go [] cont where lone (ApplyToTy {}) = False -- See Note [Lone variables] in GHC.Core.Unfold- lone (ApplyToVal {}) = False- lone (CastIt {}) = False+ lone (ApplyToVal {}) = False -- NB: even a type application or cast+ lone (CastIt {}) = False -- stops it being "lone" lone _ = True go args (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = k })@@ -489,17 +515,16 @@ = ArgInfo { ai_fun = fun, ai_args = [] , ai_rules = fun_rules , ai_encl = False- , ai_strs = vanilla_stricts+ , ai_dmds = vanilla_dmds , ai_discs = vanilla_discounts } | otherwise- = ArgInfo { ai_fun = fun, ai_args = []+ = ArgInfo { ai_fun = fun+ , ai_args = [] , ai_rules = fun_rules , ai_encl = interestingArgContext rules call_cont- , ai_strs = arg_stricts+ , ai_dmds = add_type_strictness (idType fun) arg_dmds , ai_discs = arg_discounts } where- fun_ty = idType fun- fun_rules = mkFunRules rules vanilla_discounts, arg_discounts :: [Int]@@ -509,14 +534,14 @@ -> discounts ++ vanilla_discounts _ -> vanilla_discounts - vanilla_stricts, arg_stricts :: [Bool]- vanilla_stricts = repeat False+ vanilla_dmds, arg_dmds :: [Demand]+ vanilla_dmds = repeat topDmd - arg_stricts+ arg_dmds | not (sm_inline (seMode env))- = vanilla_stricts -- See Note [Do not expose strictness if sm_inline=False]+ = vanilla_dmds -- See Note [Do not expose strictness if sm_inline=False] | otherwise- = add_type_str fun_ty $+ = -- add_type_str fun_ty $ case splitStrictSig (idStrictness fun) of (demands, result_info) | not (demands `lengthExceeds` n_val_args)@@ -529,36 +554,40 @@ -- inlining lone variables, so its ok -- (see GHC.Core.Op.Simplify.Utils.analyseCont) if isDeadEndDiv result_info then- map isStrictDmd demands -- Finite => result is bottom+ demands -- Finite => result is bottom else- map isStrictDmd demands ++ vanilla_stricts+ demands ++ vanilla_dmds | otherwise -> WARN( True, text "More demands than arity" <+> ppr fun <+> ppr (idArity fun) <+> ppr n_val_args <+> ppr demands )- vanilla_stricts -- Not enough args, or no strictness+ vanilla_dmds -- Not enough args, or no strictness - add_type_str :: Type -> [Bool] -> [Bool]+ add_type_strictness :: Type -> [Demand] -> [Demand] -- If the function arg types are strict, record that in the 'strictness bits' -- No need to instantiate because unboxed types (which dominate the strict -- types) can't instantiate type variables.- -- add_type_str is done repeatedly (for each call);+ -- add_type_strictness is done repeatedly (for each call); -- might be better once-for-all in the function -- But beware primops/datacons with no strictness - add_type_str _ [] = []- add_type_str fun_ty all_strs@(str:strs)+ add_type_strictness fun_ty dmds+ | null dmds = []++ | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty+ = add_type_strictness fun_ty' dmds -- Look through foralls+ | Just (_, arg_ty, fun_ty') <- splitFunTy_maybe fun_ty -- Add strict-type info- = (str || Just False == isLiftedType_maybe arg_ty)- : add_type_str fun_ty' strs+ , dmd : rest_dmds <- dmds+ , let dmd' = case isLiftedType_maybe arg_ty of+ Just False -> strictenDmd dmd+ _ -> dmd+ = dmd' : add_type_strictness fun_ty' rest_dmds -- If the type is levity-polymorphic, we can't know whether it's -- strict. isLiftedType_maybe will return Just False only when -- we're sure the type is unlifted. - | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty- = add_type_str fun_ty' all_strs -- Look through foralls- | otherwise- = all_strs+ = dmds {- Note [Unsaturated functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -647,6 +676,26 @@ and it looks plausible to me. -} +lazyArgContext :: ArgInfo -> CallCtxt+-- Use this for lazy arguments+lazyArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs })+ | encl_rules = RuleArgCtxt+ | disc:_ <- discs, disc > 0 = DiscArgCtxt -- Be keener here+ | otherwise = BoringCtxt -- Nothing interesting++strictArgContext :: ArgInfo -> CallCtxt+strictArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs })+-- Use this for strict arguments+ | encl_rules = RuleArgCtxt+ | disc:_ <- discs, disc > 0 = DiscArgCtxt -- Be keener here+ | otherwise = RhsCtxt+ -- Why RhsCtxt? if we see f (g x) (h x), and f is strict, we+ -- want to be a bit more eager to inline g, because it may+ -- expose an eval (on x perhaps) that can be eliminated or+ -- shared. I saw this in nofib 'boyer2', RewriteFuns.onewayunify1+ -- It's worth an 18% improvement in allocation for this+ -- particular benchmark; 5% on 'mate' and 1.3% on 'multiplier'+ interestingCallContext :: SimplEnv -> SimplCont -> CallCtxt -- See Note [Interesting call context] interestingCallContext env cont@@ -663,7 +712,7 @@ -- motivation to inline. See Note [Cast then apply] -- in GHC.Core.Unfold - interesting (StrictArg { sc_cci = cci }) = cci+ interesting (StrictArg { sc_fun = fun }) = strictArgContext fun interesting (StrictBind {}) = BoringCtxt interesting (Stop _ cci) = cci interesting (TickIt _ k) = interesting k@@ -713,16 +762,13 @@ go (Select {}) = False go (ApplyToVal {}) = False -- Shouldn't really happen go (ApplyToTy {}) = False -- Ditto- go (StrictArg { sc_cci = cci }) = interesting cci+ go (StrictArg { sc_fun = fun }) = ai_encl fun go (StrictBind {}) = False -- ?? go (CastIt _ c) = go c- go (Stop _ cci) = interesting cci+ go (Stop _ RuleArgCtxt) = True+ go (Stop _ _) = False go (TickIt _ c) = go c - interesting RuleArgCtxt = True- interesting _ = False-- {- Note [Interesting arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ An argument is interesting if it deserves a discount for unfoldings@@ -1201,9 +1247,9 @@ extend_subst_with inl_rhs = extendIdSubst env bndr (mkContEx rhs_env inl_rhs) one_occ IAmDead = True -- Happens in ((\x.1) v)- one_occ OneOcc{ occ_one_br = InOneBranch+ one_occ OneOcc{ occ_n_br = 1 , occ_in_lam = NotInsideLam } = isNotTopLevel top_lvl || early_phase- one_occ OneOcc{ occ_one_br = InOneBranch+ one_occ OneOcc{ occ_n_br = 1 , occ_in_lam = IsInsideLam , occ_int_cxt = IsInteresting } = canInlineInLam rhs one_occ _ = False@@ -1317,24 +1363,15 @@ | exprIsTrivial rhs = True | otherwise = case occ_info of- -- The point of examining occ_info here is that for *non-values*- -- that occur outside a lambda, the call-site inliner won't have- -- a chance (because it doesn't know that the thing- -- only occurs once). The pre-inliner won't have gotten- -- it either, if the thing occurs in more than one branch- -- So the main target is things like- -- let x = f y in- -- case v of- -- True -> case x of ...- -- False -> case x of ...- -- This is very important in practice; e.g. wheel-seive1 doubles- -- in allocation if you miss this out- OneOcc { occ_in_lam = in_lam, occ_int_cxt = int_cxt }- -- OneOcc => no code-duplication issue- -> smallEnoughToInline dflags unfolding -- Small enough to dup+ OneOcc { occ_in_lam = in_lam, occ_int_cxt = int_cxt, occ_n_br = n_br }+ -- See Note [Inline small things to avoid creating a thunk]++ -> n_br < 100 -- See Note [Suppress exponential blowup]++ && smallEnoughToInline dflags unfolding -- Small enough to dup -- ToDo: consider discount on smallEnoughToInline if int_cxt is true --- -- NB: Do NOT inline arbitrarily big things, even if one_br is True+ -- NB: Do NOT inline arbitrarily big things, even if occ_n_br=1 -- Reason: doing so risks exponential behaviour. We simplify a big -- expression, inline it, and simplify it again. But if the -- very same thing happens in the big expression, we get@@ -1381,7 +1418,56 @@ active = isActive (sm_phase (getMode env)) (idInlineActivation bndr) -- See Note [pre/postInlineUnconditionally in gentle mode] -{-+{- Note [Inline small things to avoid creating a thunk]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The point of examining occ_info here is that for *non-values* that+occur outside a lambda, the call-site inliner won't have a chance+(because it doesn't know that the thing only occurs once). The+pre-inliner won't have gotten it either, if the thing occurs in more+than one branch So the main target is things like++ let x = f y in+ case v of+ True -> case x of ...+ False -> case x of ...++This is very important in practice; e.g. wheel-seive1 doubles+in allocation if you miss this out. And bits of GHC itself start+to allocate more. An egregious example is test perf/compiler/T14697,+where GHC.Driver.CmdLine.$wprocessArgs allocated hugely more.++Note [Suppress exponential blowup]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In #13253, and several related tickets, we got an exponential blowup+in code size from postInlineUnconditionally. The trouble comes when+we have+ let j1a = case f y of { True -> p; False -> q }+ j1b = case f y of { True -> q; False -> p }+ j2a = case f (y+1) of { True -> j1a; False -> j1b }+ j2b = case f (y+1) of { True -> j1b; False -> j1a }+ ...+ in case f (y+10) of { True -> j10a; False -> j10b }++when there are many branches. In pass 1, postInlineUnconditionally+inlines j10a and j10b (they are both small). Now we have two calls+to j9a and two to j9b. In pass 2, postInlineUnconditionally inlines+all four of these calls, leaving four calls to j8a and j8b. Etc.+Yikes! This is exponential!++A possible plan: stop doing postInlineUnconditionally+for some fixed, smallish number of branches, say 4. But that turned+out to be bad: see Note [Inline small things to avoid creating a thunk].+And, as it happened, the problem with #13253 was solved in a+different way (Note [Duplicating StrictArg] in Simplify).++So I just set an arbitrary, high limit of 100, to stop any+totally exponential behaviour.++This still leaves the nasty possiblity that /ordinary/ inlining (not+postInlineUnconditionally) might inline these join points, each of+which is individually quiet small. I'm still not sure what to do+about this (e.g. see #15488).+ Note [Top level and postInlineUnconditionally] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We don't do postInlineUnconditionally for top-level things (even for@@ -1479,9 +1565,9 @@ , sm_eta_expand (getMode env) , any isRuntimeVar bndrs , let body_arity = exprEtaExpandArity dflags body- , body_arity > 0+ , expandableArityType body_arity = do { tick (EtaExpansion (head bndrs))- ; let res = mkLams bndrs (etaExpand body_arity body)+ ; let res = mkLams bndrs (etaExpandAT body_arity body) ; traceSmpl "eta expand" (vcat [text "before" <+> ppr (mkLams bndrs body) , text "after" <+> ppr res]) ; return res }@@ -1551,7 +1637,7 @@ -} tryEtaExpandRhs :: SimplMode -> OutId -> OutExpr- -> SimplM (Arity, Bool, OutExpr)+ -> SimplM (ArityType, OutExpr) -- See Note [Eta-expanding at let bindings] -- If tryEtaExpandRhs rhs = (n, is_bot, rhs') then -- (a) rhs' has manifest arity n@@ -1559,40 +1645,46 @@ tryEtaExpandRhs mode bndr rhs | Just join_arity <- isJoinId_maybe bndr = do { let (join_bndrs, join_body) = collectNBinders join_arity rhs- ; return (count isId join_bndrs, exprIsDeadEnd join_body, rhs) }+ oss = [idOneShotInfo id | id <- join_bndrs, isId id]+ arity_type | exprIsDeadEnd join_body = ABot (length oss)+ | otherwise = ATop oss+ ; return (arity_type, rhs) } -- Note [Do not eta-expand join points] -- But do return the correct arity and bottom-ness, because -- these are used to set the bndr's IdInfo (#15517) -- Note [Invariants on join points] invariant 2b, in GHC.Core + | sm_eta_expand mode -- Provided eta-expansion is on+ , new_arity > old_arity -- And the current manifest arity isn't enough+ , want_eta rhs+ = do { tick (EtaExpansion bndr)+ ; return (arity_type, etaExpandAT arity_type rhs) }+ | otherwise- = do { (new_arity, is_bot, new_rhs) <- try_expand+ = return (arity_type, rhs) - ; WARN( new_arity < old_id_arity,- (text "Arity decrease:" <+> (ppr bndr <+> ppr old_id_arity- <+> ppr old_arity <+> ppr new_arity) $$ ppr new_rhs) )- -- Note [Arity decrease] in GHC.Core.Opt.Simplify- return (new_arity, is_bot, new_rhs) } where- try_expand- | exprIsTrivial rhs -- See Note [Do not eta-expand trivial expressions]- = return (exprArity rhs, False, rhs)-- | sm_eta_expand mode -- Provided eta-expansion is on- , new_arity > old_arity -- And the current manifest arity isn't enough- = do { tick (EtaExpansion bndr)- ; return (new_arity, is_bot, etaExpand new_arity rhs) }-- | otherwise- = return (old_arity, is_bot && new_arity == old_arity, rhs)+ dflags = sm_dflags mode+ old_arity = exprArity rhs - dflags = sm_dflags mode- old_arity = exprArity rhs -- See Note [Do not expand eta-expand PAPs]- old_id_arity = idArity bndr+ arity_type = findRhsArity dflags bndr rhs old_arity+ `maxWithArity` idCallArity bndr+ new_arity = arityTypeArity arity_type - (new_arity1, is_bot) = findRhsArity dflags bndr rhs old_arity- new_arity2 = idCallArity bndr- new_arity = max new_arity1 new_arity2+ -- See Note [Which RHSs do we eta-expand?]+ want_eta (Cast e _) = want_eta e+ want_eta (Tick _ e) = want_eta e+ want_eta (Lam b e) | isTyVar b = want_eta e+ want_eta (App e a) | exprIsTrivial a = want_eta e+ want_eta (Var {}) = False+ want_eta (Lit {}) = False+ want_eta _ = True+{-+ want_eta _ = case arity_type of+ ATop (os:_) -> isOneShotInfo os+ ATop [] -> False+ ABot {} -> True+-} {- Note [Eta-expanding at let bindings]@@ -1619,15 +1711,54 @@ as far as the programmer is concerned, it's not applied to two arguments! -Note [Do not eta-expand trivial expressions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Do not eta-expand a trivial RHS like- f = g-If we eta expand do- f = \x. g x-we'll just eta-reduce again, and so on; so the-simplifier never terminates.+Note [Which RHSs do we eta-expand?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We don't eta-expand: +* Trivial RHSs, e.g. f = g+ If we eta expand do+ f = \x. g x+ we'll just eta-reduce again, and so on; so the+ simplifier never terminates.++* PAPs: see Note [Do not eta-expand PAPs]++What about things like this?+ f = case y of p -> \x -> blah++Here we do eta-expand. This is a change (Jun 20), but if we have+really decided that f has arity 1, then putting that lambda at the top+seems like a Good idea.++Note [Do not eta-expand PAPs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to have old_arity = manifestArity rhs, which meant that we+would eta-expand even PAPs. But this gives no particular advantage,+and can lead to a massive blow-up in code size, exhibited by #9020.+Suppose we have a PAP+ foo :: IO ()+ foo = returnIO ()+Then we can eta-expand do+ foo = (\eta. (returnIO () |> sym g) eta) |> g+where+ g :: IO () ~ State# RealWorld -> (# State# RealWorld, () #)++But there is really no point in doing this, and it generates masses of+coercions and whatnot that eventually disappear again. For T9020, GHC+allocated 6.6G before, and 0.8G afterwards; and residency dropped from+1.8G to 45M.++Moreover, if we eta expand+ f = g d ==> f = \x. g d x+that might in turn make g inline (if it has an inline pragma), which+we might not want. After all, INLINE pragmas say "inline only when+saturated" so we don't want to be too gung-ho about saturating!++But note that this won't eta-expand, say+ f = \g -> map g+Does it matter not eta-expanding such functions? I'm not sure. Perhaps+strictness analysis will have less to bite on?+ Note [Do not eta-expand join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Similarly to CPR (see Note [Don't w/w join points for CPR] in@@ -1666,29 +1797,6 @@ $j2 :: Int -> State# RealWorld -> (# State# RealWorld, ()) $j2 = if n > 0 then $j1 else (...) eta--Note [Do not eta-expand PAPs]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We used to have old_arity = manifestArity rhs, which meant that we-would eta-expand even PAPs. But this gives no particular advantage,-and can lead to a massive blow-up in code size, exhibited by #9020.-Suppose we have a PAP- foo :: IO ()- foo = returnIO ()-Then we can eta-expand do- foo = (\eta. (returnIO () |> sym g) eta) |> g-where- g :: IO () ~ State# RealWorld -> (# State# RealWorld, () #)--But there is really no point in doing this, and it generates masses of-coercions and whatnot that eventually disappear again. For T9020, GHC-allocated 6.6G before, and 0.8G afterwards; and residency dropped from-1.8G to 45M.--But note that this won't eta-expand, say- f = \g -> map g-Does it matter not eta-expanding such functions? I'm not sure. Perhaps-strictness analysis will have less to bite on? ************************************************************************
compiler/GHC/Core/Opt/SpecConstr.hs view
@@ -1090,7 +1090,7 @@ | ScrutOcc -- See Note [ScrutOcc] (DataConEnv [ArgOcc]) -- How the sub-components are used -type DataConEnv a = UniqFM a -- Keyed by DataCon+type DataConEnv a = UniqFM DataCon a -- Keyed by DataCon {- Note [ScrutOcc] ~~~~~~~~~~~~~~~~~~~
compiler/GHC/Core/Opt/Specialise.hs view
@@ -39,7 +39,7 @@ import GHC.Types.Unique.Supply import GHC.Types.Name import GHC.Types.Id.Make ( voidArgId, voidPrimId )-import GHC.Builtin.Types.Prim ( voidPrimTy )+import GHC.Builtin.Types ( unboxedUnitTy ) import GHC.Data.Maybe ( mapMaybe, maybeToList, isJust ) import GHC.Utils.Monad ( foldlM ) import GHC.Types.Basic@@ -1427,7 +1427,7 @@ (spec_bndrs, spec_rhs, spec_fn_ty) | add_void_arg = ( voidPrimId : spec_bndrs1 , Lam voidArgId spec_rhs1- , mkVisFunTyMany voidPrimTy spec_fn_ty1)+ , mkVisFunTyMany unboxedUnitTy spec_fn_ty1) | otherwise = (spec_bndrs1, spec_rhs1, spec_fn_ty1) join_arity_decr = length rule_lhs_args - length spec_bndrs
compiler/GHC/Core/Opt/WorkWrap/Utils.hs view
@@ -28,8 +28,7 @@ import GHC.Core.Make ( mkAbsentErrorApp, mkCoreUbxTup , mkCoreApp, mkCoreLet ) import GHC.Types.Id.Make ( voidArgId, voidPrimId )-import GHC.Builtin.Types ( tupleDataCon )-import GHC.Builtin.Types.Prim ( voidPrimTy )+import GHC.Builtin.Types ( tupleDataCon, unboxedUnitTy ) import GHC.Types.Literal ( absentLiteralOf, rubbishLit ) import GHC.Types.Var.Env ( mkInScopeSet ) import GHC.Types.Var.Set ( VarSet )@@ -1256,7 +1255,7 @@ | Just tc <- tyConAppTyCon_maybe nty , Just lit <- absentLiteralOf tc = Just (Let (NonRec arg (Lit lit `mkCast` mkSymCo co)))- | nty `eqType` voidPrimTy+ | nty `eqType` unboxedUnitTy = Just (Let (NonRec arg (Var voidPrimId `mkCast` mkSymCo co))) | otherwise = WARN( True, text "No absent value for" <+> ppr arg_ty )
compiler/GHC/Core/Ppr/TyThing.hs view
@@ -166,7 +166,8 @@ -- We pretty-print 'TyThing' via 'IfaceDecl' -- See Note [Pretty-printing TyThings] pprTyThing ss ty_thing- = sdocWithDynFlags (\dflags -> pprIfaceDecl ss' (tyThingToIfaceDecl dflags 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' }
compiler/GHC/Core/Tidy.hs view
@@ -26,6 +26,7 @@ import GHC.Core.Coercion ( tidyCo ) import GHC.Types.Var import GHC.Types.Var.Env+import GHC.Types.Unique (getUnique) import GHC.Types.Unique.FM import GHC.Types.Name hiding (tidyNameOcc) import GHC.Types.SrcLoc@@ -121,7 +122,7 @@ tidyNameOcc :: TidyEnv -> Name -> Name -- In rules and instances, we have Names, and we must tidy them too -- Fortunately, we can lookup in the VarEnv with a name-tidyNameOcc (_, var_env) n = case lookupUFM var_env n of+tidyNameOcc (_, var_env) n = case lookupUFM_Directly var_env (getUnique n) of Nothing -> n Just v -> idName v
compiler/GHC/CoreToByteCode.hs view
@@ -19,13 +19,15 @@ import GHC.ByteCode.Asm import GHC.ByteCode.Types +import GHC.Platform+import GHC.Platform.Profile+ import GHC.Runtime.Interpreter import GHCi.FFI import GHCi.RemoteTypes import GHC.Types.Basic import GHC.Driver.Session import GHC.Utils.Outputable-import GHC.Platform import GHC.Types.Name import GHC.Types.Id.Make import GHC.Types.Id@@ -43,6 +45,7 @@ import GHC.Core.TyCon import GHC.Utils.Misc import GHC.Types.Var.Set+import GHC.Builtin.Types ( unboxedUnitTy ) import GHC.Builtin.Types.Prim import GHC.Core.TyCo.Ppr ( pprType ) import GHC.Utils.Error@@ -240,7 +243,7 @@ -- Create a BCO and do a spot of peephole optimisation on the insns -- at the same time. mkProtoBCO- :: DynFlags+ :: Platform -> name -> BCInstrList -> Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)@@ -251,7 +254,7 @@ -> Bool -- True <=> is a return point, rather than a function -> [FFIInfo] -> ProtoBCO name-mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis+mkProtoBCO platform nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis = ProtoBCO { protoBCOName = nm, protoBCOInstrs = maybe_with_stack_check,@@ -270,7 +273,7 @@ -- (hopefully rare) cases when the (overestimated) stack use -- exceeds iNTERP_STACK_CHECK_THRESH. maybe_with_stack_check- | is_ret && stack_usage < fromIntegral (aP_STACK_SPLIM dflags) = peep_d+ | is_ret && stack_usage < fromIntegral (pc_AP_STACK_SPLIM (platformConstants platform)) = peep_d -- don't do stack checks at return points, -- everything is aggregated up to the top BCO -- (which must be a function).@@ -311,7 +314,7 @@ schemeTopBind (id, rhs) | Just data_con <- isDataConWorkId_maybe id, isNullaryRepDataCon data_con = do- dflags <- getDynFlags+ platform <- profilePlatform <$> getProfile -- Special case for the worker of a nullary data con. -- It'll look like this: Nil = /\a -> Nil a -- If we feed it into schemeR, we'll get@@ -320,7 +323,7 @@ -- by just re-using the single top-level definition. So -- for the worker itself, we must allocate it directly. -- ioToBc (putStrLn $ "top level BCO")- emitBc (mkProtoBCO dflags (getName id) (toOL [PACK data_con 0, ENTER])+ emitBc (mkProtoBCO platform (getName id) (toOL [PACK data_con 0, ENTER]) (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) | otherwise@@ -379,9 +382,9 @@ -> BcM (ProtoBCO Name) schemeR_wrk fvs nm original_body (args, body) = do- dflags <- getDynFlags+ profile <- getProfile let- platform = targetPlatform dflags+ platform = profilePlatform profile all_args = reverse args ++ fvs arity = length all_args -- all_args are the args in reverse order. We're compiling a function@@ -400,7 +403,7 @@ bitmap = mkBitmap platform bits body_code <- schemeER_wrk sum_szsb_args p_init body - emitBc (mkProtoBCO dflags nm body_code (Right original_body)+ emitBc (mkProtoBCO platform nm body_code (Right original_body) arity bitmap_size bitmap False{-not alts-}) -- introduce break instructions for ticked expressions@@ -410,8 +413,7 @@ = do code <- schemeE d 0 p newRhs cc_arr <- getCCArray this_mod <- moduleName <$> getCurrentModule- dflags <- getDynFlags- let platform = targetPlatform dflags+ platform <- profilePlatform <$> getProfile let idOffSets = getVarOffSets platform d p fvs let breakInfo = CgBreakInfo { cgb_vars = idOffSets@@ -673,7 +675,7 @@ | isUnboxedTupleType (idType bndr) , Just ty <- case typePrimRep (idType bndr) of [_] -> Just (unwrapType (idType bndr))- [] -> Just voidPrimTy+ [] -> Just unboxedUnitTy _ -> Nothing -- handles any pattern with a single non-void binder; in particular I/O -- monad returns (# RealWorld#, a #)@@ -708,7 +710,7 @@ protectNNLJoinPointId :: Id -> Id protectNNLJoinPointId x = ASSERT( isNNLJoinPoint x )- updateIdTypeButNotMult (voidPrimTy `mkVisFunTyMany`) x+ updateIdTypeButNotMult (unboxedUnitTy `mkVisFunTyMany`) x {- Ticked Expressions@@ -743,8 +745,8 @@ 1. Detect NNLJPs. This is done in isNNLJoinPoint. -2. When binding an NNLJP, add a `\ (_ :: Void#) ->` to its RHS, and modify the- type to tack on a `Void# ->`. (Void# is written voidPrimTy within GHC.)+2. When binding an NNLJP, add a `\ (_ :: (# #)) ->` to its RHS, and modify the+ type to tack on a `(# #) ->`. Note that functions are never levity-polymorphic, so this transformation changes an NNLJP to a non-levity-polymorphic join point. This is done in protectNNLJoinPointBind, called from the AnnLet case of schemeE.@@ -878,8 +880,8 @@ ASSERT( args_r_to_l `lengthIs` dataConRepArity con ) app_code where app_code = do- dflags <- getDynFlags- let platform = targetPlatform dflags+ profile <- getProfile+ let platform = profilePlatform profile -- The args are initially in reverse order, but mkVirtHeapOffsets -- expects them to be left-to-right.@@ -890,7 +892,7 @@ , not (isVoidRep prim_rep) ] (_, _, args_offsets) =- mkVirtHeapOffsetsWithPadding dflags StdHeader non_voids+ mkVirtHeapOffsetsWithPadding profile StdHeader non_voids do_pushery !d (arg : args) = do (push, arg_bytes) <- case arg of@@ -999,10 +1001,11 @@ | otherwise = do- dflags <- getDynFlags+ profile <- getProfile hsc_env <- getHscEnv let- platform = targetPlatform dflags+ platform = profilePlatform profile+ profiling | Just interp <- hsc_interp hsc_env = interpreterProfiled interp@@ -1063,7 +1066,7 @@ -- algebraic alt with some binders | otherwise = let (tot_wds, _ptrs_wds, args_offsets) =- mkVirtHeapOffsets dflags NoHeader+ mkVirtHeapOffsets profile NoHeader [ NonVoid (bcIdPrimRep id, id) | NonVoid id <- nonVoidIds real_bndrs ]@@ -1138,7 +1141,7 @@ let alt_bco_name = getName bndr- alt_bco = mkProtoBCO dflags alt_bco_name alt_final (Left alts)+ alt_bco = mkProtoBCO platform alt_bco_name alt_final (Left alts) 0{-no arity-} bitmap_size bitmap True{-is alts-} -- trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++ -- "\n bitmap = " ++ show bitmap) $ do@@ -1172,10 +1175,10 @@ -> BcM BCInstrList generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l = do- dflags <- getDynFlags+ profile <- getProfile let- platform = targetPlatform dflags+ platform = profilePlatform profile -- useful constants addr_size_b :: ByteOff addr_size_b = wordSize platform@@ -1197,17 +1200,17 @@ Just t | t == arrayPrimTyCon || t == mutableArrayPrimTyCon -> do rest <- pargs (d + addr_size_b) az- code <- parg_ArrayishRep (fromIntegral (arrPtrsHdrSize dflags)) d p a+ code <- parg_ArrayishRep (fromIntegral (arrPtrsHdrSize profile)) d p a return ((code,AddrRep):rest) | t == smallArrayPrimTyCon || t == smallMutableArrayPrimTyCon -> do rest <- pargs (d + addr_size_b) az- code <- parg_ArrayishRep (fromIntegral (smallArrPtrsHdrSize dflags)) d p a+ code <- parg_ArrayishRep (fromIntegral (smallArrPtrsHdrSize profile)) d p a return ((code,AddrRep):rest) | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon -> do rest <- pargs (d + addr_size_b) az- code <- parg_ArrayishRep (fromIntegral (arrWordsHdrSize dflags)) d p a+ code <- parg_ArrayishRep (fromIntegral (arrWordsHdrSize profile)) d p a return ((code,AddrRep):rest) -- Default case: push taggedly, but otherwise intact.@@ -2014,6 +2017,9 @@ getHscEnv :: BcM HscEnv getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st)++getProfile :: BcM Profile+getProfile = targetProfile <$> getDynFlags emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name) emitBc bco
compiler/GHC/CoreToStg.hs view
@@ -42,7 +42,7 @@ import GHC.Data.FastString import GHC.Utils.Misc import GHC.Driver.Session-import GHC.Driver.Ways+import GHC.Platform.Ways import GHC.Types.ForeignCall import GHC.Types.Demand ( isUsedOnce ) import GHC.Builtin.PrimOps ( PrimCall(..) )@@ -445,7 +445,7 @@ _ -> pprPanic "coreToStgExpr" $ text "Unexpected unsafe equality case expression:" $$ ppr e0 $$- text "STG:" $$ ppr stg+ text "STG:" $$ pprStgExpr panicStgPprOpts stg _ -> return stg where vars_alt :: (AltCon, [Var], CoreExpr) -> CtsM (AltCon, [Var], StgExpr)
compiler/GHC/CoreToStg/Prep.hs view
@@ -53,7 +53,7 @@ import GHC.Data.OrdList import GHC.Utils.Error import GHC.Driver.Session-import GHC.Driver.Ways+import GHC.Platform.Ways import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Data.FastString
compiler/GHC/Data/Graph/Base.hs view
@@ -45,7 +45,7 @@ data Graph k cls color = Graph { -- | All active nodes in the graph.- graphMap :: UniqFM (Node k cls color) }+ graphMap :: UniqFM k (Node k cls color) } -- | An empty graph.@@ -57,7 +57,7 @@ -- | Modify the finite map holding the nodes in the graph. graphMapModify- :: (UniqFM (Node k cls color) -> UniqFM (Node k cls color))+ :: (UniqFM k (Node k cls color) -> UniqFM k (Node k cls color)) -> Graph k cls color -> Graph k cls color graphMapModify f graph
compiler/GHC/Data/Graph/Color.hs view
@@ -4,6 +4,7 @@ -- {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# LANGUAGE ScopedTypeVariables #-} module GHC.Data.Graph.Color ( module GHC.Data.Graph.Base,@@ -37,19 +38,20 @@ -- the stack (ie in reverse order) and assigning them colors different to their neighbors. -- colorGraph- :: ( Uniquable k, Uniquable cls, Uniquable color+ :: forall k cls color.+ ( Uniquable k, Uniquable cls, Uniquable color , Eq cls, Ord k , Outputable k, Outputable cls, Outputable color) => Bool -- ^ whether to do iterative coalescing -> Int -- ^ how many times we've tried to color this graph so far.- -> UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class).+ -> UniqFM cls (UniqSet color) -- ^ map of (node class -> set of colors available for this class). -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable. -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. -> Graph k cls color -- ^ the graph to color. -> ( Graph k cls color -- the colored graph. , UniqSet k -- the set of nodes that we couldn't find a color for.- , UniqFM k ) -- map of regs (r1 -> r2) that were coalesced+ , UniqFM k k ) -- map of regs (r1 -> r2) that were coalesced -- r1 should be replaced by r2 in the source colorGraph iterative spinCount colors triv spill graph0@@ -71,7 +73,7 @@ -- run the scanner to slurp out all the trivially colorable nodes -- (and do coalescing if iterative coalescing is enabled)- (ksTriv, ksProblems, kksCoalesce2)+ (ksTriv, ksProblems, kksCoalesce2 :: [(k,k)]) = colorScan iterative triv spill graph_coalesced -- If iterative coalescing is enabled, the scanner will coalesce the graph as does its business.@@ -253,9 +255,10 @@ -- | Try to assign a color to all these nodes. assignColors- :: ( Uniquable k, Uniquable cls, Uniquable color+ :: forall k cls color.+ ( Uniquable k, Uniquable cls, Uniquable color , Outputable cls)- => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class).+ => UniqFM cls (UniqSet color) -- ^ map of (node class -> set of colors available for this class). -> Graph k cls color -- ^ the graph -> [k] -- ^ nodes to assign a color to. -> ( Graph k cls color -- the colored graph@@ -264,7 +267,13 @@ assignColors colors graph ks = assignColors' colors graph [] ks - where assignColors' _ graph prob []+ where assignColors' :: UniqFM cls (UniqSet color) -- ^ map of (node class -> set of colors available for this class).+ -> Graph k cls color -- ^ the graph+ -> [k] -- ^ nodes to assign a color to.+ -> [k]+ -> ( Graph k cls color -- the colored graph+ , [k])+ assignColors' _ graph prob [] = (graph, prob) assignColors' colors graph prob (k:ks)@@ -293,7 +302,7 @@ selectColor :: ( Uniquable k, Uniquable cls, Uniquable color , Outputable cls)- => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class).+ => UniqFM cls (UniqSet color) -- ^ map of (node class -> set of colors available for this class). -> Graph k cls color -- ^ the graph -> k -- ^ key of the node to select a color for. -> Maybe color
compiler/GHC/Data/Graph/Ops.hs view
@@ -218,8 +218,8 @@ addConflictSet1 :: Uniquable k => k -> (k -> cls) -> UniqSet k- -> UniqFM (Node k cls color)- -> UniqFM (Node k cls color)+ -> UniqFM k (Node k cls color)+ -> UniqFM k (Node k cls color) addConflictSet1 u getClass set = case delOneFromUniqSet set u of set' -> adjustWithDefaultUFM@@ -645,7 +645,7 @@ slurpNodeConflictCount :: Graph k cls color- -> UniqFM (Int, Int) -- ^ (conflict neighbours, num nodes with that many conflicts)+ -> UniqFM Int (Int, Int) -- ^ (conflict neighbours, num nodes with that many conflicts) slurpNodeConflictCount graph = addListToUFM_C@@ -676,7 +676,7 @@ adjustWithDefaultUFM :: Uniquable k => (a -> a) -> a -> k- -> UniqFM a -> UniqFM a+ -> UniqFM k a -> UniqFM k a adjustWithDefaultUFM f def k map = addToUFM_C@@ -689,7 +689,7 @@ adjustUFM_C :: Uniquable k => (a -> a)- -> k -> UniqFM a -> UniqFM a+ -> k -> UniqFM k a -> UniqFM k a adjustUFM_C f k map = case lookupUFM map k of
compiler/GHC/Driver/Backpack.hs view
@@ -162,15 +162,15 @@ (case session_type of -- Make sure to write interfaces when we are type-checking -- indefinite packages.- TcSession | hscTarget dflags /= HscNothing+ TcSession | backend dflags /= NoBackend -> flip gopt_set Opt_WriteInterface | otherwise -> id CompSession -> id ExeSession -> id) $ dflags {- hscTarget = case session_type of- TcSession -> HscNothing- _ -> hscTarget dflags,+ backend = case session_type of+ TcSession -> NoBackend+ _ -> backend dflags, homeUnitInstantiations = insts, -- if we don't have any instantiation, don't -- fill `homeUnitInstanceOfId` as it makes no@@ -505,8 +505,7 @@ showMsg msg reason = backpackProgressMsg level dflags $ showModuleIndex mod_index ++- msg ++ showModMsg dflags (hscTarget dflags)- (recompileRequired recomp) mod_summary+ msg ++ showModMsg dflags (recompileRequired recomp) mod_summary ++ reason in case recomp of MustCompile -> showMsg "Compiling " ""@@ -695,6 +694,7 @@ ms_textual_imps = extra_sig_imports, ms_parsed_mod = Just (HsParsedModule { hpm_module = L loc (HsModule {+ hsmodLayout = NoLayoutInfo, hsmodName = Just (L loc mod_name), hsmodExports = Nothing, hsmodImports = [],
compiler/GHC/Driver/CodeOutput.hs view
@@ -23,7 +23,8 @@ import GHC.Types.Unique.Supply ( mkSplitUniqSupply ) import GHC.Driver.Finder ( mkStubPaths )-import GHC.CmmToC ( writeC )+import GHC.Driver.Backend+import GHC.CmmToC ( cmmToC ) import GHC.Cmm.Lint ( cmmLint ) import GHC.Cmm ( RawCmmGroup ) import GHC.Cmm.CLabel@@ -94,13 +95,13 @@ } ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs- ; a <- case hscTarget dflags of- HscAsm -> outputAsm dflags this_mod location filenm- linted_cmm_stream- HscC -> outputC dflags filenm linted_cmm_stream pkg_deps- HscLlvm -> outputLlvm dflags filenm linted_cmm_stream- HscInterpreted -> panic "codeOutput: HscInterpreted"- HscNothing -> panic "codeOutput: HscNothing"+ ; a <- case backend dflags of+ NCG -> outputAsm dflags this_mod location filenm+ linted_cmm_stream+ ViaC -> outputC dflags filenm linted_cmm_stream pkg_deps+ LLVM -> outputLlvm dflags filenm linted_cmm_stream+ Interpreter -> panic "codeOutput: Interpreter"+ NoBackend -> panic "codeOutput: NoBackend" ; return (filenm, stubs_exist, foreign_fps, a) } @@ -145,7 +146,9 @@ doOutput filenm $ \ h -> do hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") hPutStr h cc_injects- Stream.consume cmm_stream (writeC dflags h)+ let platform = targetPlatform dflags+ writeC = printForC dflags h . cmmToC platform+ Stream.consume cmm_stream writeC {- ************************************************************************@@ -159,7 +162,6 @@ -> Stream IO RawCmmGroup a -> IO a outputAsm dflags this_mod location filenm cmm_stream- | platformMisc_ghcWithNativeCodeGen $ platformMisc dflags = do ncg_uniqs <- mkSplitUniqSupply 'n' debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm)@@ -167,9 +169,6 @@ {-# SCC "OutputAsm" #-} doOutput filenm $ \h -> {-# SCC "NativeCodeGen" #-} nativeCodeGen dflags this_mod location h ncg_uniqs cmm_stream-- | otherwise- = panic "This compiler was built without a native code generator" {- ************************************************************************
compiler/GHC/Driver/Finder.hs view
@@ -42,7 +42,7 @@ import GHC.Utils.Misc import GHC.Builtin.Names ( gHC_PRIM ) import GHC.Driver.Session-import GHC.Driver.Ways+import GHC.Platform.Ways import GHC.Utils.Outputable as Outputable import GHC.Data.Maybe ( expectJust )
compiler/GHC/Driver/Main.hs view
@@ -149,6 +149,7 @@ import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos) import GHC.Driver.Session+import GHC.Driver.Backend import GHC.Utils.Error import GHC.Utils.Outputable@@ -784,7 +785,7 @@ finish summary tc_result mb_old_hash = do hsc_env <- getHscEnv let dflags = hsc_dflags hsc_env- target = hscTarget dflags+ bcknd = backend dflags hsc_src = ms_hsc_src summary -- Desugar, if appropriate@@ -802,7 +803,7 @@ -- interface file. case mb_desugar of -- Just cause we desugared doesn't mean we are generating code, see above.- Just desugared_guts | target /= HscNothing -> do+ Just desugared_guts | bcknd /= NoBackend -> do plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result) simplified_guts <- hscSimplify' plugins desugared_guts @@ -830,11 +831,12 @@ liftIO $ hscMaybeWriteIface dflags iface mb_old_iface_hash (ms_location summary) - return $ case (target, hsc_src) of- (HscNothing, _) -> HscNotGeneratingCode iface details- (_, HsBootFile) -> HscUpdateBoot iface details- (_, HsigFile) -> HscUpdateSig iface details- _ -> panic "finish"+ return $ case bcknd of+ NoBackend -> HscNotGeneratingCode iface details+ _ -> case hsc_src of+ HsBootFile -> HscUpdateBoot iface details+ HsigFile -> HscUpdateSig iface details+ _ -> panic "finish" {- Note [Writing interface files]@@ -853,10 +855,10 @@ hscMaybeWriteIface :: DynFlags -> ModIface -> Maybe Fingerprint -> ModLocation -> IO () hscMaybeWriteIface dflags iface old_iface location = do let force_write_interface = gopt Opt_WriteInterface dflags- write_interface = case hscTarget dflags of- HscNothing -> False- HscInterpreted -> False- _ -> True+ write_interface = case backend dflags of+ NoBackend -> False+ Interpreter -> False+ _ -> True no_change = old_iface == Just (mi_iface_hash (mi_final_exts iface)) when (write_interface || force_write_interface) $@@ -901,8 +903,7 @@ showMsg msg reason = compilationProgressMsg dflags $ (showModuleIndex mod_index ++- msg ++ showModMsg dflags (hscTarget dflags)- (recompileRequired recomp) mod_summary)+ msg ++ showModMsg dflags (recompileRequired recomp) mod_summary) ++ reason --------------------------------------------------------------@@ -1551,7 +1552,7 @@ let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds - dumpIfSet_dyn dflags Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings stg_binds_w_fvs)+ dumpIfSet_dyn dflags Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_fvs) let cmm_stream :: Stream IO CmmGroup ModuleLFInfos -- See Note [Forcing of stg_binds]
compiler/GHC/Driver/Make.hs view
@@ -40,6 +40,7 @@ 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@@ -274,7 +275,7 @@ -- -- This function implements the core of GHC's @--make@ mode. It preprocesses, -- compiles and loads the specified modules, avoiding re-compilation wherever--- possible. Depending on the target (see 'GHC.Driver.Session.hscTarget') compiling+-- possible. Depending on the backend (see 'DynFlags.backend' field) compiling -- and loading may result in files being created on disk. -- -- Calls the 'defaultWarnErrLogger' after each compiling each module, whether@@ -952,6 +953,12 @@ , gwib_isBoot = isBootSummary ms } +mkHomeBuildModule :: ModSummary -> ModuleNameWithIsBoot+mkHomeBuildModule ms = GWIB+ { gwib_mod = moduleName $ ms_mod ms+ , gwib_isBoot = isBootSummary ms+ }+ -- | The entry point to the parallel upsweep. -- -- See also the simpler, sequential 'upsweep'.@@ -1390,20 +1397,20 @@ keep_going this_mods old_hpt done mods mod_index nmods uids_to_check done_holes = do let sum_deps ms (AcyclicSCC mod) =- if any (flip elem . map (unLoc . snd) $ ms_imps mod) ms- then ms_mod_name mod:ms+ if any (flip elem $ unfilteredEdges False mod) ms+ then mkHomeBuildModule mod:ms else ms sum_deps ms _ = ms dep_closure = foldl' sum_deps this_mods mods dropped_ms = drop (length this_mods) (reverse dep_closure)- prunable (AcyclicSCC mod) = elem (ms_mod_name mod) dep_closure+ prunable (AcyclicSCC mod) = elem (mkHomeBuildModule mod) dep_closure prunable _ = False mods' = filter (not . prunable) mods nmods' = nmods - length dropped_ms when (not $ null dropped_ms) $ do dflags <- getSessionDynFlags- liftIO $ fatalErrorMsg dflags (keepGoingPruneErr dropped_ms)+ liftIO $ fatalErrorMsg dflags (keepGoingPruneErr $ gwib_mod <$> dropped_ms) (_, done') <- upsweep' old_hpt done mods' (mod_index+1) nmods' uids_to_check done_holes return (Failed, done') @@ -1428,7 +1435,7 @@ = do dflags <- getSessionDynFlags liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms) if gopt Opt_KeepGoing dflags- then keep_going (map ms_mod_name ms) old_hpt done mods mod_index nmods+ then keep_going (mkHomeBuildModule <$> ms) old_hpt done mods mod_index nmods uids_to_check done_holes else return (Failed, done) @@ -1482,7 +1489,7 @@ Nothing -> do dflags <- getSessionDynFlags if gopt Opt_KeepGoing dflags- then keep_going [ms_mod_name mod] old_hpt done mods mod_index nmods+ then keep_going [mkHomeBuildModule mod] old_hpt done mods mod_index nmods uids_to_check done_holes else return (Failed, done) Just mod_info -> do@@ -1516,7 +1523,7 @@ -- Add any necessary entries to the static pointer -- table. See Note [Grand plan for static forms] in -- GHC.Iface.Tidy.StaticPtrTable.- when (hscTarget (hsc_dflags hsc_env4) == HscInterpreted) $+ when (backend (hsc_dflags hsc_env4) == Interpreter) $ liftIO $ hscAddSptEntries hsc_env4 [ spt | Just linkable <- pure $ hm_linkable mod_info@@ -1575,24 +1582,25 @@ -- We're using the dflags for this module now, obtained by -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas. dflags = ms_hspp_opts summary- prevailing_target = hscTarget (hsc_dflags hsc_env)- local_target = hscTarget dflags+ prevailing_backend = backend (hsc_dflags hsc_env)+ local_backend = backend dflags -- If OPTIONS_GHC contains -fasm or -fllvm, be careful that -- we don't do anything dodgy: these should only work to change -- from -fllvm to -fasm and vice-versa, or away from -fno-code, -- otherwise we could end up trying to link object code to byte -- code.- target = if prevailing_target /= local_target- && (not (isObjectTarget prevailing_target)- || not (isObjectTarget local_target))- && not (prevailing_target == HscNothing)- && not (prevailing_target == HscInterpreted)- then prevailing_target- else local_target+ bcknd = case (prevailing_backend,local_backend) of+ (LLVM,NCG) -> NCG+ (NCG,LLVM) -> LLVM+ (NoBackend,b)+ | backendProducesObject b -> b+ (Interpreter,b)+ | backendProducesObject b -> b+ _ -> prevailing_backend - -- store the corrected hscTarget into the summary- summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } }+ -- store the corrected backend into the summary+ summary' = summary{ ms_hspp_opts = dflags { backend = bcknd } } -- The old interface is ok if -- a) we're compiling a source file, and the old HPT@@ -1623,9 +1631,9 @@ compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods Nothing mb_linkable src_modified - -- With the HscNothing target we create empty linkables to avoid- -- recompilation. We have to detect these to recompile anyway if- -- the target changed since the last compile.+ -- With NoBackend we create empty linkables to avoid recompilation.+ -- We have to detect these to recompile anyway if the backend changed+ -- since the last compile. is_fake_linkable | Just hmi <- old_hmi, Just l <- hm_linkable hmi = null (linkableUnlinked l)@@ -1658,8 +1666,8 @@ -- object is stable, but we need to load the interface -- off disk to make a HMI. - | not (isObjectTarget target), is_stable_bco,- (target /= HscNothing) `implies` not is_fake_linkable ->+ | not (backendProducesObject bcknd), is_stable_bco,+ (bcknd /= NoBackend) `implies` not is_fake_linkable -> ASSERT(isJust old_hmi) -- must be in the old_hpt let Just hmi = old_hmi in do liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5@@ -1667,11 +1675,11 @@ return hmi -- BCO is stable: nothing to do - | not (isObjectTarget target),+ | not (backendProducesObject bcknd), Just hmi <- old_hmi, Just l <- hm_linkable hmi, not (isObjectLinkable l),- (target /= HscNothing) `implies` not is_fake_linkable,+ (bcknd /= NoBackend) `implies` not is_fake_linkable, linkableTime l >= ms_hs_date summary -> do liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 (text "compiling non-stable BCO mod:" <+> ppr this_mod_name)@@ -1688,7 +1696,7 @@ -- separately and generated a new interface, that we must -- read from the disk. --- | isObjectTarget target,+ | backendProducesObject bcknd, Just obj_date <- mb_obj_date, obj_date >= hs_date -> do case old_hmi of@@ -1728,7 +1736,7 @@ When GHC is invoked with -fno-code no object files or linked output will be generated. As many errors and warnings as possible will be generated, as if -fno-code had not been passed. The session DynFlags will have-hscTarget == HscNothing.+backend == NoBackend. -fwrite-interface ~~~~~~~~~~~~~~~~@@ -1917,7 +1925,7 @@ = [ node_payload node | node <- reachableG (transposeG graph) root ] where -- the rest just sets up the graph: (graph, lookup_node) = moduleGraphNodes False summaries- root = expectJust "reachableBackwards" (lookup_node IsBoot mod)+ root = expectJust "reachableBackwards" (lookup_node $ GWIB mod IsBoot) -- --------------------------------------------------------------------------- --@@ -1960,7 +1968,7 @@ -- the specified module. We do this by building a graph with -- the full set of nodes, and determining the reachable set from -- the specified node.- let root | Just node <- lookup_node NotBoot root_mod+ let root | Just node <- lookup_node $ GWIB root_mod NotBoot , graph `hasVertexG` node = node | otherwise@@ -1975,60 +1983,55 @@ summaryNodeSummary :: SummaryNode -> ModSummary summaryNodeSummary = node_payload +-- | Collect the immediate dependencies of a module from its ModSummary,+-- optionally avoiding hs-boot dependencies.+-- If the drop_hs_boot_nodes flag is False, and if this is a .hs and there is+-- an equivalent .hs-boot, add a link from the former to the latter. This+-- has the effect of detecting bogus cases where the .hs-boot depends on the+-- .hs, by introducing a cycle. Additionally, it ensures that we will always+-- process the .hs-boot before the .hs, and so the HomePackageTable will always+-- have the most up to date information.+unfilteredEdges :: Bool -> ModSummary -> [ModuleNameWithIsBoot]+unfilteredEdges drop_hs_boot_nodes ms =+ (flip GWIB hs_boot_key . unLoc <$> ms_home_srcimps ms) +++ (flip GWIB NotBoot . unLoc <$> ms_home_imps ms) +++ [ GWIB (ms_mod_name ms) IsBoot+ | not $ drop_hs_boot_nodes || ms_hsc_src ms == HsBootFile+ ]+ where+ -- Drop hs-boot nodes by using HsSrcFile as the key+ hs_boot_key | drop_hs_boot_nodes = NotBoot -- is regular mod or signature+ | otherwise = IsBoot+ moduleGraphNodes :: Bool -> [ModSummary]- -> (Graph SummaryNode, IsBootInterface -> ModuleName -> Maybe SummaryNode)+ -> (Graph SummaryNode, ModuleNameWithIsBoot -> Maybe SummaryNode) moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVerticesUniq nodes, lookup_node) where numbered_summaries = zip summaries [1..] - lookup_node :: IsBootInterface -> ModuleName -> Maybe SummaryNode- lookup_node hs_src mod = Map.lookup- (GWIB { gwib_mod = mod, gwib_isBoot = hs_src })- node_map+ lookup_node :: ModuleNameWithIsBoot -> Maybe SummaryNode+ lookup_node mnwib = Map.lookup mnwib node_map - lookup_key :: IsBootInterface -> ModuleName -> Maybe Int- lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)+ lookup_key :: ModuleNameWithIsBoot -> Maybe Int+ lookup_key = fmap summaryNodeKey . lookup_node node_map :: NodeMap SummaryNode- node_map = Map.fromList [ ( GWIB- { gwib_mod = moduleName $ ms_mod s- , gwib_isBoot = hscSourceToIsBoot $ ms_hsc_src s- }- , node- )+ node_map = Map.fromList [ (mkHomeBuildModule s, node) | node <- nodes- , let s = summaryNodeSummary node ]+ , let s = summaryNodeSummary node+ ] -- We use integers as the keys for the SCC algorithm nodes :: [SummaryNode]- nodes = [ DigraphNode s key out_keys+ nodes = [ DigraphNode s key $ out_edge_keys $ unfilteredEdges drop_hs_boot_nodes s | (s, key) <- numbered_summaries -- Drop the hi-boot ones if told to do so , not (isBootSummary s == IsBoot && drop_hs_boot_nodes)- , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++- out_edge_keys NotBoot (map unLoc (ms_home_imps s)) ++- (-- see [boot-edges] below- if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile- then []- else case lookup_key IsBoot (ms_mod_name s) of- Nothing -> []- Just k -> [k]) ]-- -- [boot-edges] if this is a .hs and there is an equivalent- -- .hs-boot, add a link from the former to the latter. This- -- has the effect of detecting bogus cases where the .hs-boot- -- depends on the .hs, by introducing a cycle. Additionally,- -- it ensures that we will always process the .hs-boot before- -- the .hs, and so the HomePackageTable will always have the- -- most up to date information.-- -- Drop hs-boot nodes by using HsSrcFile as the key- hs_boot_key | drop_hs_boot_nodes = NotBoot -- is regular mod or signature- | otherwise = IsBoot+ ] - out_edge_keys :: IsBootInterface -> [ModuleName] -> [Int]- out_edge_keys hi_boot ms = mapMaybe (lookup_key hi_boot) ms+ out_edge_keys :: [ModuleNameWithIsBoot] -> [Int]+ out_edge_keys = mapMaybe lookup_key -- If we want keep_hi_boot_nodes, then we do lookup_key with -- IsBoot; else False @@ -2109,15 +2112,11 @@ -- for dependencies of modules that have -XTemplateHaskell, -- otherwise those modules will fail to compile. -- See Note [-fno-code mode] #8025- map1 <- if hscTarget dflags == HscNothing- then enableCodeGenForTH- (defaultObjectTarget dflags)- map0- else if hscTarget dflags == HscInterpreted- then enableCodeGenForUnboxedTuplesOrSums- (defaultObjectTarget dflags)- map0- else return map0+ let default_backend = platformDefaultBackend (targetPlatform dflags)+ map1 <- case backend dflags of+ NoBackend -> enableCodeGenForTH default_backend map0+ Interpreter -> enableCodeGenForUnboxedTuplesOrSums default_backend map0+ _ -> return map0 if null errs then pure $ concat $ nodeMapElts map1 else pure $ map Left errs@@ -2200,7 +2199,7 @@ -- the specified target, disable optimization and change the .hi -- and .o file locations to be temporary files. -- See Note [-fno-code mode]-enableCodeGenForTH :: HscTarget+enableCodeGenForTH :: Backend -> NodeMap [Either ErrorMessages ModSummary] -> IO (NodeMap [Either ErrorMessages ModSummary]) enableCodeGenForTH =@@ -2208,7 +2207,7 @@ where condition = isTemplateHaskellOrQQNonBoot should_modify (ModSummary { ms_hspp_opts = dflags }) =- hscTarget dflags == HscNothing &&+ backend dflags == NoBackend && -- Don't enable codegen for TH on indefinite packages; we -- can't compile anything anyway! See #16219. homeUnitIsDefinite dflags@@ -2220,7 +2219,7 @@ -- -- This is used in order to load code that uses unboxed tuples -- or sums into GHCi while still allowing some code to be interpreted.-enableCodeGenForUnboxedTuplesOrSums :: HscTarget+enableCodeGenForUnboxedTuplesOrSums :: Backend -> NodeMap [Either ErrorMessages ModSummary] -> IO (NodeMap [Either ErrorMessages ModSummary]) enableCodeGenForUnboxedTuplesOrSums =@@ -2233,7 +2232,7 @@ unboxed_tuples_or_sums d = xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d should_modify (ModSummary { ms_hspp_opts = dflags }) =- hscTarget dflags == HscInterpreted+ backend dflags == Interpreter -- | Helper used to implement 'enableCodeGenForTH' and -- 'enableCodeGenForUnboxedTuples'. In particular, this enables@@ -2246,10 +2245,10 @@ -> (ModSummary -> Bool) -> TempFileLifetime -> TempFileLifetime- -> HscTarget+ -> Backend -> NodeMap [Either ErrorMessages ModSummary] -> IO (NodeMap [Either ErrorMessages ModSummary])-enableCodeGenWhen condition should_modify staticLife dynLife target nodemap =+enableCodeGenWhen condition should_modify staticLife dynLife bcknd nodemap = traverse (traverse (traverse enable_code_gen)) nodemap where enable_code_gen ms@@ -2282,7 +2281,7 @@ ms { ms_location = ms_location {ml_hi_file = hi_file, ml_obj_file = o_file}- , ms_hspp_opts = updOptLevel 0 $ dflags {hscTarget = target}+ , ms_hspp_opts = updOptLevel 0 $ dflags {backend = bcknd} } | otherwise = return ms @@ -2433,7 +2432,7 @@ not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do -- update the object-file timestamp obj_timestamp <-- if isObjectTarget (hscTarget (hsc_dflags hsc_env))+ if backendProducesObject (backend (hsc_dflags hsc_env)) || obj_allowed -- bug #1205 then liftIO $ getObjTimestamp location is_boot else return Nothing@@ -2609,7 +2608,7 @@ -- when the user asks to load a source file by name, we only -- use an object file if -fobject-code is on. See #1205. obj_timestamp <- liftIO $- if isObjectTarget (hscTarget dflags)+ if backendProducesObject (backend dflags) || nms_obj_allowed -- bug #1205 then getObjTimestamp nms_location nms_is_boot else return Nothing
compiler/GHC/Driver/Pipeline.hs view
@@ -41,7 +41,8 @@ import GHC.Driver.Pipeline.Monad import GHC.Unit.State-import GHC.Driver.Ways+import GHC.Platform.Ways+import GHC.Platform.ArchOS import GHC.Parser.Header import GHC.Driver.Phases import GHC.SysTools@@ -53,6 +54,7 @@ import GHC.Unit.Module import GHC.Utils.Error import GHC.Driver.Session+import GHC.Driver.Backend import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Data.StringBuffer ( hGetStringBuffer, hPutStringBuffer )@@ -183,25 +185,25 @@ -- hscIncrementalCompile) let hsc_env' = hsc_env{ hsc_dflags = plugin_dflags } - case (status, hsc_lang) of+ case (status, bcknd) of (HscUpToDate iface hmi_details, _) -> -- TODO recomp014 triggers this assert. What's going on?! -- ASSERT( isJust mb_old_linkable || isNoLink (ghcLink dflags) ) return $! HomeModInfo iface hmi_details mb_old_linkable- (HscNotGeneratingCode iface hmi_details, HscNothing) ->+ (HscNotGeneratingCode iface hmi_details, NoBackend) -> let mb_linkable = if isHsBootOrSig src_flavour then Nothing -- TODO: Questionable. else Just (LM (ms_hs_date summary) this_mod []) in return $! HomeModInfo iface hmi_details mb_linkable (HscNotGeneratingCode _ _, _) -> panic "compileOne HscNotGeneratingCode"- (_, HscNothing) -> panic "compileOne HscNothing"- (HscUpdateBoot iface hmi_details, HscInterpreted) -> do+ (_, NoBackend) -> panic "compileOne NoBackend"+ (HscUpdateBoot iface hmi_details, Interpreter) -> do return $! HomeModInfo iface hmi_details Nothing (HscUpdateBoot iface hmi_details, _) -> do touchObjectFile dflags object_filename return $! HomeModInfo iface hmi_details Nothing- (HscUpdateSig iface hmi_details, HscInterpreted) -> do+ (HscUpdateSig iface hmi_details, Interpreter) -> do let !linkable = LM (ms_hs_date summary) this_mod [] return $! HomeModInfo iface hmi_details (Just linkable) (HscUpdateSig iface hmi_details, _) -> do@@ -229,7 +231,7 @@ hscs_mod_details = hmi_details, hscs_partial_iface = partial_iface, hscs_old_iface_hash = mb_old_iface_hash,- hscs_iface_dflags = iface_dflags }, HscInterpreted) -> do+ hscs_iface_dflags = iface_dflags }, Interpreter) -> do -- In interpreted mode the regular codeGen backend is not run so we -- generate a interface without codeGen info. final_iface <- mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface Nothing@@ -285,7 +287,7 @@ src_flavour = ms_hsc_src summary mod_name = ms_mod_name summary- next_phase = hscPostBackendPhase src_flavour hsc_lang+ next_phase = hscPostBackendPhase src_flavour bcknd object_filename = ml_obj_file location -- #8180 - when using TemplateHaskell, switch on -dynamic-too so@@ -320,8 +322,8 @@ -- to re-summarize all the source files. hsc_env = hsc_env0 {hsc_dflags = dflags} - -- Figure out what lang we're generating- hsc_lang = hscTarget dflags+ -- Figure out which backend we're using+ bcknd = backend dflags -- -fforce-recomp should also work with --make force_recomp = gopt Opt_ForceRecomp dflags@@ -329,8 +331,8 @@ | force_recomp = SourceModified | otherwise = source_modified0 - always_do_basic_recompilation_check = case hsc_lang of- HscInterpreted -> True+ always_do_basic_recompilation_check = case bcknd of+ Interpreter -> True _ -> False -----------------------------------------------------------------------------@@ -562,7 +564,7 @@ -- If we are doing -fno-code, then act as if the output is -- 'Temporary'. This stops GHC trying to copy files to their -- final location.- | HscNothing <- hscTarget dflags = Temporary TFL_CurrentModule+ | NoBackend <- backend dflags = Temporary TFL_CurrentModule | StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent -- -o foo applies to linker | isJust mb_o_file = SpecificFile@@ -893,16 +895,18 @@ | WayDyn `elem` ways dflags = "dynamic-no-pic" | otherwise = "static" + platform = targetPlatform dflags+ align :: Int- align = case platformArch (targetPlatform dflags) of+ align = case platformArch platform of ArchX86_64 | isAvxEnabled dflags -> 32 _ -> 0 attrs :: String attrs = intercalate "," $ mattr ++ ["+sse42" | isSse4_2Enabled dflags ]- ++ ["+sse2" | isSse2Enabled dflags ]- ++ ["+sse" | isSseEnabled dflags ]+ ++ ["+sse2" | isSse2Enabled platform ]+ ++ ["+sse" | isSseEnabled platform ] ++ ["+avx512f" | isAvx512fEnabled dflags ] ++ ["+avx2" | isAvx2Enabled dflags ] ++ ["+avx" | isAvxEnabled dflags ]@@ -1144,8 +1148,7 @@ setModLocation location let o_file = ml_obj_file location -- The real object file- hsc_lang = hscTarget dflags- next_phase = hscPostBackendPhase src_flavour hsc_lang+ next_phase = hscPostBackendPhase src_flavour (backend dflags) case result of HscNotGeneratingCode _ _ ->@@ -1209,8 +1212,7 @@ return (RealPhase Cmm, output_fn) runPhase (RealPhase Cmm) input_fn dflags- = do let hsc_lang = hscTarget dflags- let next_phase = hscPostBackendPhase HsSrcFile hsc_lang+ = do let next_phase = hscPostBackendPhase HsSrcFile (backend dflags) output_fn <- phaseOutputFilename next_phase PipeState{hsc_env} <- getPipeState liftIO $ hscCompileCmmFile hsc_env input_fn output_fn@@ -1355,7 +1357,7 @@ = do -- LLVM from version 3.0 onwards doesn't support the OS X system -- assembler, so we use clang as the assembler instead. (#5636)- let as_prog | hscTarget dflags == HscLlvm &&+ let as_prog | backend dflags == LLVM && platformOS (targetPlatform dflags) == OSDarwin = GHC.SysTools.runClang | otherwise = GHC.SysTools.runAs@@ -1937,7 +1939,14 @@ output_exists <- doesFileExist full_output_fn (when output_exists) $ removeFile full_output_fn - pkg_cfgs <- getPreloadUnitsAnd dflags dep_units+ pkg_cfgs_init <- getPreloadUnitsAnd dflags dep_units++ let pkg_cfgs+ | gopt Opt_LinkRts dflags+ = pkg_cfgs_init+ | otherwise+ = filter ((/= rtsUnitId) . unitId) pkg_cfgs_init+ archives <- concatMapM (collectArchives dflags) pkg_cfgs ar <- foldl mappend@@ -1971,8 +1980,10 @@ let cpp_prog args | raw = GHC.SysTools.runCpp dflags args | otherwise = GHC.SysTools.runCc Nothing dflags (GHC.SysTools.Option "-E" : args) - let targetArch = stringEncodeArch $ platformArch $ targetPlatform dflags- targetOS = stringEncodeOS $ platformOS $ targetPlatform dflags+ let platform = targetPlatform dflags+ targetArch = stringEncodeArch $ platformArch platform+ targetOS = stringEncodeOS $ platformOS platform+ isWindows = platformOS platform == OSMinGW32 let target_defs = [ "-D" ++ HOST_OS ++ "_BUILD_OS", "-D" ++ HOST_ARCH ++ "_BUILD_ARCH",@@ -1981,9 +1992,13 @@ -- remember, in code we *compile*, the HOST is the same our TARGET, -- and BUILD is the same as our HOST. + let io_manager_defs =+ [ "-D__IO_MANAGER_WINIO__=1" | isWindows ] +++ [ "-D__IO_MANAGER_MIO__=1" ]+ let sse_defs =- [ "-D__SSE__" | isSseEnabled dflags ] ++- [ "-D__SSE2__" | isSse2Enabled dflags ] +++ [ "-D__SSE__" | isSseEnabled platform ] +++ [ "-D__SSE2__" | isSse2Enabled platform ] ++ [ "-D__SSE4_2__" | isSse4_2Enabled dflags ] let avx_defs =@@ -2026,6 +2041,7 @@ ++ map GHC.SysTools.Option hscpp_opts ++ map GHC.SysTools.Option sse_defs ++ map GHC.SysTools.Option avx_defs+ ++ map GHC.SysTools.Option io_manager_defs ++ mb_macro_include -- Set the language mode to assembler-with-cpp when preprocessing. This -- alleviates some of the C99 macro rules relating to whitespace and the hash@@ -2047,7 +2063,7 @@ ]) getBackendDefs :: DynFlags -> IO [String]-getBackendDefs dflags | hscTarget dflags == HscLlvm = do+getBackendDefs dflags | backend dflags == LLVM = do llvmVer <- figureLlvmVersion dflags return $ case fmap llvmVersionList llvmVer of Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ]@@ -2186,7 +2202,7 @@ writeInterfaceOnlyMode :: DynFlags -> Bool writeInterfaceOnlyMode dflags = gopt Opt_WriteInterface dflags &&- HscNothing == hscTarget dflags+ NoBackend == backend dflags -- | Figure out if a source file was modified after an output file (or if we -- anyways need to consider the source file modified since the output is gone).@@ -2201,16 +2217,16 @@ return (t2 <= src_timestamp) -- | What phase to run after one of the backend code generators has run-hscPostBackendPhase :: HscSource -> HscTarget -> Phase+hscPostBackendPhase :: HscSource -> Backend -> Phase hscPostBackendPhase HsBootFile _ = StopLn hscPostBackendPhase HsigFile _ = StopLn-hscPostBackendPhase _ hsc_lang =- case hsc_lang of- HscC -> HCc- HscAsm -> As False- HscLlvm -> LlvmOpt- HscNothing -> StopLn- HscInterpreted -> StopLn+hscPostBackendPhase _ bcknd =+ case bcknd of+ ViaC -> HCc+ NCG -> As False+ LLVM -> LlvmOpt+ NoBackend -> StopLn+ Interpreter -> StopLn touchObjectFile :: DynFlags -> FilePath -> IO () touchObjectFile dflags path = do
compiler/GHC/Hs/Stats.hs view
@@ -22,7 +22,7 @@ -- | Source Statistics ppSourceStats :: Bool -> Located HsModule -> SDoc-ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))+ppSourceStats short (L _ (HsModule{ hsmodExports = exports, hsmodImports = imports, hsmodDecls = ldecls })) = (if short then hcat else vcat) (map pp_val [("ExportAll ", export_all), -- 1 if no export list
compiler/GHC/HsToCore.hs view
@@ -23,6 +23,7 @@ import GHC.HsToCore.Usage import GHC.Driver.Session import GHC.Driver.Types+import GHC.Driver.Backend import GHC.Hs import GHC.Tc.Types import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances )@@ -123,7 +124,7 @@ (const ()) $ do { -- Desugar the program ; let export_set = availsToNameSet exports- target = hscTarget dflags+ bcknd = backend dflags hpcInfo = emptyHpcInfo other_hpc_info ; (binds_cvr, ds_hpc_info, modBreaks)@@ -139,7 +140,7 @@ ; (ds_fords, foreign_prs) <- dsForeigns fords ; ds_rules <- mapMaybeM dsRule rules ; let hpc_init- | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info+ | gopt Opt_Hpc dflags = hpcInitCode (hsc_dflags hsc_env) mod ds_hpc_info | otherwise = empty ; return ( ds_ev_binds , foreign_prs `appOL` core_prs `appOL` spec_prs@@ -153,7 +154,7 @@ do { -- Add export flags to bindings keep_alive <- readIORef keep_var ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules- final_prs = addExportFlagsAndRules target export_set keep_alive+ final_prs = addExportFlagsAndRules bcknd export_set keep_alive rules_for_locals (fromOL all_prs) final_pgm = combineEvBinds ds_ev_binds final_prs@@ -288,9 +289,9 @@ -} addExportFlagsAndRules- :: HscTarget -> NameSet -> NameSet -> [CoreRule]+ :: Backend -> NameSet -> NameSet -> [CoreRule] -> [(Id, t)] -> [(Id, t)]-addExportFlagsAndRules target exports keep_alive rules prs+addExportFlagsAndRules bcknd exports keep_alive rules prs = mapFst add_one prs where add_one bndr = add_rules name (add_export name bndr)@@ -326,7 +327,7 @@ -- isExternalName separates the user-defined top-level names from those -- introduced by the type checker. is_exported :: Name -> Bool- is_exported | targetRetainsAllBindings target = isExternalName+ is_exported | backendRetainsAllBindings bcknd = isExternalName | otherwise = (`elemNameSet` exports) {-
compiler/GHC/HsToCore/Binds.hs view
@@ -1141,6 +1141,7 @@ return $ \e -> mkCastDs e co dsHsWrapper (WpEvApp tm) = do { core_tm <- dsEvTerm tm ; return (\e -> App e core_tm) }+ -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. dsHsWrapper (WpMultCoercion co) = do { when (not (isReflexiveCo co)) $ errDs (text "Multiplicity coercions are currently not supported") ; return $ \e -> e }
compiler/GHC/HsToCore/Coverage.hs view
@@ -24,6 +24,7 @@ import GHC.Unit import GHC.Utils.Outputable as Outputable import GHC.Driver.Session+import GHC.Driver.Backend import GHC.Core.ConLike import Control.Monad import GHC.Types.SrcLoc@@ -552,8 +553,8 @@ (addTickLHsExpr e) -- not an EvalInner; e might not necessarily -- be evaluated. (addTickMatchGroup False mgs)-addTickHsExpr (HsIf x cnd e1 e2 e3) =- liftM3 (HsIf x cnd)+addTickHsExpr (HsIf x e1 e2 e3) =+ liftM3 (HsIf x) (addBinTickLHsExpr (BinBox CondBinBox) e1) (addTickLHsExprOptAlt True e2) (addTickLHsExprOptAlt True e3)@@ -629,10 +630,12 @@ liftM2 (HsProc x) (addTickLPat pat) (liftL (addTickHsCmdTop) cmdtop)-addTickHsExpr (XExpr (HsWrap w e)) =- liftM XExpr $- liftM (HsWrap w)+addTickHsExpr (XExpr (WrapExpr (HsWrap w e))) =+ liftM (XExpr . WrapExpr . HsWrap w) $ (addTickHsExpr e) -- Explicitly no tick on inside+addTickHsExpr (XExpr (ExpansionExpr (HsExpanded a b))) =+ liftM (XExpr . ExpansionExpr . HsExpanded a) $+ (addTickHsExpr b) -- Others should never happen in expression content. addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e)@@ -1048,7 +1051,7 @@ -- | Should we produce 'Breakpoint' ticks? breakpointsEnabled :: DynFlags -> Bool-breakpointsEnabled dflags = hscTarget dflags == HscInterpreted+breakpointsEnabled dflags = backend dflags == Interpreter -- | Tickishs that only make sense when their source code location -- refers to the current file. This might not always be true due to@@ -1312,9 +1315,9 @@ hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);} -} -hpcInitCode :: Module -> HpcInfo -> SDoc-hpcInitCode _ (NoHpcInfo {}) = Outputable.empty-hpcInitCode this_mod (HpcInfo tickCount hashNo)+hpcInitCode :: DynFlags -> Module -> HpcInfo -> SDoc+hpcInitCode _ _ (NoHpcInfo {}) = Outputable.empty+hpcInitCode dflags this_mod (HpcInfo tickCount hashNo) = vcat [ text "static void hpc_init_" <> ppr this_mod <> text "(void) __attribute__((constructor));"@@ -1332,7 +1335,9 @@ ]) ] where- tickboxes = ppr (mkHpcTicksLabel $ this_mod)+ platform = targetPlatform dflags+ bcknd = backend dflags+ tickboxes = pprCLabel bcknd platform (mkHpcTicksLabel $ this_mod) module_name = hcat (map (text.charToC) $ BS.unpack $ bytesFS (moduleNameFS (moduleName this_mod)))
compiler/GHC/HsToCore/Docs.hs view
@@ -1,5 +1,8 @@ -- | Extract docs from the renamer output so they can be serialized. {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-}@@ -112,9 +115,7 @@ (associated with InstDecls and DerivDecls). -} -getMainDeclBinder :: (CollectPass (GhcPass p))- => HsDecl (GhcPass p)- -> [IdP (GhcPass p)]+getMainDeclBinder :: CollectPass (GhcPass p) => HsDecl (GhcPass p) -> [IdP (GhcPass p)] getMainDeclBinder (TyClD _ d) = [tcdName d] getMainDeclBinder (ValD _ d) = case collectHsBindBinders d of@@ -125,13 +126,14 @@ getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = [] getMainDeclBinder _ = [] -sigNameNoLoc :: Sig pass -> [IdP pass]-sigNameNoLoc (TypeSig _ ns _) = map unLoc ns-sigNameNoLoc (ClassOpSig _ _ ns _) = map unLoc ns-sigNameNoLoc (PatSynSig _ ns _) = map unLoc ns-sigNameNoLoc (SpecSig _ n _ _) = [unLoc n]-sigNameNoLoc (InlineSig _ n _) = [unLoc n]-sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns++sigNameNoLoc :: forall pass. UnXRec pass => Sig pass -> [IdP pass]+sigNameNoLoc (TypeSig _ ns _) = map (unXRec @pass) ns+sigNameNoLoc (ClassOpSig _ _ ns _) = map (unXRec @pass) ns+sigNameNoLoc (PatSynSig _ ns _) = map (unXRec @pass) ns+sigNameNoLoc (SpecSig _ n _ _) = [unXRec @pass n]+sigNameNoLoc (InlineSig _ n _) = [unXRec @pass n]+sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map (unXRec @pass) ns sigNameNoLoc _ = [] -- Extract the source location where an instance is defined. This is used@@ -302,14 +304,14 @@ -- | Collect docs and attach them to the right declarations. -- -- A declaration may have multiple doc strings attached to it.-collectDocs :: [LHsDecl pass] -> [(LHsDecl pass, [HsDocString])]+collectDocs :: forall p. UnXRec p => [LHsDecl p] -> [(LHsDecl p, [HsDocString])] -- ^ This is an example. collectDocs = go [] Nothing where go docs mprev decls = case (decls, mprev) of- ((unLoc->DocD _ (DocCommentNext s)) : ds, Nothing) -> go (s:docs) Nothing ds- ((unLoc->DocD _ (DocCommentNext s)) : ds, Just prev) -> finished prev docs $ go [s] Nothing ds- ((unLoc->DocD _ (DocCommentPrev s)) : ds, mprev) -> go (s:docs) mprev ds+ ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Nothing) -> go (s:docs) Nothing ds+ ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Just prev) -> finished prev docs $ go [s] Nothing ds+ ((unXRec @p -> DocD _ (DocCommentPrev s)) : ds, mprev) -> go (s:docs) mprev ds (d : ds, Nothing) -> go docs (Just d) ds (d : ds, Just prev) -> finished prev docs $ go [] (Just d) ds ([] , Nothing) -> []@@ -318,8 +320,8 @@ finished decl docs rest = (decl, reverse docs) : rest -- | Filter out declarations that we don't handle in Haddock-filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]-filterDecls = filter (isHandled . unLoc . fst)+filterDecls :: forall p doc. UnXRec p => [(LHsDecl p, doc)] -> [(LHsDecl p, doc)]+filterDecls = filter (isHandled . unXRec @p . fst) where isHandled (ForD _ (ForeignImport {})) = True isHandled (TyClD {}) = True@@ -333,12 +335,12 @@ -- | Go through all class declarations and filter their sub-declarations-filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]-filterClasses = map (first (mapLoc filterClass))+filterClasses :: forall p doc. (UnXRec p, MapXRec p) => [(LHsDecl p, doc)] -> [(LHsDecl p, doc)]+filterClasses = map (first (mapXRec @p filterClass)) where filterClass (TyClD x c@(ClassDecl {})) = TyClD x $ c { tcdSigs =- filter (liftA2 (||) (isUserSig . unLoc) isMinimalLSig) (tcdSigs c) }+ filter (liftA2 (||) (isUserSig . unXRec @p) isMinimalLSig) (tcdSigs c) } filterClass d = d -- | Was this signature given by the user?
compiler/GHC/HsToCore/Expr.hs view
@@ -102,6 +102,7 @@ -- dependency order; hence Rec ; foldrM ds_ip_bind inner ip_binds } where+ ds_ip_bind :: LIPBind GhcTc -> CoreExpr -> DsM CoreExpr ds_ip_bind (L _ (IPBind _ ~(Right n) e)) body = do e' <- dsLExpr e return (Let (NonRec n e') body)@@ -276,12 +277,12 @@ dsExpr (HsOverLit _ lit) = do { warnAboutOverflowedOverLit lit ; dsOverLit lit }--dsExpr hswrap@(XExpr (HsWrap co_fn e))+dsExpr (XExpr (ExpansionExpr (HsExpanded _ b))) = dsExpr b+dsExpr hswrap@(XExpr (WrapExpr (HsWrap co_fn e))) = do { e' <- case e of HsVar _ (L _ var) -> return $ varToCoreExpr var HsConLikeOut _ (RealDataCon dc) -> return $ varToCoreExpr (dataConWrapId dc)- XExpr (HsWrap _ _) -> pprPanic "dsExpr: HsWrap inside HsWrap" (ppr hswrap)+ XExpr (WrapExpr (HsWrap _ _)) -> pprPanic "dsExpr: HsWrap inside HsWrap" (ppr hswrap) HsPar _ _ -> pprPanic "dsExpr: HsPar inside HsWrap" (ppr hswrap) _ -> addTyCsDs FromSource (hsWrapDictBinders co_fn) $ dsExpr e@@ -474,13 +475,11 @@ dsExpr (HsDo _ ctx@MDoExpr{} (L _ stmts)) = dsDo ctx stmts dsExpr (HsDo _ MonadComp (L _ stmts)) = dsMonadComp stmts -dsExpr (HsIf _ fun guard_expr then_expr else_expr)+dsExpr (HsIf _ guard_expr then_expr else_expr) = do { pred <- dsLExpr guard_expr ; b1 <- dsLExpr then_expr ; b2 <- dsLExpr else_expr- ; case fun of -- See Note [Rebindable if] in "GHC.Hs.Expr"- (SyntaxExprTc {}) -> dsSyntaxExpr fun [pred, b1, b2]- NoSyntaxExprTc -> return $ mkIfThenElse pred b1 b2 }+ ; return $ mkIfThenElse pred b1 b2 } dsExpr (HsMultiIf res_ty alts) | null alts@@ -822,8 +821,6 @@ Tick (ProfNote (mkUserCC nm mod_name (getLoc expr) flavour) count True) <$> dsLExpr expr else dsLExpr expr-ds_prag_expr (HsPragCore _ _ _) expr- = dsLExpr expr ds_prag_expr (HsPragTick _ _ _ _) expr = do dflags <- getDynFlags if gopt Opt_Hpc dflags
compiler/GHC/HsToCore/Match.hs view
@@ -1056,7 +1056,10 @@ exp e (HsPar _ (L _ e')) = exp e e' -- because the expressions do not necessarily have the same type, -- we have to compare the wrappers- exp (XExpr (HsWrap h e)) (XExpr (HsWrap h' e')) = wrap h h' && exp e e'+ exp (XExpr (WrapExpr (HsWrap h e))) (XExpr (WrapExpr (HsWrap h' e'))) =+ wrap h h' && exp e e'+ exp (XExpr (ExpansionExpr (HsExpanded _ b))) (XExpr (ExpansionExpr (HsExpanded _ b'))) =+ exp b b' exp (HsVar _ i) (HsVar _ i') = i == i' exp (HsConLikeOut _ c) (HsConLikeOut _ c') = c == c' -- the instance for IPName derives using the id, so this works if the@@ -1084,7 +1087,7 @@ exp (ExplicitTuple _ es1 _) (ExplicitTuple _ es2 _) = eq_list tup_arg es1 es2 exp (ExplicitSum _ _ _ e) (ExplicitSum _ _ _ e') = lexp e e'- exp (HsIf _ _ e e1 e2) (HsIf _ _ e' e1' e2') =+ exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') = lexp e e' && lexp e1 e1' && lexp e2 e2' -- Enhancement: could implement equality for more expressions
compiler/GHC/HsToCore/Match/Literal.hs view
@@ -261,18 +261,19 @@ warnAboutEmptyEnumerations :: FamInstEnvs -> DynFlags -> LHsExpr GhcTc -> Maybe (LHsExpr GhcTc) -> LHsExpr GhcTc -> DsM ()--- ^ Warns about @[2,3 .. 1]@ which returns the empty list.--- Only works for integral types, not floating point.+-- ^ Warns about @[2,3 .. 1]@ or @['b' .. 'a']@ which return the empty list.+-- For numeric literals, only works for integral types, not floating point. warnAboutEmptyEnumerations fam_envs dflags fromExpr mThnExpr toExpr- | wopt Opt_WarnEmptyEnumerations dflags- , Just from_ty@(from,_) <- getLHsIntegralLit fromExpr+ | not $ wopt Opt_WarnEmptyEnumerations dflags+ = return ()+ -- Numeric Literals+ | Just from_ty@(from,_) <- getLHsIntegralLit fromExpr , Just (_, tc) <- getNormalisedTyconName fam_envs from_ty , Just mThn <- traverse getLHsIntegralLit mThnExpr , Just (to,_) <- getLHsIntegralLit toExpr , let check :: forall a. (Enum a, Num a) => Proxy a -> DsM () check _proxy- = when (null enumeration) $- warnDs (Reason Opt_WarnEmptyEnumerations) (text "Enumeration is empty")+ = when (null enumeration) raiseWarning where enumeration :: [a] enumeration = case mThn of@@ -296,7 +297,18 @@ -- See the T10930b test case for an example of where this matters. else return () + -- Char literals (#18402)+ | Just fromChar <- getLHsCharLit fromExpr+ , Just mThnChar <- traverse getLHsCharLit mThnExpr+ , Just toChar <- getLHsCharLit toExpr+ , let enumeration = case mThnChar of+ Nothing -> [fromChar .. toChar]+ Just thnChar -> [fromChar, thnChar .. toChar]+ = when (null enumeration) raiseWarning+ | otherwise = return ()+ where+ raiseWarning = warnDs (Reason Opt_WarnEmptyEnumerations) (text "Enumeration is empty") getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Type) -- ^ See if the expression is an 'Integral' literal.@@ -324,6 +336,14 @@ getSimpleIntegralLit (HsWord64Prim _ i) = Just (i, word64PrimTy) getSimpleIntegralLit (HsInteger _ i ty) = Just (i, ty) getSimpleIntegralLit _ = Nothing++-- | Extract the Char if the expression is a Char literal.+getLHsCharLit :: LHsExpr GhcTc -> Maybe Char+getLHsCharLit (L _ (HsPar _ e)) = getLHsCharLit e+getLHsCharLit (L _ (HsTick _ _ e)) = getLHsCharLit e+getLHsCharLit (L _ (HsBinTick _ _ _ e)) = getLHsCharLit e+getLHsCharLit (L _ (HsLit _ (HsChar _ c))) = Just c+getLHsCharLit _ = Nothing -- | Convert a pair (Integer, Type) to (Integer, Name) after eventually -- normalising the type
compiler/GHC/HsToCore/Monad.hs view
@@ -86,7 +86,7 @@ import GHC.Driver.Session import GHC.Utils.Error import GHC.Data.FastString-import GHC.Types.Unique.FM ( lookupWithDefaultUFM )+import GHC.Types.Unique.FM ( lookupWithDefaultUFM_Directly ) import GHC.Types.Literal ( mkLitString ) import GHC.Types.CostCentre.State @@ -533,7 +533,10 @@ dsGetCompleteMatches tc = do eps <- getEps env <- getGblEnv- let lookup_completes ufm = lookupWithDefaultUFM ufm [] tc+ -- We index into a UniqFM from Name -> elt, for tyCon it holds that+ -- getUnique (tyConName tc) == getUnique tc. So we lookup using the+ -- unique directly instead.+ let lookup_completes ufm = lookupWithDefaultUFM_Directly ufm [] (getUnique tc) eps_matches_list = lookup_completes $ eps_complete_matches eps env_matches_list = lookup_completes $ ds_complete_matches env return $ eps_matches_list ++ env_matches_list
compiler/GHC/HsToCore/PmCheck/Oracle.hs view
@@ -781,7 +781,7 @@ -- Unfortunately we need the extra bit of polymorphism and the unfortunate -- duplication of lookupVarInfo here. lookupRefuts MkDelta{ delta_tm_st = ts@(TmSt (SDIE env) _) } k =- case lookupUDFM env k of+ case lookupUDFM_Directly env (getUnique k) of Nothing -> [] Just (Indirect y) -> pmAltConSetElems (vi_neg (lookupVarInfo ts y)) Just (Entry vi) -> pmAltConSetElems (vi_neg vi)
compiler/GHC/HsToCore/PmCheck/Ppr.hs view
@@ -98,7 +98,7 @@ -- | Extract and assigns pretty names to constraint variables with refutable -- shapes. prettifyRefuts :: Delta -> DIdEnv SDoc -> DIdEnv (SDoc, [PmAltCon])-prettifyRefuts delta = listToUDFM . map attach_refuts . udfmToList+prettifyRefuts delta = listToUDFM_Directly . map attach_refuts . udfmToList where attach_refuts (u, sdoc) = (u, (sdoc, lookupRefuts delta u))
compiler/GHC/HsToCore/Quote.hs view
@@ -1474,11 +1474,11 @@ ; ms2 <- mapM repMatchTup ms ; core_ms2 <- coreListM matchTyConName ms2 ; repCaseE arg core_ms2 }-repE (HsIf _ _ x y z) = do- a <- repLE x- b <- repLE y- c <- repLE z- repCond a b c+repE (HsIf _ x y z) = do+ a <- repLE x+ b <- repLE y+ c <- repLE z+ repCond a b c repE (HsMultiIf _ alts) = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts ; expr' <- repMultiIf (nonEmptyCoreList alts')@@ -1569,8 +1569,7 @@ occ <- occNameLit uv sname <- repNameS occ repUnboundVar sname--repE e@(HsPragE _ HsPragCore {} _) = notHandled "Core annotations" (ppr e)+repE (XExpr (HsExpanded _ b)) = repE b repE e@(HsPragE _ HsPragSCC {} _) = notHandled "Cost centres" (ppr e) repE e@(HsPragE _ HsPragTick {} _) = notHandled "Tick Pragma" (ppr e) repE e = notHandled "Expression form" (ppr e)
compiler/GHC/HsToCore/Usage.hs view
@@ -14,7 +14,7 @@ import GHC.Prelude import GHC.Driver.Session-import GHC.Driver.Ways+import GHC.Platform.Ways import GHC.Driver.Types import GHC.Tc.Types import GHC.Types.Name
compiler/GHC/HsToCore/Utils.hs view
@@ -67,7 +67,6 @@ import GHC.Core.PatSyn import GHC.Core.Type import GHC.Core.Coercion-import GHC.Builtin.Types.Prim import GHC.Builtin.Types import GHC.Types.Basic import GHC.Core.ConLike@@ -853,8 +852,8 @@ CoreExpr) -- Fail variable applied to realWorld# -- See Note [Failure thunks and CPR] mkFailurePair expr- = do { fail_fun_var <- newFailLocalDs Many (voidPrimTy `mkVisFunTyMany` ty)- ; fail_fun_arg <- newSysLocalDs Many voidPrimTy+ = do { fail_fun_var <- newFailLocalDs Many (unboxedUnitTy `mkVisFunTyMany` ty)+ ; fail_fun_arg <- newSysLocalDs Many unboxedUnitTy ; let real_arg = setOneShotLambda fail_fun_arg ; return (NonRec fail_fun_var (Lam real_arg expr), App (Var fail_fun_var) (Var voidPrimId)) }
compiler/GHC/Iface/Binary.hs view
@@ -17,7 +17,7 @@ getSymtabName, getDictFastString, CheckHiWay(..),- TraceBinIFaceReading(..),+ TraceBinIFace(..), getWithUserData, putWithUserData, @@ -43,13 +43,12 @@ import GHC.Unit import GHC.Types.Name import GHC.Driver.Session-import GHC.Driver.Ways+import GHC.Platform.Profile import GHC.Types.Unique.FM import GHC.Types.Unique.Supply import GHC.Utils.Panic import GHC.Utils.Binary as Binary import GHC.Types.SrcLoc-import GHC.Utils.Error import GHC.Data.FastMutInt import GHC.Types.Unique import GHC.Utils.Outputable@@ -59,7 +58,6 @@ import GHC.Settings.Constants import GHC.Utils.Misc -import Data.Set (Set) import Data.Array import Data.Array.ST import Data.Array.Unsafe@@ -80,39 +78,34 @@ data CheckHiWay = CheckHiWay | IgnoreHiWay deriving Eq -data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading- deriving Eq+data TraceBinIFace+ = TraceBinIFace (SDoc -> IO ())+ | QuietBinIFace -- | Read an interface file-readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath+readBinIface :: CheckHiWay -> TraceBinIFace -> FilePath -> TcRnIf a b ModIface readBinIface checkHiWay traceBinIFaceReading hi_path = do ncu <- mkNameCacheUpdater dflags <- getDynFlags- liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu+ let profile = targetProfile dflags+ liftIO $ readBinIface_ profile checkHiWay traceBinIFaceReading hi_path ncu -- | Read an interface file in 'IO'.-readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath+readBinIface_ :: Profile -> CheckHiWay -> TraceBinIFace -> FilePath -> NameCacheUpdater -> IO ModIface-readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do- let platform = targetPlatform dflags-- printer :: SDoc -> IO ()- printer = case traceBinIFaceReading of- TraceBinIFaceReading -> \sd ->- putLogMsg dflags- NoReason- SevOutput- noSrcSpan- $ withPprStyle defaultDumpStyle sd- QuietBinIFaceReading -> \_ -> return ()+readBinIface_ profile checkHiWay traceBinIFace hi_path ncu = do+ let platform = profilePlatform profile wantedGot :: String -> a -> a -> (a -> SDoc) -> IO () wantedGot what wanted got ppr' =- printer (text what <> text ": " <>+ case traceBinIFace of+ QuietBinIFace -> return ()+ TraceBinIFace printer -> printer $+ text what <> text ": " <> vcat [text "Wanted " <> ppr' wanted <> text ",",- text "got " <> ppr' got])+ text "got " <> ppr' got] errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO () errorOnMismatch what wanted got =@@ -131,17 +124,17 @@ errorOnMismatch "magic number mismatch: old/corrupt interface file?" (unFixedLength $ binaryInterfaceMagic platform) (unFixedLength magic) - -- Check the interface file version and ways.+ -- Check the interface file version and profile tag. check_ver <- get bh let our_ver = show hiVersion wantedGot "Version" our_ver check_ver text errorOnMismatch "mismatched interface file versions" our_ver check_ver - check_way <- get bh- let way_descr = getWayDescr platform (ways dflags)- wantedGot "Way" way_descr check_way ppr+ check_tag <- get bh+ let tag = profileBuildTag profile+ wantedGot "Way" tag check_tag ppr when (checkHiWay == CheckHiWay) $- errorOnMismatch "mismatched interface file ways" way_descr check_way+ errorOnMismatch "mismatched interface file profile tag" tag check_tag extFields_p <- get bh @@ -185,21 +178,21 @@ get bh -- | Write an interface file-writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()-writeBinIface dflags hi_path mod_iface = do+writeBinIface :: Profile -> TraceBinIFace -> FilePath -> ModIface -> IO ()+writeBinIface profile traceBinIface hi_path mod_iface = do bh <- openBinMem initBinMemSize- let platform = targetPlatform dflags+ let platform = profilePlatform profile put_ bh (binaryInterfaceMagic platform) - -- The version and way descriptor go next+ -- The version and profile tag go next put_ bh (show hiVersion)- let way_descr = getWayDescr platform (ways dflags)- put_ bh way_descr+ let tag = profileBuildTag profile+ put_ bh tag extFields_p_p <- tellBin bh put_ bh extFields_p_p - putWithUserData (debugTraceMsg dflags 3) bh mod_iface+ putWithUserData traceBinIface bh mod_iface extFields_p <- tellBin bh putAt bh extFields_p_p extFields_p@@ -213,8 +206,8 @@ -- is necessary if you want to serialise Names or FastStrings. -- It also writes a symbol table and the dictionary. -- This segment should be read using `getWithUserData`.-putWithUserData :: Binary a => (SDoc -> IO ()) -> BinHandle -> a -> IO ()-putWithUserData log_action bh payload = do+putWithUserData :: Binary a => TraceBinIFace -> BinHandle -> a -> IO ()+putWithUserData traceBinIface bh payload = do -- Remember where the dictionary pointer will go dict_p_p <- tellBin bh -- Placeholder for ptr to dictionary@@ -252,8 +245,11 @@ symtab_next <- readFastMutInt symtab_next symtab_map <- readIORef symtab_map putSymbolTable bh symtab_next symtab_map- log_action (text "writeBinIface:" <+> int symtab_next- <+> text "Names")+ case traceBinIface of+ QuietBinIFace -> return ()+ TraceBinIFace printer ->+ printer (text "writeBinIface:" <+> int symtab_next+ <+> text "Names") -- NB. write the dictionary after the symbol table, because -- writing the symbol table may create more dictionary entries.@@ -267,8 +263,11 @@ dict_next <- readFastMutInt dict_next_ref dict_map <- readIORef dict_map_ref putDictionary bh dict_next dict_map- log_action (text "writeBinIface:" <+> int dict_next- <+> text "dict entries")+ case traceBinIface of+ QuietBinIFace -> return ()+ TraceBinIFace printer ->+ printer (text "writeBinIface:" <+> int dict_next+ <+> text "dict entries") @@ -286,7 +285,7 @@ -- The symbol table -- -putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()+putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,Name) -> IO () putSymbolTable bh next_off symtab = do put_ bh next_off let names = elems (array (0,next_off-1) (nonDetEltsUFM symtab))@@ -327,7 +326,7 @@ new_cache = extendNameCache cache mod occ name in ( nc{ nsUniqs = us, nsNames = new_cache }, name ) -serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()+serialiseName :: BinHandle -> Name -> UniqFM key (Int,Name) -> IO () serialiseName bh name _ = do let mod = ASSERT2( isExternalName name, ppr name ) nameModule name put_ bh (moduleUnit mod, moduleName mod, nameOccName name)@@ -399,7 +398,7 @@ data BinSymbolTable = BinSymbolTable { bin_symtab_next :: !FastMutInt, -- The next index to use- bin_symtab_map :: !(IORef (UniqFM (Int,Name)))+ bin_symtab_map :: !(IORef (UniqFM Name (Int,Name))) -- indexed by Name } @@ -410,13 +409,13 @@ allocateFastString BinDictionary { bin_dict_next = j_r, bin_dict_map = out_r} f = do out <- readIORef out_r- let uniq = getUnique f- case lookupUFM out uniq of+ let !uniq = getUnique f+ case lookupUFM_Directly out uniq of Just (j, _) -> return (fromIntegral j :: Word32) Nothing -> do j <- readFastMutInt j_r writeFastMutInt j_r (j + 1)- writeIORef out_r $! addToUFM out uniq (j, f)+ writeIORef out_r $! addToUFM_Directly out uniq (j, f) return (fromIntegral j :: Word32) getDictFastString :: Dictionary -> BinHandle -> IO FastString@@ -426,14 +425,7 @@ data BinDictionary = BinDictionary { bin_dict_next :: !FastMutInt, -- The next index to use- bin_dict_map :: !(IORef (UniqFM (Int,FastString)))+ bin_dict_map :: !(IORef (UniqFM FastString (Int,FastString))) -- indexed by FastString } -getWayDescr :: Platform -> Set Way -> String-getWayDescr platform ws- | platformUnregisterised platform = 'u':tag- | otherwise = tag- where tag = waysBuildTag ws- -- if this is an unregisterised build, make sure our interfaces- -- can't be used by a registerised build.
compiler/GHC/Iface/Ext/Ast.hs view
@@ -390,9 +390,8 @@ getRealSpan (RealSrcSpan sp _) = Just sp getRealSpan _ = Nothing -grhss_span :: GRHSs p body -> SrcSpan+grhss_span :: GRHSs (GhcPass p) body -> SrcSpan grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs)-grhss_span (XGRHSs _) = panic "XGRHS has no span" bindingsOnly :: [Context Name] -> HieM [HieAST a] bindingsOnly [] = pure []@@ -488,8 +487,8 @@ tvScopes :: TyVarScope -> Scope- -> [LHsTyVarBndr flag a]- -> [TVScoped (LHsTyVarBndr flag a)]+ -> [LHsTyVarBndr flag (GhcPass a)]+ -> [TVScoped (LHsTyVarBndr flag (GhcPass a))] tvScopes tvScope rhsScope xs = map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs @@ -540,11 +539,11 @@ loc [] = noSrcSpan loc xs = foldl1' combineSrcSpans $ map loc xs -instance HasLoc a => HasLoc (FamEqn s a) where+instance HasLoc a => HasLoc (FamEqn (GhcPass s) a) where loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c] loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans [loc a, loc tvs, loc b, loc c]- loc _ = noSrcSpan+ instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where loc (HsValArg tm) = loc tm loc (HsTypeArg _ ty) = loc ty@@ -684,7 +683,7 @@ concatMapM (toHie . C EvidenceVarUse . L osp) $ evVarsOfTermList a _ -> pure [] -instance HiePass p => HasType (LHsBind (GhcPass p)) where+instance HiePass p => HasType (Located (HsBind (GhcPass p))) where getTypeNode (L spn bind) = case hiePass @p of HieRn -> makeNode bind spn@@ -713,7 +712,7 @@ -- expression's type is going to be expensive. -- -- See #16233-instance HiePass p => HasType (LHsExpr (GhcPass p)) where+instance HiePass p => HasType (Located (HsExpr (GhcPass p))) where getTypeNode e@(L spn e') = case hiePass @p of HieRn -> makeNode e' spn@@ -758,14 +757,14 @@ -- performance before marking more things as 'True'. skipDesugaring :: HsExpr GhcTc -> Bool skipDesugaring e = case e of- HsVar{} -> False- HsUnboundVar{} -> False- HsConLikeOut{} -> False- HsRecFld{} -> False- HsOverLabel{} -> False- HsIPVar{} -> False- XExpr (HsWrap{}) -> False- _ -> True+ HsVar{} -> False+ HsUnboundVar{} -> False+ HsConLikeOut{} -> False+ HsRecFld{} -> False+ HsOverLabel{} -> False+ HsIPVar{} -> False+ XExpr (WrapExpr {}) -> False+ _ -> True data HiePassEv p where HieRn :: HiePassEv 'Renamed@@ -800,7 +799,7 @@ instance HiePass 'Typechecked where hiePass = HieTc -instance HiePass p => ToHie (BindContext (LHsBind (GhcPass p))) where+instance HiePass p => ToHie (BindContext (Located (HsBind (GhcPass p)))) where toHie (BC context scope b@(L span bind)) = concatM $ getTypeNode b : case bind of FunBind{fun_id = name, fun_matches = matches, fun_ext = wrap} ->@@ -884,7 +883,7 @@ instance ( HiePass p , Data body , ToHie (Located body)- ) => ToHie (LMatch (GhcPass p) (Located body)) where+ ) => ToHie (Located (Match (GhcPass p) (Located body))) where toHie (L span m ) = concatM $ node : case m of Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } -> [ toHie mctx@@ -1006,7 +1005,6 @@ L spn $ HsRecField lbl (PS rsp scope fscope pat) pun scoped_fds = listScopes pscope fds - instance ToHie (TScoped (HsPatSigType GhcRn)) where toHie (TS sc (HsPS (HsPSRn wcs tvs) body@(L span _))) = concatM $ [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) (wcs++tvs)@@ -1027,7 +1025,7 @@ instance ( ToHie (Located body) , HiePass a , Data body- ) => ToHie (LGRHS (GhcPass a) (Located body)) where+ ) => ToHie (Located (GRHS (GhcPass a) (Located body))) where toHie (L span g) = concatM $ node : case g of GRHS _ guards body -> [ toHie $ listScopes (mkLScope body) guards@@ -1038,7 +1036,7 @@ HieRn -> makeNode g span HieTc -> makeNode g span -instance HiePass p => ToHie (LHsExpr (GhcPass p)) where+instance HiePass p => ToHie (Located (HsExpr (GhcPass p))) where toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of HsVar _ (L _ var) -> [ toHie $ C Use (L mspan var)@@ -1099,7 +1097,7 @@ [ toHie expr , toHie matches ]- HsIf _ _ a b c ->+ HsIf _ a b c -> [ toHie a , toHie b , toHie c@@ -1166,13 +1164,17 @@ ] XExpr x | GhcTc <- ghcPass @p- , HsWrap w a <- x+ , WrapExpr (HsWrap w a) <- x -> [ toHie $ L mspan a , toHie (L mspan w) ]+ | GhcTc <- ghcPass @p+ , ExpansionExpr (HsExpanded _ b) <- x+ -> [ toHie (L mspan b)+ ] | otherwise -> [] -instance HiePass p => ToHie (LHsTupArg (GhcPass p)) where+instance HiePass p => ToHie (Located (HsTupArg (GhcPass p))) where toHie (L span arg) = concatM $ makeNode arg span : case arg of Present _ expr -> [ toHie expr@@ -1182,7 +1184,7 @@ instance ( ToHie (Located body) , Data body , HiePass p- ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where+ ) => ToHie (RScoped (Located (Stmt (GhcPass p) (Located body)))) where toHie (RS scope (L span stmt)) = concatM $ node : case stmt of LastStmt _ body _ _ -> [ toHie body@@ -1218,7 +1220,7 @@ HieTc -> makeNode stmt span HieRn -> makeNode stmt span -instance HiePass p => ToHie (RScoped (LHsLocalBinds (GhcPass p))) where+instance HiePass p => ToHie (RScoped (Located (HsLocalBinds (GhcPass p)))) where toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of EmptyLocalBinds _ -> [] HsIPBinds _ ipbinds -> case ipbinds of@@ -1233,7 +1235,7 @@ valBinds ] -instance HiePass p => ToHie (RScoped (LIPBind (GhcPass p))) where+instance HiePass p => ToHie (RScoped (Located (IPBind (GhcPass p)))) where toHie (RS scope (L sp bind)) = concatM $ makeNode bind sp : case bind of IPBind _ (Left _) expr -> [toHie expr] IPBind _ (Right v) expr ->@@ -1273,13 +1275,13 @@ removeDefSrcSpan :: Name -> Name removeDefSrcSpan n = setNameLoc n noSrcSpan -instance ToHie (RFContext (LFieldOcc GhcRn)) where+instance ToHie (RFContext (Located (FieldOcc GhcRn))) where toHie (RFC c rhs (L nspan f)) = concatM $ case f of FieldOcc name _ -> [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name) ] -instance ToHie (RFContext (LFieldOcc GhcTc)) where+instance ToHie (RFContext (Located (FieldOcc GhcTc))) where toHie (RFC c rhs (L nspan f)) = concatM $ case f of FieldOcc var _ -> let var' = setVarName var (removeDefSrcSpan $ varName var)@@ -1320,13 +1322,13 @@ toHie (RecCon rec) = toHie rec toHie (InfixCon a b) = concatM [ toHie a, toHie b] -instance HiePass p => ToHie (LHsCmdTop (GhcPass p)) where+instance HiePass p => ToHie (Located (HsCmdTop (GhcPass p))) where toHie (L span top) = concatM $ makeNode top span : case top of HsCmdTop _ cmd -> [ toHie cmd ] -instance HiePass p => ToHie (LHsCmd (GhcPass p)) where+instance HiePass p => ToHie (Located (HsCmd (GhcPass p))) where toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of HsCmdArrApp _ a b _ _ -> [ toHie a@@ -1380,7 +1382,7 @@ , toHie instances ] -instance ToHie (LTyClDecl GhcRn) where+instance ToHie (Located (TyClDecl GhcRn)) where toHie (L span decl) = concatM $ makeNode decl span : case decl of FamDecl {tcdFam = fdecl} -> [ toHie (L span fdecl)@@ -1425,7 +1427,7 @@ rhs_scope = foldl1' combineScopes $ map mkScope [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps] -instance ToHie (LFamilyDecl GhcRn) where+instance ToHie (Located (FamilyDecl GhcRn)) where toHie (L span decl) = concatM $ makeNode decl span : case decl of FamilyDecl _ info name vars _ sig inj -> [ toHie $ C (Decl FamDec $ getRealSpan span) name@@ -1448,7 +1450,7 @@ go (L l ib) = TS (ResolvedScopes [mkScope l]) ib toHie _ = pure [] -instance ToHie (RScoped (LFamilyResultSig GhcRn)) where+instance ToHie (RScoped (Located (FamilyResultSig GhcRn))) where toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of NoSig _ -> []@@ -1482,7 +1484,7 @@ patsScope = mkScope (loc pats) rhsScope = mkScope (loc rhs) -instance ToHie (LInjectivityAnn GhcRn) where+instance ToHie (Located (InjectivityAnn GhcRn)) where toHie (L span ann) = concatM $ makeNode ann span : case ann of InjectivityAnn lhs rhs -> [ toHie $ C Use lhs@@ -1497,13 +1499,13 @@ , toHie derivs ] -instance ToHie (HsDeriving GhcRn) where+instance ToHie (Located [Located (HsDerivingClause GhcRn)]) where toHie (L span clauses) = concatM [ locOnly span , toHie clauses ] -instance ToHie (LHsDerivingClause GhcRn) where+instance ToHie (Located (HsDerivingClause GhcRn)) where toHie (L span cl) = concatM $ makeNode cl span : case cl of HsDerivingClause _ strat (L ispan tys) -> [ toHie strat@@ -1524,7 +1526,7 @@ instance ToHie a => ToHie (HsScaled GhcRn a) where toHie (HsScaled w t) = concatM [toHie (arrowToHsType w), toHie t] -instance ToHie (LConDecl GhcRn) where+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 } ->@@ -1553,14 +1555,14 @@ rhsScope = combineScopes ctxScope argsScope ctxScope = maybe NoScope mkLScope ctx argsScope = condecl_scope dets- where condecl_scope :: HsConDeclDetails p -> Scope+ 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 -instance ToHie (Located [LConDeclField GhcRn]) where+instance ToHie (Located [Located (ConDeclField GhcRn)]) where toHie (L span decls) = concatM $ [ locOnly span , toHie decls@@ -1584,7 +1586,7 @@ ] where span = loc a -instance ToHie (LStandaloneKindSig GhcRn) where+instance ToHie (Located (StandaloneKindSig GhcRn)) where toHie (L sp sig) = concatM [makeNode sig sp, toHie sig] instance ToHie (StandaloneKindSig GhcRn) where@@ -1594,7 +1596,7 @@ , toHie $ TS (ResolvedScopes []) typ ] -instance HiePass p => ToHie (SigContext (LSig (GhcPass p))) where+instance HiePass p => ToHie (SigContext (Located (Sig (GhcPass p)))) where toHie (SC (SI styp msp) (L sp sig)) = case hiePass @p of HieTc -> pure []@@ -1640,10 +1642,10 @@ , toHie $ fmap (C Use) typ ] -instance ToHie (LHsType GhcRn) where+instance ToHie (Located (HsType GhcRn)) where toHie x = toHie $ TS (ResolvedScopes []) x -instance ToHie (TScoped (LHsType GhcRn)) where+instance ToHie (TScoped (Located (HsType GhcRn))) where toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of HsForAllTy _ tele body -> let scope = mkScope $ getLoc body in@@ -1727,7 +1729,7 @@ toHie (HsTypeArg _ ty) = toHie ty toHie (HsArgPar sp) = locOnly sp -instance Data flag => ToHie (TVScoped (LHsTyVarBndr flag GhcRn)) where+instance Data flag => ToHie (TVScoped (Located (HsTyVarBndr flag GhcRn))) where toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of UserTyVar _ _ var -> [ toHie $ C (TyVarBind sc tsc) var@@ -1746,13 +1748,13 @@ varLoc = loc vars bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits -instance ToHie (LHsContext GhcRn) where+instance ToHie (Located [Located (HsType GhcRn)]) where toHie (L span tys) = concatM $ [ locOnly span , toHie tys ] -instance ToHie (LConDeclField GhcRn) where+instance ToHie (Located (ConDeclField GhcRn)) where toHie (L span field) = concatM $ makeNode field span : case field of ConDeclField _ fields typ _ -> [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields@@ -1775,7 +1777,7 @@ , toHie c ] -instance ToHie (LSpliceDecl GhcRn) where+instance ToHie (Located (SpliceDecl GhcRn)) where toHie (L span decl) = concatM $ makeNode decl span : case decl of SpliceDecl _ splice _ -> [ toHie splice@@ -1829,14 +1831,14 @@ GhcTc -> case x of HsSplicedT _ -> [] -instance ToHie (LRoleAnnotDecl GhcRn) where+instance ToHie (Located (RoleAnnotDecl GhcRn)) where toHie (L span annot) = concatM $ makeNode annot span : case annot of RoleAnnotDecl _ var roles -> [ toHie $ C Use var , concatMapM (locOnly . getLoc) roles ] -instance ToHie (LInstDecl GhcRn) where+instance ToHie (Located (InstDecl GhcRn)) where toHie (L span decl) = concatM $ makeNode decl span : case decl of ClsInstD _ d -> [ toHie $ L span d@@ -1848,7 +1850,7 @@ [ toHie $ L span d ] -instance ToHie (LClsInstDecl GhcRn) where+instance ToHie (Located (ClsInstDecl GhcRn)) where toHie (L span decl) = concatM [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl@@ -1860,10 +1862,10 @@ , toHie $ cid_overlap_mode decl ] -instance ToHie (LDataFamInstDecl GhcRn) where+instance ToHie (Located (DataFamInstDecl GhcRn)) where toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d -instance ToHie (LTyFamInstDecl GhcRn) where+instance ToHie (Located (TyFamInstDecl GhcRn)) where toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d instance ToHie (Context a)@@ -1873,7 +1875,7 @@ , toHie $ C Use b ] -instance ToHie (LDerivDecl GhcRn) where+instance ToHie (Located (DerivDecl GhcRn)) where toHie (L span decl) = concatM $ makeNode decl span : case decl of DerivDecl _ typ strat overlap -> [ toHie $ TS (ResolvedScopes []) typ@@ -1881,19 +1883,19 @@ , toHie overlap ] -instance ToHie (LFixitySig GhcRn) where+instance ToHie (Located (FixitySig GhcRn)) where toHie (L span sig) = concatM $ makeNode sig span : case sig of FixitySig _ vars _ -> [ toHie $ map (C Use) vars ] -instance ToHie (LDefaultDecl GhcRn) where+instance ToHie (Located (DefaultDecl GhcRn)) where toHie (L span decl) = concatM $ makeNode decl span : case decl of DefaultDecl _ typs -> [ toHie typs ] -instance ToHie (LForeignDecl GhcRn) where+instance ToHie (Located (ForeignDecl GhcRn)) where toHie (L span decl) = concatM $ makeNode decl span : case decl of ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} -> [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name@@ -1919,19 +1921,19 @@ , locOnly b ] -instance ToHie (LWarnDecls GhcRn) where+instance ToHie (Located (WarnDecls GhcRn)) where toHie (L span decl) = concatM $ makeNode decl span : case decl of Warnings _ _ warnings -> [ toHie warnings ] -instance ToHie (LWarnDecl GhcRn) where+instance ToHie (Located (WarnDecl GhcRn)) where toHie (L span decl) = concatM $ makeNode decl span : case decl of Warning _ vars _ -> [ toHie $ map (C Use) vars ] -instance ToHie (LAnnDecl GhcRn) where+instance ToHie (Located (AnnDecl GhcRn)) where toHie (L span decl) = concatM $ makeNode decl span : case decl of HsAnnotation _ _ prov expr -> [ toHie prov@@ -1943,13 +1945,13 @@ toHie (TypeAnnProvenance a) = toHie $ C Use a toHie ModuleAnnProvenance = pure [] -instance ToHie (LRuleDecls GhcRn) where+instance ToHie (Located (RuleDecls GhcRn)) where toHie (L span decl) = concatM $ makeNode decl span : case decl of HsRules _ _ rules -> [ toHie rules ] -instance ToHie (LRuleDecl GhcRn) where+instance ToHie (Located (RuleDecl GhcRn)) where toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM [ makeNode r span , locOnly $ getLoc rname@@ -1963,7 +1965,7 @@ exprA_sc = mkLScope exprA exprB_sc = mkLScope exprB -instance ToHie (RScoped (LRuleBndr GhcRn)) where+instance ToHie (RScoped (Located (RuleBndr GhcRn))) where toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of RuleBndr _ var -> [ toHie $ C (ValBind RegularBind sc Nothing) var@@ -1973,7 +1975,7 @@ , toHie $ TS (ResolvedScopes [sc]) typ ] -instance ToHie (LImportDecl GhcRn) where+instance ToHie (Located (ImportDecl GhcRn)) where toHie (L span decl) = concatM $ makeNode decl span : case decl of ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } -> [ toHie $ IEC Import name@@ -1988,7 +1990,7 @@ where c = if hiding then ImportHiding else Import -instance ToHie (IEContext (LIE GhcRn)) where+instance ToHie (IEContext (Located (IE GhcRn))) where toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of IEVar _ n -> [ toHie $ IEC c n
compiler/GHC/Iface/Ext/Binary.hs view
@@ -2,6 +2,8 @@ Binary serialization for .hie files. -} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}+ module GHC.Iface.Ext.Binary ( readHieFile , readHieFileWithVersion@@ -48,12 +50,12 @@ data HieSymbolTable = HieSymbolTable { hie_symtab_next :: !FastMutInt- , hie_symtab_map :: !(IORef (UniqFM (Int, HieName)))+ , hie_symtab_map :: !(IORef (UniqFM Name (Int, HieName))) } data HieDictionary = HieDictionary { hie_dict_next :: !FastMutInt -- The next index to use- , hie_dict_map :: !(IORef (UniqFM (Int,FastString))) -- indexed by FastString+ , hie_dict_map :: !(IORef (UniqFM FastString (Int,FastString))) -- indexed by FastString } initBinMemSize :: Int@@ -97,7 +99,7 @@ -- Make some initial state symtab_next <- newFastMutInt writeFastMutInt symtab_next 0- symtab_map <- newIORef emptyUFM+ symtab_map <- newIORef emptyUFM :: IO (IORef (UniqFM Name (Int, HieName))) let hie_symtab = HieSymbolTable { hie_symtab_next = symtab_next, hie_symtab_map = symtab_map }@@ -257,16 +259,16 @@ hie_dict_map = out_r} bh f = do out <- readIORef out_r- let unique = getUnique f- case lookupUFM out unique of+ let !unique = getUnique f+ case lookupUFM_Directly out unique of Just (j, _) -> put_ bh (fromIntegral j :: Word32) Nothing -> do j <- readFastMutInt j_r put_ bh (fromIntegral j :: Word32) writeFastMutInt j_r (j + 1)- writeIORef out_r $! addToUFM out unique (j, f)+ writeIORef out_r $! addToUFM_Directly out unique (j, f) -putSymbolTable :: BinHandle -> Int -> UniqFM (Int,HieName) -> IO ()+putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,HieName) -> IO () putSymbolTable bh next_off symtab = do put_ bh next_off let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab))
compiler/GHC/Iface/Load.hs view
@@ -41,6 +41,7 @@ , tcIfaceAnnotations, tcIfaceCompleteSigs ) import GHC.Driver.Session+import GHC.Driver.Backend import GHC.Iface.Syntax import GHC.Iface.Env import GHC.Driver.Types@@ -592,12 +593,12 @@ -- instantiation of a signature might reside in the HPT, so -- this case breaks the assumption that EPS interfaces only -- refer to other EPS interfaces. We can detect when we're in- -- typechecking-only mode by using hscTarget==HscNothing, and+ -- typechecking-only mode by using backend==NoBackend, and -- in that case we don't empty the HPT. (admittedly this is -- a bit of a hack, better suggestions welcome). A number of -- tests in testsuite/tests/backpack break without this -- tweak.- !hpt | hscTarget hsc_dflags == HscNothing = hsc_HPT+ !hpt | backend hsc_dflags == NoBackend = hsc_HPT | otherwise = emptyHomePackageTable in HscEnv { hsc_targets = panic "cleanTopEnv: hsc_targets"@@ -982,7 +983,9 @@ writeIface :: DynFlags -> FilePath -> ModIface -> IO () writeIface dflags hi_file_path new_iface = do createDirectoryIfMissing True (takeDirectory hi_file_path)- writeBinIface dflags hi_file_path new_iface+ let printer = TraceBinIFace (debugTraceMsg dflags 3)+ profile = targetProfile dflags+ writeBinIface profile printer hi_file_path new_iface -- @readIface@ tries just the one file. readIface :: Module -> FilePath@@ -992,7 +995,7 @@ readIface wanted_mod file_path = do { res <- tryMostM $- readBinIface CheckHiWay QuietBinIFaceReading file_path+ readBinIface CheckHiWay QuietBinIFace file_path ; case res of Right iface -- NB: This check is NOT just a sanity check, it is@@ -1111,12 +1114,15 @@ -- | Read binary interface, and print it out showIface :: HscEnv -> FilePath -> IO () showIface hsc_env filename = do+ let dflags = hsc_dflags hsc_env+ printer = putLogMsg dflags NoReason SevOutput noSrcSpan . withPprStyle defaultDumpStyle+ -- skip the hi way check; we don't want to worry about profiled vs. -- non-profiled interfaces, for example. iface <- initTcRnIf 's' hsc_env () () $- readBinIface IgnoreHiWay TraceBinIFaceReading filename- let dflags = hsc_dflags hsc_env- -- See Note [Name qualification with --show-iface]+ readBinIface IgnoreHiWay (TraceBinIFace printer) filename++ let -- See Note [Name qualification with --show-iface] qualifyImportedNames mod _ | mod == mi_module iface = NameUnqual | otherwise = NameNotInScope1
compiler/GHC/Iface/Make.hs view
@@ -28,6 +28,7 @@ import GHC.Iface.Load import GHC.CoreToIface +import qualified GHC.LanguageExtensions as LangExt import GHC.HsToCore.Usage ( mkUsageInfo, mkUsedNames, mkDependencies ) import GHC.Types.Id import GHC.Types.Annotations@@ -46,6 +47,7 @@ import GHC.Tc.Utils.Monad import GHC.Hs import GHC.Driver.Types+import GHC.Driver.Backend import GHC.Driver.Session import GHC.Types.Var.Env import GHC.Types.Var@@ -144,7 +146,7 @@ -- | Make an interface from the results of typechecking only. Useful -- for non-optimising compilation, or where we aren't generating any--- object code at all ('HscNothing').+-- object code at all ('NoBackend'). mkIfaceTc :: HscEnv -> SafeHaskellMode -- The safe haskell mode -> ModDetails -- gotten from mkBootModDetails, probably@@ -224,7 +226,8 @@ = do let semantic_mod = canonicalizeHomeModule (hsc_dflags hsc_env) (moduleName this_mod) entities = typeEnvElts type_env- decls = [ tyThingToIfaceDecl (hsc_dflags hsc_env) entity+ show_linear_types = xopt LangExt.LinearTypes (hsc_dflags hsc_env)+ decls = [ tyThingToIfaceDecl show_linear_types entity | entity <- entities, let name = getName entity, not (isImplicitTyThing entity),@@ -301,8 +304,8 @@ -- scope available. (#5534) maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv maybeGlobalRdrEnv rdr_env- | targetRetainsAllBindings (hscTarget dflags) = Just rdr_env- | otherwise = Nothing+ | backendRetainsAllBindings (backend dflags) = Just rdr_env+ | otherwise = Nothing ifFamInstTcName = ifFamInstFam @@ -375,12 +378,12 @@ ************************************************************************ -} -tyThingToIfaceDecl :: DynFlags -> TyThing -> IfaceDecl+tyThingToIfaceDecl :: Bool -> TyThing -> IfaceDecl tyThingToIfaceDecl _ (AnId id) = idToIfaceDecl id tyThingToIfaceDecl _ (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon) tyThingToIfaceDecl _ (ACoAxiom ax) = coAxiomToIfaceDecl ax-tyThingToIfaceDecl dflags (AConLike cl) = case cl of- RealDataCon dc -> dataConToIfaceDecl dflags dc -- for ppr purposes only+tyThingToIfaceDecl show_linear_types (AConLike cl) = case cl of+ RealDataCon dc -> dataConToIfaceDecl show_linear_types dc -- for ppr purposes only PatSynCon ps -> patSynToIfaceDecl ps --------------------------@@ -396,10 +399,10 @@ ifIdInfo = toIfaceIdInfo (idInfo id) } ---------------------------dataConToIfaceDecl :: DynFlags -> DataCon -> IfaceDecl-dataConToIfaceDecl dflags dataCon+dataConToIfaceDecl :: Bool -> DataCon -> IfaceDecl+dataConToIfaceDecl show_linear_types dataCon = IfaceId { ifName = getName dataCon,- ifType = toIfaceType (dataConDisplayType dflags dataCon),+ ifType = toIfaceType (dataConDisplayType show_linear_types dataCon), ifIdDetails = IfVanillaId, ifIdInfo = [] }
compiler/GHC/Iface/Recomp.hs view
@@ -23,6 +23,7 @@ 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@@ -169,7 +170,7 @@ -- If the source has changed and we're in interactive mode, -- avoid reading an interface; just return the one we might -- have been supplied with.- True | not (isObjectTarget $ hscTarget dflags) ->+ True | not (backendProducesObject $ backend dflags) -> return (MustCompile, maybe_iface) -- Try and read the old interface for the current module
compiler/GHC/Iface/Tidy.hs view
@@ -18,6 +18,7 @@ import GHC.Tc.Types import GHC.Driver.Session+import GHC.Driver.Backend import GHC.Core import GHC.Core.Unfold import GHC.Core.FVs@@ -383,10 +384,10 @@ sptCreateStaticBinds hsc_env mod tidy_binds ; let { spt_init_code = sptModuleInitCode mod spt_entries ; add_spt_init_code =- case hscTarget dflags of+ case backend dflags of -- If we are compiling for the interpreter we will insert -- any necessary SPT entries dynamically- HscInterpreted -> id+ Interpreter -> id -- otherwise add a C stub to do so _ -> (`appendStubC` spt_init_code)
compiler/GHC/Rename/Bind.hs view
@@ -43,7 +43,8 @@ import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, extendTyVarEnvFVRn , checkDupRdrNames, warnUnusedLocalBinds , checkUnusedRecordWildcard- , checkDupAndShadowedNames, bindLocalNamesFV )+ , checkDupAndShadowedNames, bindLocalNamesFV+ , addNoNestedForallsContextsErr, checkInferredVars ) import GHC.Driver.Session import GHC.Unit.Module import GHC.Types.Name@@ -955,7 +956,7 @@ renameSig ctxt sig@(TypeSig _ vs ty) = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs ; let doc = TypeSigCtx (ppr_sig_bndrs vs)- ; (new_ty, fvs) <- rnHsSigWcType doc Nothing ty+ ; (new_ty, fvs) <- rnHsSigWcType doc ty ; return (TypeSig noExtField new_vs new_ty, fvs) } renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty)@@ -963,20 +964,25 @@ ; when (is_deflt && not defaultSigs_on) $ addErr (defaultSigErr sig) ; new_v <- mapM (lookupSigOccRn ctxt sig) vs- ; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel inf_msg ty+ ; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel ty ; return (ClassOpSig noExtField is_deflt new_v new_ty, fvs) } where (v1:_) = vs ty_ctxt = GenericCtx (text "a class method signature for" <+> quotes (ppr v1))- inf_msg = if is_deflt- then Just (text "A default type signature cannot contain inferred type variables")- else Nothing renameSig _ (SpecInstSig _ src ty)- = do { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx TypeLevel inf_msg ty+ = do { checkInferredVars doc inf_msg ty+ ; (new_ty, fvs) <- rnHsSigType doc TypeLevel ty+ -- Check if there are any nested `forall`s or contexts, which are+ -- illegal in the type of an instance declaration (see+ -- Note [No nested foralls or contexts in instance types] in+ -- GHC.Hs.Type).+ ; addNoNestedForallsContextsErr doc (text "SPECIALISE instance type")+ (getLHsInstDeclHead new_ty) ; return (SpecInstSig noExtField src new_ty,fvs) } where+ doc = SpecInstSigCtx inf_msg = Just (text "Inferred type variables are not allowed") -- {-# SPECIALISE #-} pragmas can refer to imported Ids@@ -993,7 +999,7 @@ ty_ctxt = GenericCtx (text "a SPECIALISE signature for" <+> quotes (ppr v)) do_one (tys,fvs) ty- = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt TypeLevel Nothing ty+ = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt TypeLevel ty ; return ( new_ty:tys, fvs_ty `plusFV` fvs) } renameSig ctxt sig@(InlineSig _ v s)@@ -1010,7 +1016,7 @@ renameSig ctxt sig@(PatSynSig _ vs ty) = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs- ; (ty', fvs) <- rnHsSigType ty_ctxt TypeLevel Nothing ty+ ; (ty', fvs) <- rnHsSigType ty_ctxt TypeLevel ty ; return (PatSynSig noExtField new_vs ty', fvs) } where ty_ctxt = GenericCtx (text "a pattern synonym signature for"
compiler/GHC/Rename/Env.hs view
@@ -31,7 +31,7 @@ -- Rebindable Syntax lookupSyntax, lookupSyntaxExpr, lookupSyntaxName, lookupSyntaxNames,- lookupIfThenElse,+ lookupIfThenElse, lookupReboundIf, -- QualifiedDo lookupQualifiedDoExpr, lookupQualifiedDo,@@ -58,6 +58,7 @@ import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad import GHC.Parser.PostProcess ( filterCTuple, setRdrNameSpace )+import GHC.Builtin.RebindableNames import GHC.Builtin.Types import GHC.Types.Name import GHC.Types.Name.Set@@ -1769,6 +1770,32 @@ = case qualifiedDoModuleName_maybe ctxt of Nothing -> lookupSyntaxName std_name Just modName -> lookupNameWithQualifier std_name modName+++-- Lookup a locally-rebound name for Rebindable Syntax (RS).+--+-- - When RS is off, 'lookupRebound' just returns 'Nothing', whatever+-- name it is given.+--+-- - When RS is on, we always try to return a 'Just', and GHC errors out+-- if no suitable name is found in the environment.+--+-- 'Nothing' really is "reserved" and means that rebindable syntax is off.+lookupRebound :: FastString -> RnM (Maybe (Located Name))+lookupRebound nameStr = do+ rebind <- xoptM LangExt.RebindableSyntax+ if rebind+ -- If repetitive lookups ever become a problem perormance-wise,+ -- we could lookup all the names we will ever care about just once+ -- at the beginning and stick them in the environment, possibly+ -- populating that "cache" lazily too.+ then (\nm -> Just (L (nameSrcSpan nm) nm)) <$>+ lookupOccRn (mkVarUnqual nameStr)+ else pure Nothing++-- | Lookup an @ifThenElse@ binding (see 'lookupRebound').+lookupReboundIf :: RnM (Maybe (Located Name))+lookupReboundIf = lookupRebound reboundIfSymbol -- Error messages
compiler/GHC/Rename/Expr.hs view
@@ -242,7 +242,6 @@ where rn_prag :: HsPragE GhcPs -> HsPragE GhcRn rn_prag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann- rn_prag (HsPragCore x1 src lbl) = HsPragCore x1 src lbl rn_prag (HsPragTick x1 src info srcInfo) = HsPragTick x1 src info srcInfo rnExpr (HsLam x matches)@@ -318,18 +317,25 @@ , fvExpr `plusFV` fvRbinds) } rnExpr (ExprWithTySig _ expr pty)- = do { (pty', fvTy) <- rnHsSigWcType ExprWithTySigCtx Nothing pty+ = do { (pty', fvTy) <- rnHsSigWcType ExprWithTySigCtx pty ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $ rnLExpr expr ; return (ExprWithTySig noExtField expr' pty', fvExpr `plusFV` fvTy) }--rnExpr (HsIf might_use_rebindable_syntax _ p b1 b2)+rnExpr (HsIf _ p b1 b2) = do { (p', fvP) <- rnLExpr p ; (b1', fvB1) <- rnLExpr b1 ; (b2', fvB2) <- rnLExpr b2- ; (mb_ite, fvITE) <- lookupIfThenElse might_use_rebindable_syntax- ; return (HsIf noExtField mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }-+ ; mifteName <- lookupReboundIf+ ; let subFVs = plusFVs [fvP, fvB1, fvB2]+ ; return $ case mifteName of+ -- RS is off, we keep an 'HsIf' node around+ Nothing ->+ (HsIf noExtField p' b1' b2', subFVs)+ -- See Note [Rebindable syntax and HsExpansion].+ Just ifteName ->+ let ifteExpr = rebindIf ifteName p' b1' b2'+ in (ifteExpr, plusFVs [unitFV (unLoc ifteName), subFVs])+ } rnExpr (HsMultiIf x alts) = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts -- ; return (HsMultiIf ty alts', fvs) }@@ -433,6 +439,7 @@ rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars) rnCmdTop = wrapLocFstM rnCmdTop' where+ rnCmdTop' :: HsCmdTop GhcPs -> RnM (HsCmdTop GhcRn, FreeVars) rnCmdTop' (HsCmdTop _ cmd) = do { (cmd', fvCmd) <- rnLCmd cmd ; let cmd_names = [arrAName, composeAName, firstAName] ++@@ -1865,7 +1872,7 @@ , is_body_stmt = False}) = not (isIrrefutableHsPat pat) hasRefutablePattern _ = False -isLetStmt :: LStmt a b -> Bool+isLetStmt :: LStmt (GhcPass a) b -> Bool isLetStmt (L _ LetStmt{}) = True isLetStmt _ = False @@ -2224,3 +2231,26 @@ mkSyntaxExpr failAfterFromStringExpr return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs) | otherwise = lookupQualifiedDo ctxt failMName++-- Rebinding 'if's to 'ifThenElse' applications.+--+-- See Note [Rebindable syntax and HsExpansion]+rebindIf+ :: Located Name -- 'Name' for the 'ifThenElse' function we will rebind to+ -> LHsExpr GhcRn -- renamed condition+ -> LHsExpr GhcRn -- renamed true branch+ -> LHsExpr GhcRn -- renamed false branch+ -> HsExpr GhcRn -- rebound if expression+rebindIf ifteName p b1 b2 =+ let ifteOrig = HsIf noExtField p b1 b2+ ifteFun = L generatedSrcSpan (HsVar noExtField ifteName)+ -- ifThenElse var+ ifteApp = mkHsAppsWith (\_ _ e -> L generatedSrcSpan e)+ ifteFun+ [p, b1, b2]+ -- desugared_if_expr =+ -- ifThenElse desugared_predicate+ -- desugared_true_branch+ -- desugared_false_branch+ in mkExpanded XExpr ifteOrig (unLoc ifteApp)+ -- (source_if_expr, desugared_if_expr)
compiler/GHC/Rename/HsType.hs view
@@ -39,7 +39,6 @@ import {-# SOURCE #-} GHC.Rename.Splice( rnSpliceType ) -import GHC.Core.Type import GHC.Driver.Session import GHC.Hs import GHC.Rename.Doc ( rnLHsDoc, rnMbLHsDoc )@@ -68,7 +67,7 @@ import GHC.Data.Maybe import qualified GHC.LanguageExtensions as LangExt -import Data.List ( nubBy, partition, find )+import Data.List ( nubBy, partition ) import Control.Monad ( unless, when ) #include "GhclibHsVersions.h"@@ -124,19 +123,16 @@ -- "GHC.Hs.Type". rnHsSigWcType :: HsDocContext- -> Maybe SDoc- -- ^ The error msg if the signature is not allowed to contain- -- manually written inferred variables. -> LHsSigWcType GhcPs -> RnM (LHsSigWcType GhcRn, FreeVars)-rnHsSigWcType doc inf_err (HsWC { hswc_body = HsIB { hsib_body = hs_ty }})- = rn_hs_sig_wc_type BindUnlessForall doc inf_err hs_ty $ \nwcs imp_tvs body ->+rnHsSigWcType doc (HsWC { hswc_body = HsIB { hsib_body = hs_ty }})+ = rn_hs_sig_wc_type BindUnlessForall doc hs_ty $ \nwcs imp_tvs body -> let ib_ty = HsIB { hsib_ext = imp_tvs, hsib_body = body } wc_ty = HsWC { hswc_ext = nwcs, hswc_body = ib_ty } in pure (wc_ty, emptyFVs) rnHsPatSigType :: HsSigWcTypeScoping- -> HsDocContext -> Maybe SDoc+ -> HsDocContext -> HsPatSigType GhcPs -> (HsPatSigType GhcRn -> RnM (a, FreeVars)) -> RnM (a, FreeVars)@@ -147,10 +143,10 @@ -- Wildcards are allowed -- -- See Note [Pattern signature binders and scoping] in GHC.Hs.Type-rnHsPatSigType scoping ctx inf_err sig_ty thing_inside+rnHsPatSigType scoping ctx sig_ty thing_inside = do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables ; checkErr ty_sig_okay (unexpectedPatSigTypeErr sig_ty)- ; rn_hs_sig_wc_type scoping ctx inf_err (hsPatSigType sig_ty) $+ ; rn_hs_sig_wc_type scoping ctx (hsPatSigType sig_ty) $ \nwcs imp_tvs body -> do { let sig_names = HsPSRn { hsps_nwcs = nwcs, hsps_imp_tvs = imp_tvs } sig_ty' = HsPS { hsps_ext = sig_names, hsps_body = body }@@ -158,16 +154,15 @@ } } -- The workhorse for rnHsSigWcType and rnHsPatSigType.-rn_hs_sig_wc_type :: HsSigWcTypeScoping -> HsDocContext -> Maybe SDoc+rn_hs_sig_wc_type :: HsSigWcTypeScoping -> HsDocContext -> LHsType GhcPs -> ([Name] -- Wildcard names -> [Name] -- Implicitly bound type variable names -> LHsType GhcRn -> RnM (a, FreeVars)) -> RnM (a, FreeVars)-rn_hs_sig_wc_type scoping ctxt inf_err hs_ty thing_inside- = do { check_inferred_vars ctxt inf_err hs_ty- ; free_vars <- filterInScopeM (extractHsTyRdrTyVars hs_ty)+rn_hs_sig_wc_type scoping ctxt hs_ty thing_inside+ = do { free_vars <- filterInScopeM (extractHsTyRdrTyVars hs_ty) ; (nwc_rdrs', tv_rdrs) <- partition_nwcs free_vars ; let nwc_rdrs = nubL nwc_rdrs' ; implicit_bndrs <- case scoping of@@ -318,17 +313,13 @@ rnHsSigType :: HsDocContext -> TypeOrKind- -> Maybe SDoc- -- ^ The error msg if the signature is not allowed to contain- -- manually written inferred variables. -> LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars) -- Used for source-language type signatures -- that cannot have wildcards-rnHsSigType ctx level inf_err (HsIB { hsib_body = hs_ty })+rnHsSigType ctx level (HsIB { hsib_body = hs_ty }) = do { traceRn "rnHsSigType" (ppr hs_ty) ; rdr_env <- getLocalRdrEnv- ; check_inferred_vars ctx inf_err hs_ty ; vars0 <- forAllOrNothing (isLHsForAllTy hs_ty) $ filterInScope rdr_env $ extractHsTyRdrTyVars hs_ty@@ -414,26 +405,6 @@ type signature, since the type signature implicitly carries their binding sites. This is less precise, but more accurate. -}--check_inferred_vars :: HsDocContext- -> Maybe SDoc- -- ^ The error msg if the signature is not allowed to contain- -- manually written inferred variables.- -> LHsType GhcPs- -> RnM ()-check_inferred_vars _ Nothing _ = return ()-check_inferred_vars ctxt (Just msg) ty =- let bndrs = forallty_bndrs ty- in case find ((==) InferredSpec . hsTyVarBndrFlag) bndrs of- Nothing -> return ()- Just _ -> addErr $ withHsDocContext ctxt msg- where- forallty_bndrs :: LHsType GhcPs -> [HsTyVarBndr Specificity GhcPs]- forallty_bndrs (L _ ty) = case ty of- HsParTy _ ty' -> forallty_bndrs ty'- HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = tvs }}- -> map unLoc tvs- _ -> [] {- ****************************************************** * *
compiler/GHC/Rename/Module.hs view
@@ -34,7 +34,8 @@ , checkDupRdrNames, bindLocalNamesFV , checkShadowedRdrNames, warnUnusedTypePatterns , extendTyVarEnvFVRn, newLocalBndrsRn- , withHsDocContext )+ , withHsDocContext, noNestedForallsContextsErr+ , addNoNestedForallsContextsErr, checkInferredVars ) import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr ) import GHC.Rename.Names import GHC.Rename.Doc ( rnHsDoc, rnMbLHsDoc )@@ -65,7 +66,6 @@ import GHC.Data.Graph.Directed ( SCC, flattenSCC, flattenSCCs, Node(..) , stronglyConnCompFromEdgedVerticesUniq ) import GHC.Types.Unique.Set-import GHC.Data.Maybe ( whenIsJust ) import GHC.Data.OrdList import qualified GHC.LanguageExtensions as LangExt @@ -371,7 +371,7 @@ rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec }) = do { topEnv :: HscEnv <- getTopEnv ; name' <- lookupLocatedTopBndrRn name- ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel Nothing ty+ ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty -- Mark any PackageTarget style imports as coming from the current package ; let unitId = homeUnit $ hsc_dflags topEnv@@ -383,7 +383,7 @@ rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec }) = do { name' <- lookupLocatedOccRn name- ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel Nothing ty+ ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty ; return (ForeignExport { fd_e_ext = noExtField , fd_name = name', fd_sig_ty = ty' , fd_fe = spec }@@ -424,11 +424,11 @@ rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars) rnSrcInstDecl (TyFamInstD { tfid_inst = tfi })- = do { (tfi', fvs) <- rnTyFamInstDecl NonAssocTyFamEqn tfi+ = do { (tfi', fvs) <- rnTyFamInstDecl (NonAssocTyFamEqn NotClosedTyFam) tfi ; return (TyFamInstD { tfid_ext = noExtField, tfid_inst = tfi' }, fvs) } rnSrcInstDecl (DataFamInstD { dfid_inst = dfi })- = do { (dfi', fvs) <- rnDataFamInstDecl NonAssocTyFamEqn dfi+ = do { (dfi', fvs) <- rnDataFamInstDecl (NonAssocTyFamEqn NotClosedTyFam) dfi ; return (DataFamInstD { dfid_ext = noExtField, dfid_inst = dfi' }, fvs) } rnSrcInstDecl (ClsInstD { cid_inst = cid })@@ -602,13 +602,14 @@ , cid_sigs = uprags, cid_tyfam_insts = ats , cid_overlap_mode = oflag , cid_datafam_insts = adts })- = do { (inst_ty', inst_fvs) <- rnHsSigType ctxt TypeLevel inf_err inst_ty+ = do { checkInferredVars ctxt inf_err inst_ty+ ; (inst_ty', inst_fvs) <- rnHsSigType ctxt TypeLevel inst_ty ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty' -- Check if there are any nested `forall`s or contexts, which are -- illegal in the type of an instance declaration (see -- Note [No nested foralls or contexts in instance types] in -- GHC.Hs.Type)...- mb_nested_msg = no_nested_foralls_contexts_err+ mb_nested_msg = noNestedForallsContextsErr (text "Instance head") head_ty' -- ...then check if the instance head is actually headed by a -- class type constructor...@@ -628,17 +629,10 @@ -- with an error message if there isn't one. To avoid excessive -- amounts of error messages, we will only report one of the errors -- from mb_nested_msg or eith_cls at a time.- ; cls <- case maybe eith_cls Left mb_nested_msg of- Right cls -> pure cls- Left (l, err_msg) -> do- -- The instance is malformed. We'd still like- -- to make *some* progress (rather than failing outright), so- -- we report an error and continue for as long as we can.- -- Importantly, this error should be thrown before we reach the- -- typechecker, lest we encounter different errors that are- -- hopelessly confusing (such as the one in #16114).- addErrAt l $ withHsDocContext ctxt err_msg- pure $ mkUnboundName (mkTcOccFS (fsLit "<class>"))+ ; cls <- case (mb_nested_msg, eith_cls) of+ (Nothing, Right cls) -> pure cls+ (Just err1, _) -> bail_out err1+ (_, Left err2) -> bail_out err2 -- Rename the bindings -- The typechecker (not the renamer) checks that all@@ -680,6 +674,15 @@ ctxt = GenericCtx $ text "an instance declaration" inf_err = Just (text "Inferred type variables are not allowed") + -- The instance is malformed. We'd still like to make *some* progress+ -- (rather than failing outright), so we report an error and continue for+ -- as long as we can. Importantly, this error should be thrown before we+ -- reach the typechecker, lest we encounter different errors that are+ -- hopelessly confusing (such as the one in #16114).+ bail_out (l, err_msg) = do+ addErrAt l $ withHsDocContext ctxt err_msg+ pure $ mkUnboundName (mkTcOccFS (fsLit "<class>"))+ rnFamInstEqn :: HsDocContext -> AssocTyFamInfo -> FreeKiTyVars@@ -760,8 +763,12 @@ all_nms = all_imp_var_names ++ hsLTyVarNames bndrs' ; warnUnusedTypePatterns all_nms nms_used - ; let all_fvs = (rhs_fvs `plusFV` pat_fvs) `addOneFV` unLoc tycon'- -- type instance => use, hence addOneFV+ ; let eqn_fvs = rhs_fvs `plusFV` pat_fvs+ -- See Note [Type family equations and occurrences]+ all_fvs = case atfi of+ NonAssocTyFamEqn ClosedTyFam+ -> eqn_fvs+ _ -> eqn_fvs `addOneFV` unLoc tycon' ; return (HsIB { hsib_ext = all_imp_var_names -- Note [Wildcards in family instances] , hsib_body@@ -776,14 +783,14 @@ -- The parent class, if we are dealing with an associated type family -- instance. mb_cls = case atfi of- NonAssocTyFamEqn -> Nothing+ NonAssocTyFamEqn _ -> Nothing AssocTyFamDeflt cls -> Just cls AssocTyFamInst cls _ -> Just cls -- The type variables from the instance head, if we are dealing with an -- associated type family instance. inst_tvs = case atfi of- NonAssocTyFamEqn -> []+ NonAssocTyFamEqn _ -> [] AssocTyFamDeflt _ -> [] AssocTyFamInst _ inst_tvs -> inst_tvs @@ -806,48 +813,62 @@ -> TyFamInstDecl GhcPs -> RnM (TyFamInstDecl GhcRn, FreeVars) rnTyFamInstDecl atfi (TyFamInstDecl { tfid_eqn = eqn })- = do { (eqn', fvs) <- rnTyFamInstEqn atfi NotClosedTyFam eqn+ = do { (eqn', fvs) <- rnTyFamInstEqn atfi eqn ; return (TyFamInstDecl { tfid_eqn = eqn' }, fvs) } -- | Tracks whether we are renaming: -- -- 1. A type family equation that is not associated--- with a parent type class ('NonAssocTyFamEqn')+-- with a parent type class ('NonAssocTyFamEqn'). Examples: ----- 2. An associated type family default declaration ('AssocTyFamDeflt')+-- @+-- type family F a+-- type instance F Int = Bool -- NonAssocTyFamEqn NotClosed ----- 3. An associated type family instance declaration ('AssocTyFamInst')+-- type family G a where+-- G Int = Bool -- NonAssocTyFamEqn Closed+-- @+--+-- 2. An associated type family default declaration ('AssocTyFamDeflt').+-- Example:+--+-- @+-- class C a where+-- type A a+-- type instance A a = a -> a -- AssocTyFamDeflt C+-- @+--+-- 3. An associated type family instance declaration ('AssocTyFamInst').+-- Example:+--+-- @+-- instance C a => C [a] where+-- type A [a] = Bool -- AssocTyFamInst C [a]+-- @ data AssocTyFamInfo = NonAssocTyFamEqn- | AssocTyFamDeflt Name -- Name of the parent class- | AssocTyFamInst Name -- Name of the parent class- [Name] -- Names of the tyvars of the parent instance decl+ ClosedTyFamInfo -- Is this a closed type family?+ | AssocTyFamDeflt+ Name -- Name of the parent class+ | AssocTyFamInst+ Name -- Name of the parent class+ [Name] -- Names of the tyvars of the parent instance decl -- | Tracks whether we are renaming an equation in a closed type family -- equation ('ClosedTyFam') or not ('NotClosedTyFam'). data ClosedTyFamInfo = NotClosedTyFam- | ClosedTyFam (Located RdrName) Name- -- The names (RdrName and Name) of the closed type family+ | ClosedTyFam rnTyFamInstEqn :: AssocTyFamInfo- -> ClosedTyFamInfo -> TyFamInstEqn GhcPs -> RnM (TyFamInstEqn GhcRn, FreeVars)-rnTyFamInstEqn atfi ctf_info+rnTyFamInstEqn atfi eqn@(HsIB { hsib_body = FamEqn { feqn_tycon = tycon , feqn_rhs = rhs }})- = do { let rhs_kvs = extractHsTyRdrTyVarsKindVars rhs- ; (eqn'@(HsIB { hsib_body =- FamEqn { feqn_tycon = L _ tycon' }}), fvs)- <- rnFamInstEqn (TySynCtx tycon) atfi rhs_kvs eqn rnTySyn- ; case ctf_info of- NotClosedTyFam -> pure ()- ClosedTyFam fam_rdr_name fam_name ->- checkTc (fam_name == tycon') $- withHsDocContext (TyFamilyCtx fam_rdr_name) $- wrongTyFamName fam_name tycon'- ; pure (eqn', fvs) }+ = rnFamInstEqn (TySynCtx tycon) atfi rhs_kvs eqn rnTySyn+ where+ rhs_kvs = extractHsTyRdrTyVarsKindVars rhs rnTyFamDefltDecl :: Name -> TyFamDefltDecl GhcPs@@ -995,6 +1016,51 @@ In each case, the function which detects improperly bound variables on the RHS is GHC.Tc.Validity.checkValidFamPats.++Note [Type family equations and occurrences]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In most data/type family equations, the type family name used in the equation+is treated as an occurrence. For example:++ module A where+ type family F a++ module B () where+ import B (F)+ type instance F Int = Bool++We do not want to warn about `F` being unused in the module `B`, as the+instance constitutes a use site for `F`. The exception to this rule is closed+type families, whose equations constitute a definition, not occurrences. For+example:++ module C () where+ type family CF a where+ CF Char = Float++Here, we /do/ want to warn that `CF` is unused in the module `C`, as it is+defined but not used (#18470).++GHC accomplishes this in rnFamInstEqn when determining the set of free+variables to return at the end. If renaming a data family or open type family+equation, we add the name of the type family constructor to the set of returned+free variables to ensure that the name is marked as an occurrence. If renaming+a closed type family equation, we avoid adding the type family constructor name+to the free variables. This is quite simple, but it is not a perfect solution.+Consider this example:++ module X () where+ type family F a where+ F Int = Bool+ F Double = F Int++At present, GHC will treat any use of a type family constructor on the RHS of a+type family equation as an occurrence. Since `F` is used on the RHS of the+second equation of `F`, it is treated as an occurrence, causing `F` not to be+warned about. This is not ideal, since `F` isn't exported—it really /should/+cause a warning to be emitted. There is some discussion in #10089/#12920 about+how this limitation might be overcome, but until then, we stick to the+simplistic solution above, as it fixes the egregious bug in #18470. -} @@ -1010,22 +1076,22 @@ rnSrcDerivDecl (DerivDecl _ ty mds overlap) = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving ; unless standalone_deriv_ok (addErr standaloneDerivErr)- ; (mds', ty', fvs)- <- rnLDerivStrategy ctxt mds $ rnHsSigWcType ctxt inf_err ty+ ; checkInferredVars ctxt inf_err nowc_ty+ ; (mds', ty', fvs) <- rnLDerivStrategy ctxt mds $ rnHsSigWcType ctxt ty -- Check if there are any nested `forall`s or contexts, which are -- illegal in the type of an instance declaration (see -- Note [No nested foralls or contexts in instance types] in -- GHC.Hs.Type).- ; whenIsJust (no_nested_foralls_contexts_err- (text "Standalone-derived instance head")- (getLHsInstDeclHead $ dropWildCards ty')) $ \(l, err_msg) ->- addErrAt l $ withHsDocContext ctxt err_msg+ ; addNoNestedForallsContextsErr ctxt+ (text "Standalone-derived instance head")+ (getLHsInstDeclHead $ dropWildCards ty') ; warnNoDerivStrat mds' loc ; return (DerivDecl noExtField ty' mds' overlap, fvs) } where ctxt = DerivDeclCtx inf_err = Just (text "Inferred type variables are not allowed")- loc = getLoc $ hsib_body $ hswc_body ty+ loc = getLoc $ hsib_body nowc_ty+ nowc_ty = dropWildCards ty standaloneDerivErr :: SDoc standaloneDerivErr@@ -1091,7 +1157,7 @@ go ((L l (RuleBndrSig _ (L loc _) bsig)) : vars) (n : ns) thing_inside- = rnHsPatSigType bind_free_tvs doc Nothing bsig $ \ bsig' ->+ = rnHsPatSigType bind_free_tvs doc bsig $ \ bsig' -> go vars ns $ \ vars' -> thing_inside (L l (RuleBndrSig noExtField (L loc n) bsig') : vars') @@ -1431,7 +1497,7 @@ ; unless standalone_ki_sig_ok $ addErr standaloneKiSigErr ; new_v <- lookupSigCtxtOccRn (TopSigCtxt tc_names) (text "standalone kind signature") v ; let doc = StandaloneKindSigCtx (ppr v)- ; (new_ki, fvs) <- rnHsSigType doc KindLevel Nothing ki+ ; (new_ki, fvs) <- rnHsSigType doc KindLevel ki ; return (StandaloneKindSig noExtField new_v new_ki, fvs) } where@@ -1717,7 +1783,7 @@ cls_doc = ClassDeclCtx lcls -- Does the data type declaration include a CUSK?-data_decl_has_cusk :: LHsQTyVars pass -> NewOrData -> Bool -> Maybe (LHsKind pass') -> RnM Bool+data_decl_has_cusk :: LHsQTyVars (GhcPass p) -> NewOrData -> Bool -> Maybe (LHsKind (GhcPass p')) -> RnM Bool data_decl_has_cusk tyvars new_or_data no_rhs_kvs kind_sig = do { -- See Note [Unlifted Newtypes and CUSKs], and for a broader -- picture, see Note [Implementation of UnliftedNewtypes].@@ -1841,15 +1907,14 @@ rn_clause_pred :: LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars) rn_clause_pred pred_ty = do let inf_err = Just (text "Inferred type variables are not allowed")- ret@(pred_ty', _) <- rnHsSigType doc TypeLevel inf_err pred_ty+ checkInferredVars doc inf_err pred_ty+ ret@(pred_ty', _) <- rnHsSigType doc TypeLevel pred_ty -- Check if there are any nested `forall`s, which are illegal in a -- `deriving` clause. -- See Note [No nested foralls or contexts in instance types] -- (Wrinkle: Derived instances) in GHC.Hs.Type.- whenIsJust (no_nested_foralls_contexts_err- (text "Derived class type")- (getLHsInstDeclHead pred_ty')) $ \(l, err_msg) ->- addErrAt l $ withHsDocContext doc err_msg+ addNoNestedForallsContextsErr doc (text "Derived class type")+ (getLHsInstDeclHead pred_ty') pure ret rnLDerivStrategy :: forall a.@@ -1883,7 +1948,8 @@ AnyclassStrategy -> boring_case AnyclassStrategy NewtypeStrategy -> boring_case NewtypeStrategy ViaStrategy via_ty ->- do (via_ty', fvs1) <- rnHsSigType doc TypeLevel inf_err via_ty+ do checkInferredVars doc inf_err via_ty+ (via_ty', fvs1) <- rnHsSigType doc TypeLevel via_ty let HsIB { hsib_ext = via_imp_tvs , hsib_body = via_body } = via_ty' (via_exp_tv_bndrs, via_rho) = splitLHsForAllTyInvis_KP via_body@@ -1893,10 +1959,8 @@ -- `via` type. -- See Note [No nested foralls or contexts in instance types] -- (Wrinkle: Derived instances) in GHC.Hs.Type.- whenIsJust (no_nested_foralls_contexts_err- (quotes (text "via") <+> text "type")- via_rho) $ \(l, err_msg) ->- addErrAt l $ withHsDocContext doc err_msg+ addNoNestedForallsContextsErr doc+ (quotes (text "via") <+> text "type") via_rho (thing, fvs2) <- extendTyVarEnvFVRn via_tvs thing_inside pure (ViaStrategy via_ty', thing, fvs1 `plusFV` fvs2) @@ -1947,7 +2011,7 @@ ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig') injectivity ; return ( (tyvars', res_sig', injectivity') , fv_kind ) }- ; (info', fv2) <- rn_info tycon' info+ ; (info', fv2) <- rn_info info ; return (FamilyDecl { fdExt = noExtField , fdLName = tycon', fdTyVars = tyvars' , fdFixity = fixity@@ -1959,18 +2023,16 @@ kvs = extractRdrKindSigVars res_sig ----------------------- rn_info :: Located Name- -> FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars)- rn_info (L _ fam_name) (ClosedTypeFamily (Just eqns))+ rn_info :: FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars)+ rn_info (ClosedTypeFamily (Just eqns)) = do { (eqns', fvs)- <- rnList (rnTyFamInstEqn NonAssocTyFamEqn (ClosedTyFam tycon fam_name))+ <- rnList (rnTyFamInstEqn (NonAssocTyFamEqn ClosedTyFam)) eqns -- no class context- eqns ; return (ClosedTypeFamily (Just eqns'), fvs) }- rn_info _ (ClosedTypeFamily Nothing)+ rn_info (ClosedTypeFamily Nothing) = return (ClosedTypeFamily Nothing, emptyFVs)- rn_info _ OpenTypeFamily = return (OpenTypeFamily, emptyFVs)- rn_info _ DataFamily = return (DataFamily, emptyFVs)+ rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs)+ rn_info DataFamily = return (DataFamily, emptyFVs) rnFamResultSig :: HsDocContext -> FamilyResultSig GhcPs@@ -2114,13 +2176,6 @@ * * ***************************************************** -} -----------------wrongTyFamName :: Name -> Name -> SDoc-wrongTyFamName fam_tc_name eqn_tc_name- = hang (text "Mismatched type name in type family instance.")- 2 (vcat [ text "Expected:" <+> ppr fam_tc_name- , text " Actual:" <+> ppr eqn_tc_name ])- ----------------- rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars) rnConDecls = mapFvRn (wrapLocFstM rnConDecl)@@ -2128,7 +2183,7 @@ rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars) rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs , con_mb_cxt = mcxt, con_args = args- , con_doc = mb_doc })+ , con_doc = mb_doc, con_forall = forall }) = do { _ <- addLocM checkConName name ; new_name <- lookupLocatedTopBndrRn name ; mb_doc' <- rnMbLHsDoc mb_doc@@ -2155,11 +2210,12 @@ ; 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) }} rnConDecl decl@(ConDeclGADT { con_names = names- , con_forall = L _ explicit_forall+ , con_forall = forall@(L _ explicit_forall) , con_qvars = explicit_tkvs , con_mb_cxt = mcxt , con_args = args@@ -2197,7 +2253,8 @@ ; 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_doc = mb_doc'+ , con_forall = forall }, -- Remove when #18311 is fixed all_fvs) } } -- This case is only used for prefix GADT constructors generated by GHC's@@ -2211,7 +2268,7 @@ ; mb_doc' <- rnMbLHsDoc mb_doc ; let ctxt = ConDeclCtx new_names- ; (ty', fvs) <- rnHsSigType ctxt TypeLevel Nothing ty+ ; (ty', fvs) <- rnHsSigType ctxt TypeLevel ty ; linearTypes <- xopt LangExt.LinearTypes <$> getDynFlags -- Now that operator precedence has been resolved, we can split the@@ -2230,10 +2287,8 @@ -- Ensure that there are no nested `forall`s or contexts, per -- Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts) -- in GHC.Hs.Type.- ; whenIsJust (no_nested_foralls_contexts_err- (text "GADT constructor type signature")- res_ty) $ \(l, err_msg) ->- addErrAt l $ withHsDocContext ctxt err_msg+ ; addNoNestedForallsContextsErr ctxt+ (text "GADT constructor type signature") res_ty ; traceRn "rnConDecl (ConDeclGADTPrefixPs)" (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs)@@ -2270,41 +2325,6 @@ -- No need to check for duplicate fields -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn ; return (RecCon (L l new_fields), fvs) }---- | Examines a non-outermost type for @forall@s or contexts, which are assumed--- to be nested. Returns @'Just' err_msg@ if such a @forall@ or context is--- found, and returns @Nothing@ otherwise.------ This is currently used in two places:------ * In GADT constructor types (in 'rnConDecl').--- See @Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts)@--- in "GHC.Hs.Type".------ * In instance declaration types (in 'rnClsIntDecl' and 'rnSrcDerivDecl').--- See @Note [No nested foralls or contexts in instance types]@ in--- "GHC.Hs.Type".-no_nested_foralls_contexts_err :: SDoc -> LHsType GhcRn -> Maybe (SrcSpan, SDoc)-no_nested_foralls_contexts_err what lty =- case ignoreParens lty of- L l (HsForAllTy { hst_tele = tele })- | HsForAllVis{} <- tele- -- The only two places where this function is called correspond to- -- types of terms, so we give a slightly more descriptive error- -- message in the event that they contain visible dependent- -- quantification (currently only allowed in kinds).- -> Just (l, vcat [ text "Illegal visible, dependent quantification" <+>- text "in the type of a term"- , text "(GHC does not yet support this)" ])- | HsForAllInvis{} <- tele- -> Just (l, nested_foralls_contexts_err)- L l (HsQualTy {})- -> Just (l, nested_foralls_contexts_err)- _ -> Nothing- where- nested_foralls_contexts_err =- what <+> text "cannot contain nested"- <+> quotes forAllLit <> text "s or contexts" -------------------------------------------------
compiler/GHC/Rename/Names.hs view
@@ -385,7 +385,9 @@ warnUnqualifiedImport decl iface let new_imp_decl = L loc (decl { ideclExt = noExtField, ideclSafe = mod_safe'- , ideclHiding = new_imp_details })+ , ideclHiding = new_imp_details+ , ideclName = ideclName decl+ , ideclAs = ideclAs decl }) return (new_imp_decl, gbl_env, imports, mi_hpc iface) @@ -1232,11 +1234,11 @@ ********************************************************* -} -reportUnusedNames :: TcGblEnv -> RnM ()-reportUnusedNames gbl_env+reportUnusedNames :: TcGblEnv -> HscSource -> RnM ()+reportUnusedNames gbl_env hsc_src = do { keep <- readTcRef (tcg_keep gbl_env) ; traceRn "RUN" (ppr (tcg_dus gbl_env))- ; warnUnusedImportDecls gbl_env+ ; warnUnusedImportDecls gbl_env hsc_src ; warnUnusedTopBinds $ unused_locals keep ; warnMissingSignatures gbl_env } where@@ -1358,8 +1360,8 @@ , [GlobalRdrElt] -- What *is* used (normalised) , [Name] ) -- What is imported but *not* used -warnUnusedImportDecls :: TcGblEnv -> RnM ()-warnUnusedImportDecls gbl_env+warnUnusedImportDecls :: TcGblEnv -> HscSource -> RnM ()+warnUnusedImportDecls gbl_env hsc_src = do { uses <- readMutVar (tcg_used_gres gbl_env) ; let user_imports = filterOut (ideclImplicit . unLoc)@@ -1381,7 +1383,7 @@ mapM_ (warnUnusedImport Opt_WarnUnusedImports fld_env) usage ; whenGOptM Opt_D_dump_minimal_imports $- printMinimalImports usage }+ printMinimalImports hsc_src usage } findImportUsage :: [LImportDecl GhcRn] -> [GlobalRdrElt]@@ -1393,6 +1395,7 @@ import_usage :: ImportMap import_usage = mkImportMap used_gres + unused_decl :: LImportDecl GhcRn -> (LImportDecl GhcRn, [GlobalRdrElt], [Name]) unused_decl decl@(L loc (ImportDecl { ideclHiding = imps })) = (decl, used_gres, nameSetElemsStable unused_imps) where@@ -1616,9 +1619,9 @@ all_non_overloaded = all (not . flIsOverloaded) -printMinimalImports :: [ImportDeclUsage] -> RnM ()+printMinimalImports :: HscSource -> [ImportDeclUsage] -> RnM () -- See Note [Printing minimal imports]-printMinimalImports imports_w_usage+printMinimalImports hsc_src imports_w_usage = do { imports' <- getMinimalImports imports_w_usage ; this_mod <- getModule ; dflags <- getDynFlags@@ -1635,7 +1638,11 @@ | Just d <- dumpDir dflags = d </> basefn | otherwise = basefn where- basefn = moduleNameString (moduleName this_mod) ++ ".imports"+ suffix = case hsc_src of+ HsBootFile -> ".imports-boot"+ HsSrcFile -> ".imports"+ HsigFile -> ".imports"+ basefn = moduleNameString (moduleName this_mod) ++ suffix to_ie_post_rn_var :: (HasOccName name) => Located name -> LIEWrappedName name
compiler/GHC/Rename/Pat.hs view
@@ -236,19 +236,30 @@ do { name <- case is_top of NotTopLevel -> newLocalBndrRn rdr_name TopLevel -> newTopSrcBinder rdr_name- ; bindLocalNames [name] $ -- Do *not* use bindLocalNameFV here- -- See Note [View pattern usage]+ ; bindLocalNames [name] $+ -- Do *not* use bindLocalNameFV here;+ -- see Note [View pattern usage]+ -- For the TopLevel case+ -- see Note [bindLocalNames for an External name] addLocalFixities fix_env [name] $ thing_inside name }) - -- Note: the bindLocalNames is somewhat suspicious- -- because it binds a top-level name as a local name.- -- however, this binding seems to work, and it only exists for- -- the duration of the patterns and the continuation;- -- then the top-level name is added to the global env- -- before going on to the RHSes (see GHC.Rename.Module).+{- Note [bindLocalNames for an External name]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the TopLevel case, the use of bindLocalNames here is somewhat+suspicious because it binds a top-level External name in the+LocalRdrEnv. c.f. Note [LocalRdrEnv] in GHC.Types.Name.Reader. -{-+However, this only happens when renaming the LHS (only) of a top-level+pattern binding. Even though this only the LHS, we need to bring the+binder into scope in the pattern itself in case the binder is used in+subsequent view patterns. A bit bizarre, something like+ (x, Just y <- f x) = e++Anyway, bindLocalNames does work, and the binding only exists for the+duration of the pattern; then the top-level name is added to the+global env before going on to the RHSes (see GHC.Rename.Module).+ Note [View pattern usage] ~~~~~~~~~~~~~~~~~~~~~~~~~ Consider@@ -412,7 +423,7 @@ ; return (SigPat x pat' sig' ) } where rnHsPatSigTypeAndThen :: HsPatSigType GhcPs -> CpsRn (HsPatSigType GhcRn)- rnHsPatSigTypeAndThen sig = CpsRn (rnHsPatSigType AlwaysBind PatCtx Nothing sig)+ rnHsPatSigTypeAndThen sig = CpsRn (rnHsPatSigType AlwaysBind PatCtx sig) rnPatAndThen mk (LitPat x lit) | HsString src s <- lit
compiler/GHC/Rename/Splice.hs view
@@ -111,6 +111,8 @@ False -> do { traceRn "Renaming untyped TH bracket" empty ; ps_var <- newMutVar [] ; (body', fvs_e) <-+ -- See Note [Rebindable syntax and Template Haskell]+ unsetXOptM LangExt.RebindableSyntax $ setStage (Brack cur_stage (RnPendingUntyped ps_var)) $ rn_bracket cur_stage br_body ; pendings <- readMutVar ps_var@@ -489,6 +491,67 @@ expressions before splicy expressions, b) explain to TH users which expressions are/not available to reify at any given point.++-}++{- Note [Rebindable syntax and Template Haskell]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When processing Template Haskell quotes with Rebindable Syntax (RS) enabled,+there are two possibilities: apply the RS rules to the quotes or don't.++One might expect that with {-# LANGUAGE RebindableSyntax #-} at the top of a+module, any 'if' expression would end up being turned into a call to whatever+'ifThenElse' function is in scope, regardless of whether the said if expression+appears in "normal" Haskell code or in a TH quote. This however comes with its+problems. Consider the following code:++ {-# LANGUAGE TemplateHaskell, RebindableSyntax #-}++ module X where++ import Prelude ( Monad(..), Bool(..), print, ($) )+ import Language.Haskell.TH.Syntax++ $( do stuff <- [| if True then 10 else 15 |]+ runIO $ print stuff+ return [] )++If we apply the RS rules, then GHC would complain about not having suitable+fromInteger/ifThenElse functions in scope. But this quote is just a bit of+Haskell syntax that has yet to be used, or, to put it differently, placed+(spliced) in some context where the said functions might be available. More+generally, untyped TH quotes are meant to work with yet-unbound identifiers.+This tends to show that untyped TH and Rebindable Syntax overall don't play+well together. Users still have the option to splice "normal" if expressions+into modules where RS is enabled, to turn them into applications of+an 'ifThenElse' function of their choice.++Typed TH (TTH) quotes, on the other hand, come with different constraints. They+don't quite have this "delayed" nature: we typecheck them while processing+them, and TTH users expect RS to Just Work in their quotes, exactly like it does+outside of the quotes. There, we do not have to accept unbound identifiers and+we can apply the RS rules both in the typechecking and desugaring of the quotes+without triggering surprising/bad behaviour for users. For instance, the+following code is expected to be rejected (because of the lack of suitable+'fromInteger'/'ifThenElse' functions in scope):++ {-# LANGUAGE TemplateHaskell, RebindableSyntax #-}++ module X where++ import Prelude ( Monad(..), Bool(..), print, ($) )+ import Language.Haskell.TH.Syntax++ $$( do stuff <- [|| if True then 10 else 15 ||]+ runIO $ print stuff+ return [] )++The conclusion is that even if RS is enabled for a given module, GHC disables it+when processing untyped TH quotes from that module, to avoid the aforementioned+problems, but keeps it on while processing typed TH quotes.++This note and approach originated in #18102. -}
compiler/GHC/Rename/Utils.hs view
@@ -26,8 +26,10 @@ bindLocalNames, bindLocalNamesFV, - addNameClashErrRn, extendTyVarEnvFVRn+ addNameClashErrRn, extendTyVarEnvFVRn, + checkInferredVars,+ noNestedForallsContextsErr, addNoNestedForallsContextsErr ) where@@ -35,6 +37,7 @@ import GHC.Prelude +import GHC.Core.Type import GHC.Hs import GHC.Types.Name.Reader import GHC.Driver.Types@@ -49,6 +52,7 @@ import GHC.Utils.Misc import GHC.Types.Basic ( TopLevelFlag(..) ) import GHC.Data.List.SetOps ( removeDups )+import GHC.Data.Maybe ( whenIsJust ) import GHC.Driver.Session import GHC.Data.FastString import Control.Monad@@ -176,6 +180,136 @@ || xopt LangExt.RecordWildCards dflags) } is_shadowed_gre _other = return True +-------------------------------------+-- | Throw an error message if a user attempts to quantify an inferred type+-- variable in a place where specificity cannot be observed. For example,+-- @forall {a}. [a] -> [a]@ would be rejected to the inferred type variable+-- @{a}@, but @forall a. [a] -> [a]@ would be accepted.+-- See @Note [Unobservably inferred type variables]@.+checkInferredVars :: HsDocContext+ -> Maybe SDoc+ -- ^ The error msg if the signature is not allowed to contain+ -- manually written inferred variables.+ -> LHsSigType GhcPs+ -> RnM ()+checkInferredVars _ Nothing _ = return ()+checkInferredVars ctxt (Just msg) ty =+ let bndrs = forallty_bndrs (hsSigType ty)+ in case find ((==) InferredSpec . hsTyVarBndrFlag) bndrs of+ Nothing -> return ()+ Just _ -> addErr $ withHsDocContext ctxt msg+ where+ forallty_bndrs :: LHsType GhcPs -> [HsTyVarBndr Specificity GhcPs]+ forallty_bndrs (L _ ty) = case ty of+ HsParTy _ ty' -> forallty_bndrs ty'+ HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = tvs }}+ -> map unLoc tvs+ _ -> []++{-+Note [Unobservably inferred type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+While GHC's parser allows the use of inferred type variables+(e.g., `forall {a}. <...>`) just about anywhere that type variable binders can+appear, there are some situations where the distinction between inferred and+specified type variables cannot be observed. For example, consider this+instance declaration:++ instance forall {a}. Eq (T a) where ...++Making {a} inferred is pointless, as there is no way for user code to+"apply" an instance declaration in a way where the inferred/specified+distinction would make a difference. (Notably, there is no opportunity+for visible type application of an instance declaration.) Anyone who+writes such code is likely confused, so in an attempt to be helpful,+we emit an error message if a user writes code like this. The+checkInferredVars function is responsible for implementing this+restriction.++It turns out to be somewhat cumbersome to enforce this restriction in+certain cases. Specifically:++* Quantified constraints. In the type `f :: (forall {a}. C a) => Proxy Int`,+ there is no way to observe that {a} is inferred. Nevertheless, actually+ rejecting this code would be tricky, as we would need to reject+ `forall {a}. <...>` as a constraint but *accept* other uses of+ `forall {a}. <...>` as a type (e.g., `g :: (forall {a}. a -> a) -> b -> b`).+ This is quite tedious to do in practice, so we don't bother.++* Default method type signatures (#18432). These are tricky because inferred+ type variables can appear nested, e.g.,++ class C a where+ m :: forall b. a -> b -> forall c. c -> c+ default m :: forall b. a -> b -> forall {c}. c -> c+ m _ _ = id++ Robustly checking for nested, inferred type variables ends up being a pain,+ so we don't try to do this.++For now, we simply allow inferred quantifiers to be specified here,+even though doing so is pointless. All we lose is a warning.++Aside from the places where we already use checkInferredVars, most of+the other places where inferred vars don't make sense are in any case+already prohibited from having foralls /at all/. For example:++ instance forall a. forall {b}. Eq (Either a b) where ...++Here the nested `forall {b}` is already prohibited. (See+Note [No nested foralls or contexts in instance types] in GHC.Hs.Type).+-}++-- | Examines a non-outermost type for @forall@s or contexts, which are assumed+-- to be nested. For example, in the following declaration:+--+-- @+-- instance forall a. forall b. C (Either a b)+-- @+--+-- The outermost @forall a@ is fine, but the nested @forall b@ is not. We+-- invoke 'noNestedForallsContextsErr' on the type @forall b. C (Either a b)@+-- to catch the nested @forall@ and create a suitable error message.+-- 'noNestedForallsContextsErr' returns @'Just' err_msg@ if such a @forall@ or+-- context is found, and returns @Nothing@ otherwise.+--+-- This is currently used in the following places:+--+-- * In GADT constructor types (in 'rnConDecl').+-- See @Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts)@+-- in "GHC.Hs.Type".+--+-- * In instance declaration types (in 'rnClsIntDecl' and 'rnSrcDerivDecl' in+-- "GHC.Rename.Module" and 'renameSig' in "GHC.Rename.Bind").+-- See @Note [No nested foralls or contexts in instance types]@ in+-- "GHC.Hs.Type".+noNestedForallsContextsErr :: SDoc -> LHsType GhcRn -> Maybe (SrcSpan, SDoc)+noNestedForallsContextsErr what lty =+ case ignoreParens lty of+ L l (HsForAllTy { hst_tele = tele })+ | HsForAllVis{} <- tele+ -- The only two places where this function is called correspond to+ -- types of terms, so we give a slightly more descriptive error+ -- message in the event that they contain visible dependent+ -- quantification (currently only allowed in kinds).+ -> Just (l, vcat [ text "Illegal visible, dependent quantification" <+>+ text "in the type of a term"+ , text "(GHC does not yet support this)" ])+ | HsForAllInvis{} <- tele+ -> Just (l, nested_foralls_contexts_err)+ L l (HsQualTy {})+ -> Just (l, nested_foralls_contexts_err)+ _ -> Nothing+ where+ nested_foralls_contexts_err =+ what <+> text "cannot contain nested"+ <+> quotes forAllLit <> text "s or contexts"++-- | A common way to invoke 'noNestedForallsContextsErr'.+addNoNestedForallsContextsErr :: HsDocContext -> SDoc -> LHsType GhcRn -> RnM ()+addNoNestedForallsContextsErr ctxt what lty =+ whenIsJust (noNestedForallsContextsErr what lty) $ \(l, err_msg) ->+ addErrAt l $ withHsDocContext ctxt err_msg {- ************************************************************************
compiler/GHC/Runtime/Eval.hs view
@@ -1256,7 +1256,7 @@ withSession $ \hsc_env -> do interpreted <- moduleIsBootOrNotObjectLinkable mod_summary let dflags = hsc_dflags hsc_env- return (showModMsg dflags (hscTarget dflags) interpreted mod_summary)+ return (showModMsg dflags interpreted mod_summary) moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env ->
compiler/GHC/Runtime/Heap/Inspect.hs view
@@ -870,20 +870,21 @@ (error "unboxedTupleTerm: no HValue for unboxed tuple") terms -- Extract a sub-word sized field from a word- index item_size_b index_b word_size endian =- (word .&. (mask `shiftL` moveBytes)) `shiftR` moveBytes- where- mask :: Word- mask = case item_size_b of- 1 -> 0xFF- 2 -> 0xFFFF- 4 -> 0xFFFFFFFF- _ -> panic ("Weird byte-index: " ++ show index_b)- (q,r) = index_b `quotRem` word_size- word = array!!q- moveBytes = case endian of- BigEndian -> word_size - (r + item_size_b) * 8- LittleEndian -> r * 8+ -- A sub word is aligned to the left-most part of a word on big-endian+ -- platforms, and to the right-most part of a word on little-endian+ -- platforms. This allows to write and read it back from memory+ -- independent of endianness. Bits not belonging to a sub word are zeroed+ -- out, although, this is strictly speaking not necessary since a sub word+ -- is read back from memory by appropriately casted pointers (see e.g.+ -- ppr_float of cPprTermBase).+ index size_b aligned_idx word_size endian = case endian of+ BigEndian -> (word `shiftL` moveBits) `shiftR` zeroOutBits `shiftL` zeroOutBits+ LittleEndian -> (word `shiftR` moveBits) `shiftL` zeroOutBits `shiftR` zeroOutBits+ where+ (q, r) = aligned_idx `quotRem` word_size+ word = array!!q+ moveBits = r * 8+ zeroOutBits = (word_size - size_b) * 8 -- | Fast, breadth-first Type reconstruction
compiler/GHC/Runtime/Interpreter.hs view
@@ -79,7 +79,7 @@ #if defined(HAVE_INTERNAL_INTERPRETER) import GHCi.Run-import GHC.Driver.Ways+import GHC.Platform.Ways #endif import Control.Concurrent
compiler/GHC/Runtime/Linker.hs view
@@ -43,7 +43,7 @@ import GHC.Driver.Phases import GHC.Driver.Finder import GHC.Driver.Types-import GHC.Driver.Ways+import GHC.Platform.Ways import GHC.Types.Name import GHC.Types.Name.Env import GHC.Unit.Module@@ -1323,8 +1323,8 @@ all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env - maybePutStr dflags- ("Loading package " ++ unitPackageIdString pkg ++ " ... ")+ maybePutSDoc dflags+ (text "Loading unit " <> pprUnitInfoForUser pkg <> text " ... ") -- See comments with partOfGHCi #if defined(CAN_LOAD_DLL)@@ -1354,9 +1354,9 @@ if succeeded ok then maybePutStrLn dflags "done."- else let errmsg = "unable to load package `"- ++ unitPackageIdString pkg ++ "'"- in throwGhcExceptionIO (InstallationError errmsg)+ else let errmsg = text "unable to load unit `"+ <> pprUnitInfoForUser pkg <> text "'"+ in throwGhcExceptionIO (InstallationError (showSDoc dflags errmsg)) {- Note [Crash early load_dyn and locateLib]@@ -1695,6 +1695,38 @@ -- ---------------------------------------------------------------------------- -- Loading a dynamic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32) +{-+Note [macOS Big Sur dynamic libraries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++macOS Big Sur makes the following change to how frameworks are shipped+with the OS:++> New in macOS Big Sur 11 beta, the system ships with a built-in+> dynamic linker cache of all system-provided libraries. As part of+> this change, copies of dynamic libraries are no longer present on+> the filesystem. Code that attempts to check for dynamic library+> presence by looking for a file at a path or enumerating a directory+> will fail. Instead, check for library presence by attempting to+> dlopen() the path, which will correctly check for the library in the+> cache. (62986286)++(https://developer.apple.com/documentation/macos-release-notes/macos-big-sur-11-beta-release-notes/)++Therefore, the previous method of checking whether a library exists+before attempting to load it makes GHC.Runtime.Linker.loadFramework+fail to find frameworks installed at /System/Library/Frameworks.+Instead, any attempt to load a framework at runtime, such as by+passing -framework OpenGL to runghc or running code loading such a+framework with GHCi, fails with a 'not found' message.++GHC.Runtime.Linker.loadFramework now opportunistically loads the+framework libraries without checking for their existence first,+failing only if all attempts to load a given framework from any of the+various possible locations fail. See also #18446, which this change+addresses.+-}+ -- Darwin / MacOS X only: load a framework -- a framework is a dynamic library packaged inside a directory of the same -- name. They are searched for in different paths than normal libraries.@@ -1705,31 +1737,46 @@ Left _ -> [] Right dir -> [dir </> "Library/Frameworks"] ps = extraPaths ++ homeFrameworkPath ++ defaultFrameworkPaths- ; mb_fwk <- findFile ps fwk_file- ; case mb_fwk of- Just fwk_path -> loadDLL hsc_env fwk_path- Nothing -> return (Just "not found") }- -- Tried all our known library paths, but dlopen()- -- has no built-in paths for frameworks: give up+ ; errs <- findLoadDLL ps []+ ; return $ fmap (intercalate ", ") errs+ } where fwk_file = rootname <.> "framework" </> rootname- -- sorry for the hardcoded paths, I hope they won't change anytime soon:++ -- sorry for the hardcoded paths, I hope they won't change anytime soon: defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"] + -- Try to call loadDLL for each candidate path.+ --+ -- See Note [macOS Big Sur dynamic libraries]+ findLoadDLL [] errs =+ -- Tried all our known library paths, but dlopen()+ -- has no built-in paths for frameworks: give up+ return $ Just errs+ findLoadDLL (p:ps) errs =+ do { dll <- loadDLL hsc_env (p </> fwk_file)+ ; case dll of+ Nothing -> return Nothing+ Just err -> findLoadDLL ps ((p ++ ": " ++ err):errs)+ }+ {- ********************************************************************** Helper functions ********************************************************************* -} -maybePutStr :: DynFlags -> String -> IO ()-maybePutStr dflags s+maybePutSDoc :: DynFlags -> SDoc -> IO ()+maybePutSDoc dflags s = when (verbosity dflags > 1) $ putLogMsg dflags NoReason SevInteractive noSrcSpan- $ withPprStyle defaultUserStyle (text s)+ $ withPprStyle defaultUserStyle s++maybePutStr :: DynFlags -> String -> IO ()+maybePutStr dflags s = maybePutSDoc dflags (text s) maybePutStrLn :: DynFlags -> String -> IO () maybePutStrLn dflags s = maybePutStr dflags (s ++ "\n")
compiler/GHC/Settings/IO.hs view
@@ -11,7 +11,6 @@ import GHC.Prelude -import GHC.Settings.Platform import GHC.Settings.Utils import GHC.Settings.Config@@ -71,12 +70,12 @@ -- just partially applying those functions and throwing 'Left's; they're -- written in a very portable style to keep ghc-boot light. let getSetting key = either pgmError pure $- getFilePathSetting0 top_dir settingsFile mySettings key+ getRawFilePathSetting top_dir settingsFile mySettings key getToolSetting :: String -> ExceptT SettingsError m String getToolSetting key = expandToolDir mtool_dir <$> getSetting key getBooleanSetting :: String -> ExceptT SettingsError m Bool getBooleanSetting key = either pgmError pure $- getBooleanSetting0 settingsFile mySettings key+ getRawBooleanSetting settingsFile mySettings key targetPlatformString <- getSetting "target platform string" myExtraGccViaCFlags <- getSetting "GCC extra via C opts" -- On Windows, mingw is distributed with GHC,@@ -92,7 +91,7 @@ cpp_prog <- getToolSetting "Haskell CPP command" cpp_args_str <- getSetting "Haskell CPP flags" - platform <- either pgmError pure $ getTargetPlatform settingsFile mySettings+ platform <- either pgmError pure $ getTargetPlatform settingsFile mySettings platformConstants let unreg_cc_args = if platformUnregisterised platform then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]@@ -149,7 +148,6 @@ let iserv_prog = libexec "ghc-iserv" ghcWithInterpreter <- getBooleanSetting "Use interpreter"- ghcWithNativeCodeGen <- getBooleanSetting "Use native code generator" ghcWithSMP <- getBooleanSetting "Support SMP" ghcRTSWays <- getSetting "RTS ways" useLibFFI <- getBooleanSetting "Use LibFFI"@@ -216,7 +214,6 @@ , sPlatformMisc = PlatformMisc { platformMisc_targetPlatformString = targetPlatformString , platformMisc_ghcWithInterpreter = ghcWithInterpreter- , platformMisc_ghcWithNativeCodeGen = ghcWithNativeCodeGen , platformMisc_ghcWithSMP = ghcWithSMP , platformMisc_ghcRTSWays = ghcRTSWays , platformMisc_libFFI = useLibFFI@@ -229,4 +226,40 @@ , sPlatformConstants = platformConstants , sRawSettings = settingsList+ }++getTargetPlatform+ :: FilePath -- ^ Settings filepath (for error messages)+ -> RawSettings -- ^ Raw settings file contents+ -> PlatformConstants -- ^ Platform constants+ -> Either String Platform+getTargetPlatform settingsFile settings constants = do+ let+ getBooleanSetting = getRawBooleanSetting settingsFile settings+ readSetting :: (Show a, Read a) => String -> Either String a+ readSetting = readRawSetting settingsFile settings++ targetArchOS <- getTargetArchOS settingsFile settings+ targetWordSize <- readSetting "target word size"+ targetWordBigEndian <- getBooleanSetting "target word big endian"+ targetLeadingUnderscore <- getBooleanSetting "Leading underscore"+ targetUnregisterised <- getBooleanSetting "Unregisterised"+ targetHasGnuNonexecStack <- getBooleanSetting "target has GNU nonexec stack"+ targetHasIdentDirective <- getBooleanSetting "target has .ident directive"+ targetHasSubsectionsViaSymbols <- getBooleanSetting "target has subsections via symbols"+ crossCompiling <- getBooleanSetting "cross compiling"+ tablesNextToCode <- getBooleanSetting "Tables next to code"++ pure $ Platform+ { platformArchOS = targetArchOS+ , platformWordSize = targetWordSize+ , platformByteOrder = if targetWordBigEndian then BigEndian else LittleEndian+ , platformUnregisterised = targetUnregisterised+ , platformHasGnuNonexecStack = targetHasGnuNonexecStack+ , platformHasIdentDirective = targetHasIdentDirective+ , platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols+ , platformIsCrossCompiling = crossCompiling+ , platformLeadingUnderscore = targetLeadingUnderscore+ , platformTablesNextToCode = tablesNextToCode+ , platformConstants = constants }
compiler/GHC/Stg/DepAnal.hs view
@@ -14,6 +14,7 @@ import GHC.Unit.Module (Module) import Data.Graph (SCC (..))+import Data.Bifunctor (first) -------------------------------------------------------------------------------- -- * Dependency analysis@@ -90,7 +91,7 @@ expr bounds (StgOpApp _ as _) = args bounds as expr _ lam@StgLam{} =- pprPanic "annTopBindingsDeps" (text "Found lambda:" $$ ppr lam)+ pprPanic "annTopBindingsDeps" (text "Found lambda:" $$ pprStgExpr panicStgPprOpts lam) expr bounds (StgCase scrut scrut_bndr _ as) = expr bounds scrut `unionVarSet` alts (extendVarSet bounds scrut_bndr) as@@ -141,4 +142,6 @@ get_binds (AcyclicSCC bind) = [bind] get_binds (CyclicSCC binds) =- pprPanic "depSortStgBinds" (text "Found cyclic SCC:" $$ ppr binds)+ pprPanic "depSortStgBinds"+ (text "Found cyclic SCC:"+ $$ ppr (map (first (pprStgTopBinding panicStgPprOpts)) binds))
compiler/GHC/Stg/Lift.hs view
@@ -199,7 +199,7 @@ -> LlStgRhs -> LiftM OutStgRhs liftRhs mb_former_fvs rhs@(StgRhsCon ccs con args)- = ASSERT2(isNothing mb_former_fvs, text "Should never lift a constructor" $$ ppr rhs)+ = 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 -- This RHS wasn't lifted.
compiler/GHC/Stg/Lift/Analysis.hs view
@@ -21,7 +21,9 @@ ) where import GHC.Prelude+ import GHC.Platform+import GHC.Platform.Profile import GHC.Types.Basic import GHC.Types.Demand@@ -375,7 +377,8 @@ , ("args spill on stack", args_spill_on_stack) , ("increases allocation", inc_allocs) ] where- platform = targetPlatform dflags+ profile = targetProfile dflags+ platform = profilePlatform profile decide deciders | not (fancy_or deciders) = llTrace "stgLiftLams:lifting"@@ -472,7 +475,7 @@ -- GHC does not currently share closure environments, and we either lift -- the entire recursive binding group or none of it. closuresSize = sum $ flip map rhss $ \rhs ->- closureSize dflags+ closureSize profile . dVarSetElems . expander . flip dVarSetMinusVarSet bndrs_set@@ -485,14 +488,14 @@ -- | The size in words of a function closure closing over the given 'Id's, -- including the header.-closureSize :: DynFlags -> [Id] -> WordOff-closureSize dflags ids = words + sTD_HDR_SIZE dflags+closureSize :: Profile -> [Id] -> WordOff+closureSize profile ids = words + pc_STD_HDR_SIZE (platformConstants (profilePlatform profile)) -- We go through sTD_HDR_SIZE rather than fixedHdrSizeW so that we don't -- optimise differently when profiling is enabled. where (words, _, _) -- Functions have a StdHeader (as opposed to ThunkHeader).- = StgToCmm.Layout.mkVirtHeapOffsets dflags StgToCmm.Layout.StdHeader+ = StgToCmm.Layout.mkVirtHeapOffsets profile StgToCmm.Layout.StdHeader . StgToCmm.Closure.addIdReps . StgToCmm.Closure.nonVoidIds $ ids
compiler/GHC/Stg/Lint.hs view
@@ -70,7 +70,7 @@ lintStgTopBindings dflags this_mod unarised whodunnit binds = {-# SCC "StgLint" #-}- case initL this_mod unarised top_level_binds (lint_binds binds) of+ case initL this_mod unarised opts top_level_binds (lint_binds binds) of Nothing -> return () Just msg -> do@@ -80,10 +80,11 @@ text whodunnit <+> text "***", msg, text "*** Offending Program ***",- pprGenStgTopBindings binds,+ pprGenStgTopBindings opts binds, text "*** End of Offense ***"]) Err.ghcExit dflags 1 where+ opts = initStgPprOpts dflags -- Bring all top-level binds into scope because CoreToStg does not generate -- bindings in dependency order (so we may see a use before its definition). top_level_binds = mkVarSet (bindersOfTopBinds binds)@@ -129,9 +130,10 @@ = addLoc (RhsOf binder) $ do when (isTopLevel top_lvl) (checkNoCurrentCCS rhs) lintStgRhs rhs+ opts <- getStgPprOpts -- Check binder doesn't have unlifted type or it's a join point checkL (isJoinId binder || not (isUnliftedType (idType binder)))- (mkUnliftedTyMsg binder rhs)+ (mkUnliftedTyMsg opts binder rhs) -- | Top-level bindings can't inherit the cost centre stack from their -- (static) allocation site.@@ -139,14 +141,17 @@ :: (OutputablePass a, BinderP a ~ Id) => GenStgRhs a -> LintM ()-checkNoCurrentCCS rhs@(StgRhsClosure _ ccs _ _ _)- | isCurrentCCS ccs- = addErrL (text "Top-level StgRhsClosure with CurrentCCS" $$ ppr rhs)-checkNoCurrentCCS rhs@(StgRhsCon ccs _ _)- | isCurrentCCS ccs- = addErrL (text "Top-level StgRhsCon with CurrentCCS" $$ ppr rhs)-checkNoCurrentCCS _- = return ()+checkNoCurrentCCS rhs = do+ opts <- getStgPprOpts+ let rhs' = pprStgRhs opts rhs+ case rhs of+ StgRhsClosure _ ccs _ _ _+ | isCurrentCCS ccs+ -> addErrL (text "Top-level StgRhsClosure with CurrentCCS" $$ rhs')+ StgRhsCon ccs _ _+ | isCurrentCCS ccs+ -> addErrL (text "Top-level StgRhsCon with CurrentCCS" $$ rhs')+ _ -> return () lintStgRhs :: (OutputablePass a, BinderP a ~ Id) => GenStgRhs a -> LintM () @@ -159,9 +164,10 @@ lintStgExpr expr lintStgRhs rhs@(StgRhsCon _ con args) = do- when (isUnboxedTupleCon con || isUnboxedSumCon con) $+ when (isUnboxedTupleCon con || isUnboxedSumCon con) $ do+ opts <- getStgPprOpts addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$- ppr rhs)+ pprStgRhs opts rhs) mapM_ lintStgArg args mapM_ checkPostUnariseConArg args @@ -176,17 +182,19 @@ lintStgExpr app@(StgConApp con args _arg_tys) = do -- unboxed sums should vanish during unarise lf <- getLintFlags- when (lf_unarised lf && isUnboxedSumCon con) $+ when (lf_unarised lf && isUnboxedSumCon con) $ do+ opts <- getStgPprOpts addErrL (text "Unboxed sum after unarise:" $$- ppr app)+ pprStgExpr opts app) mapM_ lintStgArg args mapM_ checkPostUnariseConArg args lintStgExpr (StgOpApp _ args _) = mapM_ lintStgArg args -lintStgExpr lam@(StgLam _ _) =- addErrL (text "Unexpected StgLam" <+> ppr lam)+lintStgExpr lam@(StgLam _ _) = do+ opts <- getStgPprOpts+ addErrL (text "Unexpected StgLam" <+> pprStgExpr opts lam) lintStgExpr (StgLet _ binds body) = do binders <- lintStgBinds NotTopLevel binds@@ -235,6 +243,7 @@ newtype LintM a = LintM { unLintM :: Module -> LintFlags+ -> StgPprOpts -- Pretty-printing options -> [LintLocInfo] -- Locations -> IdSet -- Local vars in scope -> Bag MsgDoc -- Error messages so far@@ -268,16 +277,16 @@ pp_binder b = hsep [ppr b, dcolon, ppr (idType b)] -initL :: Module -> Bool -> IdSet -> LintM a -> Maybe MsgDoc-initL this_mod unarised locals (LintM m) = do- let (_, errs) = m this_mod (LintFlags unarised) [] locals emptyBag+initL :: Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe MsgDoc+initL this_mod unarised opts locals (LintM m) = do+ let (_, errs) = m this_mod (LintFlags unarised) opts [] locals emptyBag if isEmptyBag errs then Nothing else Just (vcat (punctuate blankLine (bagToList errs))) instance Applicative LintM where- pure a = LintM $ \_mod _lf _loc _scope errs -> (a, errs)+ pure a = LintM $ \_mod _lf _opts _loc _scope errs -> (a, errs) (<*>) = ap (*>) = thenL_ @@ -286,14 +295,14 @@ (>>) = (*>) thenL :: LintM a -> (a -> LintM b) -> LintM b-thenL m k = LintM $ \mod lf loc scope errs- -> case unLintM m mod lf loc scope errs of- (r, errs') -> unLintM (k r) mod lf loc scope errs'+thenL m k = LintM $ \mod lf opts loc scope errs+ -> case unLintM m mod lf opts loc scope errs of+ (r, errs') -> unLintM (k r) mod lf opts loc scope errs' thenL_ :: LintM a -> LintM b -> LintM b-thenL_ m k = LintM $ \mod lf loc scope errs- -> case unLintM m mod lf loc scope errs of- (_, errs') -> unLintM k mod lf loc scope errs'+thenL_ m k = LintM $ \mod lf opts loc scope errs+ -> case unLintM m mod lf opts loc scope errs of+ (_, errs') -> unLintM k mod lf opts loc scope errs' checkL :: Bool -> MsgDoc -> LintM () checkL True _ = return ()@@ -338,7 +347,7 @@ is_sum <|> is_tuple <|> is_void addErrL :: MsgDoc -> LintM ()-addErrL msg = LintM $ \_mod _lf loc _scope errs -> ((), addErr errs msg loc)+addErrL msg = LintM $ \_mod _lf _opts loc _scope errs -> ((), addErr errs msg loc) addErr :: Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc addErr errs_so_far msg locs@@ -349,29 +358,32 @@ mk_msg [] = msg addLoc :: LintLocInfo -> LintM a -> LintM a-addLoc extra_loc m = LintM $ \mod lf loc scope errs- -> unLintM m mod lf (extra_loc:loc) scope errs+addLoc extra_loc m = LintM $ \mod lf opts loc scope errs+ -> unLintM m mod lf opts (extra_loc:loc) scope errs addInScopeVars :: [Id] -> LintM a -> LintM a-addInScopeVars ids m = LintM $ \mod lf loc scope errs+addInScopeVars ids m = LintM $ \mod lf opts loc scope errs -> let new_set = mkVarSet ids- in unLintM m mod lf loc (scope `unionVarSet` new_set) errs+ in unLintM m mod lf opts loc (scope `unionVarSet` new_set) errs getLintFlags :: LintM LintFlags-getLintFlags = LintM $ \_mod lf _loc _scope errs -> (lf, errs)+getLintFlags = LintM $ \_mod lf _opts _loc _scope errs -> (lf, errs) +getStgPprOpts :: LintM StgPprOpts+getStgPprOpts = LintM $ \_mod _lf opts _loc _scope errs -> (opts, errs)+ checkInScope :: Id -> LintM ()-checkInScope id = LintM $ \mod _lf loc scope errs+checkInScope id = LintM $ \mod _lf _opts loc scope errs -> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then ((), addErr errs (hsep [ppr id, dcolon, ppr (idType id), text "is out of scope"]) loc) else ((), errs) -mkUnliftedTyMsg :: OutputablePass a => Id -> GenStgRhs a -> SDoc-mkUnliftedTyMsg binder rhs+mkUnliftedTyMsg :: OutputablePass a => StgPprOpts -> Id -> GenStgRhs a -> SDoc+mkUnliftedTyMsg opts binder rhs = (text "Let(rec) binder" <+> quotes (ppr binder) <+> text "has unlifted type" <+> quotes (ppr (idType binder))) $$- (text "RHS:" <+> ppr rhs)+ (text "RHS:" <+> pprStgRhs opts rhs)
compiler/GHC/Stg/Pipeline.hs view
@@ -103,13 +103,14 @@ liftIO (stg_linter True "Unarise" binds') return binds' + opts = initStgPprOpts dflags dump_when flag header binds- = dumpIfSet_dyn dflags flag header FormatSTG (pprStgTopBindings binds)+ = dumpIfSet_dyn dflags flag header FormatSTG (pprStgTopBindings opts binds) end_pass what binds2 = liftIO $ do -- report verbosely, if required dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what- FormatSTG (vcat (map ppr binds2))+ FormatSTG (vcat (map (pprStgTopBinding opts) binds2)) stg_linter False what binds2 return binds2
compiler/GHC/Stg/Unarise.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE FlexibleContexts #-}+ {- (c) The GRASP/AQUA Project, Glasgow University, 1992-2012 @@ -315,7 +317,7 @@ f' = case lookupVarEnv rho f of Just (UnaryVal (StgVarArg f')) -> f' Nothing -> f- err -> pprPanic "unariseExpr - app2" (ppr e $$ ppr err)+ err -> pprPanic "unariseExpr - app2" (pprStgExpr panicStgPprOpts e $$ ppr err) -- Can't happen because 'args' is non-empty, and -- a tuple or sum cannot be applied to anything @@ -334,7 +336,7 @@ = return (StgOpApp op (unariseFunArgs rho args) ty) unariseExpr _ e@StgLam{}- = pprPanic "unariseExpr: found lambda" (ppr e)+ = pprPanic "unariseExpr: found lambda" (pprStgExpr panicStgPprOpts e) unariseExpr rho (StgCase scrut bndr alt_ty alts) -- tuple/sum binders in the scrutinee can always be eliminated@@ -412,7 +414,7 @@ elimCase _ args bndr alt_ty alts = pprPanic "elimCase - unhandled case"- (ppr args <+> ppr bndr <+> ppr alt_ty $$ ppr alts)+ (ppr args <+> ppr bndr <+> ppr alt_ty $$ pprPanicAlts alts) -------------------------------------------------------------------------------- @@ -433,7 +435,7 @@ unariseAlts _ (MultiValAlt _) bndr alts | isUnboxedTupleBndr bndr- = pprPanic "unariseExpr: strange multi val alts" (ppr alts)+ = pprPanic "unariseExpr: strange multi val alts" (pprPanicAlts alts) -- In this case we don't need to scrutinize the tag bit unariseAlts rho (MultiValAlt _) bndr [(DEFAULT, _, rhs)]@@ -484,7 +486,7 @@ return ( LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon))), [], e' ) unariseSumAlt _ scrt alt- = pprPanic "unariseSumAlt" (ppr scrt $$ ppr alt)+ = pprPanic "unariseSumAlt" (ppr scrt $$ pprPanicAlt alt) -------------------------------------------------------------------------------- @@ -776,4 +778,10 @@ mkDefaultLitAlt [] = pprPanic "elimUbxSumExpr.mkDefaultAlt" (text "Empty alts") mkDefaultLitAlt alts@((DEFAULT, _, _) : _) = alts mkDefaultLitAlt ((LitAlt{}, [], rhs) : alts) = (DEFAULT, [], rhs) : alts-mkDefaultLitAlt alts = pprPanic "mkDefaultLitAlt" (text "Not a lit alt:" <+> ppr alts)+mkDefaultLitAlt alts = pprPanic "mkDefaultLitAlt" (text "Not a lit alt:" <+> pprPanicAlts alts)++pprPanicAlts :: (Outputable a, Outputable b, OutputablePass pass) => [(a,b,GenStgExpr pass)] -> SDoc+pprPanicAlts alts = ppr (map pprPanicAlt alts)++pprPanicAlt :: (Outputable a, Outputable b, OutputablePass pass) => (a,b,GenStgExpr pass) -> SDoc+pprPanicAlt (c,b,e) = ppr (c,b,pprStgExpr panicStgPprOpts e)
compiler/GHC/StgToCmm.hs view
@@ -37,6 +37,7 @@ import GHC.Utils.Error import GHC.Driver.Types+import GHC.Driver.Backend import GHC.Types.CostCentre import GHC.Types.Id import GHC.Types.Id.Info@@ -165,7 +166,7 @@ -- emit either a CmmString literal or dump the string in a file and emit a -- CmmFileEmbed literal. -- See Note [Embedding large binary blobs] in GHC.CmmToAsm.Ppr- let isNCG = platformMisc_ghcWithNativeCodeGen $ platformMisc dflags+ let isNCG = backend dflags == NCG isSmall = fromIntegral (BS.length str) <= binBlobThreshold dflags asString = binBlobThreshold dflags == 0 || isSmall @@ -176,7 +177,7 @@ BS.writeFile bFile str return bFile emitDecl decl- addBindC (litIdInfo dflags id mkLFStringLit lit)+ addBindC (litIdInfo (targetPlatform dflags) id mkLFStringLit lit) cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ())@@ -189,7 +190,7 @@ cgTopRhs dflags rec bndr (StgRhsClosure fvs cc upd_flag args body) = ASSERT(isEmptyDVarSet fvs) -- There should be no free variables- cgTopRhsClosure dflags rec bndr cc upd_flag args body+ cgTopRhsClosure (targetPlatform dflags) rec bndr cc upd_flag args body ---------------------------------------------------------------@@ -215,28 +216,28 @@ cgEnumerationTyCon :: TyCon -> FCode () cgEnumerationTyCon tycon- = do dflags <- getDynFlags+ = do platform <- getPlatform emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs) [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs)- (tagForCon dflags con)+ (tagForCon platform con) | con <- tyConDataCons tycon] -cgDataCon :: DataCon -> FCode ()--- Generate the entry code, info tables, and (for niladic constructor)+-- | Generate the entry code, info tables, and (for niladic constructor) -- the static closure, for a constructor.+cgDataCon :: DataCon -> FCode () cgDataCon data_con- = do { dflags <- getDynFlags+ = do { profile <- getProfile ; platform <- getPlatform ; let (tot_wds, -- #ptr_wds + #nonptr_wds ptr_wds) -- #ptr_wds- = mkVirtConstrSizes dflags arg_reps+ = mkVirtConstrSizes profile arg_reps nonptr_wds = tot_wds - ptr_wds dyn_info_tbl =- mkDataConInfoTable dflags data_con False ptr_wds nonptr_wds+ mkDataConInfoTable profile data_con False ptr_wds nonptr_wds -- We're generating info tables, so we don't know and care about -- what the actual arguments are. Using () here as the place holder.@@ -246,7 +247,7 @@ , rep_ty <- typePrimRep (scaledThing ty) , not (isVoidRep rep_ty) ] - ; emitClosureAndInfoTable dyn_info_tbl NativeDirectCall [] $+ ; emitClosureAndInfoTable platform dyn_info_tbl NativeDirectCall [] $ -- NB: the closure pointer is assumed *untagged* on -- entry to a constructor. If the pointer is tagged, -- then we should not be entering it. This assumption@@ -256,7 +257,7 @@ do { tickyEnterDynCon ; ldvEnter (CmmReg nodeReg) ; tickyReturnOldCon (length arg_reps)- ; void $ emitReturn [cmmOffsetB platform (CmmReg nodeReg) (tagForCon dflags data_con)]+ ; void $ emitReturn [cmmOffsetB platform (CmmReg nodeReg) (tagForCon platform data_con)] } -- The case continuation code expects a tagged pointer }
compiler/GHC/StgToCmm/Bind.hs view
@@ -14,7 +14,9 @@ ) where import GHC.Prelude hiding ((<*>))+ import GHC.Platform+import GHC.Platform.Profile import GHC.StgToCmm.Expr import GHC.StgToCmm.Monad@@ -60,7 +62,7 @@ -- For closures bound at top level, allocate in static space. -- They should have no free variables. -cgTopRhsClosure :: DynFlags+cgTopRhsClosure :: Platform -> RecFlag -- member of a recursive group? -> Id -> CostCentreStack -- Optional cost centre annotation@@ -69,12 +71,11 @@ -> CgStgExpr -> (CgIdInfo, FCode ()) -cgTopRhsClosure dflags rec id ccs upd_flag args body =- let platform = targetPlatform dflags- closure_label = mkLocalClosureLabel (idName id) (idCafInfo id)- cg_id_info = litIdInfo dflags id lf_info (CmmLabel closure_label)+cgTopRhsClosure platform rec id ccs upd_flag args body =+ let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id)+ cg_id_info = litIdInfo platform id lf_info (CmmLabel closure_label) lf_info = mkClosureLFInfo platform id TopLevel [] upd_flag args- in (cg_id_info, gen_code dflags lf_info closure_label)+ in (cg_id_info, gen_code lf_info closure_label) where -- special case for a indirection (f = g). We create an IND_STATIC -- closure pointing directly to the indirectee. This is exactly@@ -89,17 +90,19 @@ -- hole detection from working in that case. Test -- concurrent/should_run/4030 fails, for instance. --- gen_code _ _ closure_label+ gen_code _ closure_label | StgApp f [] <- body, null args, isNonRec rec = do cg_info <- getCgIdInfo f emitDataCon closure_label indStaticInfoTable ccs [unLit (idInfoToAmode cg_info)] - gen_code dflags lf_info _closure_label- = do { let name = idName id+ gen_code lf_info _closure_label+ = do { profile <- getProfile+ ; dflags <- getDynFlags+ ; let name = idName id ; mod_name <- getModuleName ; let descr = closureDescription dflags mod_name name- closure_info = mkClosureInfo dflags True id lf_info 0 0 descr+ closure_info = mkClosureInfo profile True id lf_info 0 0 descr -- We don't generate the static closure here, because we might -- want to add references to static closures to it later. The@@ -108,7 +111,7 @@ ; let fv_details :: [(NonVoid Id, ByteOff)] header = if isLFThunk lf_info then ThunkHeader else StdHeader- (_, _, fv_details) = mkVirtHeapOffsets dflags header []+ (_, _, fv_details) = mkVirtHeapOffsets profile header [] -- Don't drop the non-void args until the closure info has been made ; forkClosureBody (closureCodeBody True id closure_info ccs args body fv_details)@@ -208,14 +211,14 @@ {- See Note [GC recovery] in "GHC.StgToCmm.Closure" -} cgRhs id (StgRhsClosure fvs cc upd_flag args body)- = do dflags <- getDynFlags- mkRhsClosure dflags id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body+ = do profile <- getProfile+ mkRhsClosure profile id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body ------------------------------------------------------------------------ -- Non-constructor right hand sides ------------------------------------------------------------------------ -mkRhsClosure :: DynFlags -> Id -> CostCentreStack+mkRhsClosure :: Profile -> Id -> CostCentreStack -> [NonVoid Id] -- Free vars -> UpdateFlag -> [Id] -- Args@@ -258,7 +261,7 @@ -} ---------- Note [Selectors] -------------------mkRhsClosure dflags bndr _cc+mkRhsClosure profile bndr _cc [NonVoid the_fv] -- Just one free var upd_flag -- Updatable thunk [] -- A thunk@@ -271,14 +274,14 @@ , StgApp selectee [{-no args-}] <- strip sel_expr , the_fv == scrutinee -- Scrutinee is the only free variable - , let (_, _, params_w_offsets) = mkVirtConstrOffsets dflags (addIdReps (assertNonVoidIds params))+ , let (_, _, params_w_offsets) = mkVirtConstrOffsets profile (addIdReps (assertNonVoidIds params)) -- pattern binders are always non-void, -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise , Just the_offset <- assocMaybe params_w_offsets (NonVoid selectee) - , let offset_into_int = bytesToWordsRoundUp (targetPlatform dflags) the_offset- - fixedHdrSizeW dflags- , offset_into_int <= mAX_SPEC_SELECTEE_SIZE dflags -- Offset is small enough+ , let offset_into_int = bytesToWordsRoundUp (profilePlatform profile) the_offset+ - fixedHdrSizeW profile+ , offset_into_int <= pc_MAX_SPEC_SELECTEE_SIZE (profileConstants profile) -- Offset is small enough = -- NOT TRUE: ASSERT(is_single_constructor) -- The simplifier may have statically determined that the single alternative -- is the only possible case and eliminated the others, even if there are@@ -291,7 +294,7 @@ in cgRhsStdThunk bndr lf_info [StgVarArg the_fv] ---------- Note [Ap thunks] -------------------mkRhsClosure dflags bndr _cc+mkRhsClosure profile bndr _cc fvs upd_flag [] -- No args; a thunk@@ -306,8 +309,8 @@ -- Missed opportunity: (f x x) is not detected , all (isGcPtrRep . idPrimRep . fromNonVoid) fvs , isUpdatable upd_flag- , n_fvs <= mAX_SPEC_AP_SIZE dflags- , not (sccProfilingEnabled dflags)+ , n_fvs <= pc_MAX_SPEC_AP_SIZE (profileConstants profile)+ , not (profileIsProfiling profile) -- not when profiling: we don't want to -- lose information about this particular -- thunk (e.g. its type) (#949)@@ -324,12 +327,11 @@ payload = StgVarArg fun_id : args ---------- Default case -------------------mkRhsClosure dflags bndr cc fvs upd_flag args body- = do { let lf_info = mkClosureLFInfo platform bndr NotTopLevel fvs upd_flag args+mkRhsClosure profile bndr cc fvs upd_flag args body+ = do { let lf_info = mkClosureLFInfo (profilePlatform profile) bndr NotTopLevel fvs upd_flag args ; (id_info, reg) <- rhsIdInfo bndr lf_info ; return (id_info, gen_code lf_info reg) } where- platform = targetPlatform dflags gen_code lf_info reg = do { -- LAY OUT THE OBJECT -- If the binder is itself a free variable, then don't store@@ -341,15 +343,19 @@ -- Node points to it... ; let reduced_fvs = filter (NonVoid bndr /=) fvs + ; profile <- getProfile+ ; let platform = profilePlatform profile+ -- MAKE CLOSURE INFO FOR THIS CLOSURE ; mod_name <- getModuleName+ ; dflags <- getDynFlags ; let name = idName bndr descr = closureDescription dflags mod_name name fv_details :: [(NonVoid Id, ByteOff)] header = if isLFThunk lf_info then ThunkHeader else StdHeader (tot_wds, ptr_wds, fv_details)- = mkVirtHeapOffsets dflags header (addIdReps reduced_fvs)- closure_info = mkClosureInfo dflags False -- Not static+ = mkVirtHeapOffsets profile header (addIdReps reduced_fvs)+ closure_info = mkClosureInfo profile False -- Not static bndr lf_info tot_wds ptr_wds descr @@ -371,7 +377,7 @@ (map toVarArg fv_details) -- RETURN- ; return (mkRhsInit dflags reg lf_info hp_plus_n) }+ ; return (mkRhsInit platform reg lf_info hp_plus_n) } ------------------------- cgRhsStdThunk@@ -391,13 +397,15 @@ { -- LAY OUT THE OBJECT mod_name <- getModuleName ; dflags <- getDynFlags- ; let header = if isLFThunk lf_info then ThunkHeader else StdHeader+ ; profile <- getProfile+ ; let platform = profilePlatform profile+ header = if isLFThunk lf_info then ThunkHeader else StdHeader (tot_wds, ptr_wds, payload_w_offsets)- = mkVirtHeapOffsets dflags header+ = mkVirtHeapOffsets profile header (addArgReps (nonVoidStgArgs payload)) descr = closureDescription dflags mod_name (idName bndr)- closure_info = mkClosureInfo dflags False -- Not static+ closure_info = mkClosureInfo profile False -- Not static bndr lf_info tot_wds ptr_wds descr @@ -411,7 +419,7 @@ use_cc blame_cc payload_w_offsets -- RETURN- ; return (mkRhsInit dflags reg lf_info hp_plus_n) }+ ; return (mkRhsInit platform reg lf_info hp_plus_n) } mkClosureLFInfo :: Platform@@ -480,9 +488,9 @@ \(_offset, node, arg_regs) -> do -- Emit slow-entry code (for entering a closure through a PAP) { mkSlowEntryCode bndr cl_info arg_regs- ; dflags <- getDynFlags+ ; profile <- getProfile ; platform <- getPlatform- ; let node_points = nodeMustPointToIt dflags lf_info+ ; let node_points = nodeMustPointToIt profile lf_info node' = if node_points then Just node else Nothing ; loop_header_id <- newBlockId -- Extend reader monad with information that@@ -499,7 +507,7 @@ ; enterCostCentreFun cc (CmmMachOp (mo_wordSub platform) [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification]- , mkIntExpr platform (funTag dflags cl_info) ])+ , mkIntExpr platform (funTag platform cl_info) ]) ; fv_bindings <- mapM bind_fv fv_details -- Load free vars out of closure *after* -- heap check, to reduce live vars over check@@ -528,9 +536,8 @@ load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode () load_fvs node lf_info = mapM_ (\ (reg, off) ->- do dflags <- getDynFlags- platform <- getPlatform- let tag = lfDynTag dflags lf_info+ do platform <- getPlatform+ let tag = lfDynTag platform lf_info emit $ mkTaggedObjectLoad platform reg node off tag) -----------------------------------------@@ -548,13 +555,13 @@ -- Here, we emit the slow-entry code. mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node' | Just (_, ArgGen _) <- closureFunInfo cl_info- = do dflags <- getDynFlags+ = do profile <- getProfile platform <- getPlatform let node = idToReg platform (NonVoid bndr)- slow_lbl = closureSlowEntryLabel cl_info+ slow_lbl = closureSlowEntryLabel platform cl_info fast_lbl = closureLocalEntryLabel platform cl_info -- mkDirectJump does not clobber `Node' containing function closure- jump = mkJump dflags NativeNodeCall+ jump = mkJump profile NativeNodeCall (mkLblExpr fast_lbl) (map (CmmReg . CmmLocal) (node : arg_regs)) (initUpdFrameOff platform)@@ -567,8 +574,8 @@ thunkCode :: ClosureInfo -> [(NonVoid Id, ByteOff)] -> CostCentreStack -> LocalReg -> CgStgExpr -> FCode () thunkCode cl_info fv_details _cc node body- = do { dflags <- getDynFlags- ; let node_points = nodeMustPointToIt dflags (closureLFInfo cl_info)+ = do { profile <- getProfile+ ; let node_points = nodeMustPointToIt profile (closureLFInfo cl_info) node' = if node_points then Just node else Nothing ; ldvEnterClosure cl_info (CmmLocal node) -- NB: Node always points when profiling @@ -606,7 +613,8 @@ emitBlackHoleCode :: CmmExpr -> FCode () emitBlackHoleCode node = do dflags <- getDynFlags- let platform = targetPlatform dflags+ profile <- getProfile+ let platform = profilePlatform profile -- Eager blackholing is normally disabled, but can be turned on with -- -feager-blackholing. When it is on, we replace the info pointer@@ -626,7 +634,7 @@ -- Note the eager-blackholing check is here rather than in blackHoleOnEntry, -- because emitBlackHoleCode is called from GHC.Cmm.Parser. - let eager_blackholing = not (sccProfilingEnabled dflags)+ let eager_blackholing = not (profileIsProfiling profile) && gopt Opt_EagerBlackHoling dflags -- Profiling needs slop filling (to support LDV -- profiling), so currently eager blackholing doesn't@@ -634,7 +642,7 @@ when eager_blackholing $ do whenUpdRemSetEnabled $ emitUpdRemSetPushThunk node- emitStore (cmmOffsetW platform node (fixedHdrSizeW dflags)) currentTSOExpr+ emitStore (cmmOffsetW platform node (fixedHdrSizeW profile)) currentTSOExpr -- See Note [Heap memory barriers] in SMP.h. emitPrimCall [] MO_WriteBarrier [] emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo))@@ -684,20 +692,21 @@ pushUpdateFrame lbl updatee body = do updfr <- getUpdFrameOff- dflags <- getDynFlags+ profile <- getProfile let- hdr = fixedHdrSize dflags- frame = updfr + hdr + sIZEOF_StgUpdateFrame_NoHdr dflags+ hdr = fixedHdrSize profile+ frame = updfr + hdr + pc_SIZEOF_StgUpdateFrame_NoHdr (profileConstants profile) --- emitUpdateFrame dflags (CmmStackSlot Old frame) lbl updatee+ emitUpdateFrame (CmmStackSlot Old frame) lbl updatee withUpdFrameOff frame body -emitUpdateFrame :: DynFlags -> CmmExpr -> CLabel -> CmmExpr -> FCode ()-emitUpdateFrame dflags frame lbl updatee = do+emitUpdateFrame :: CmmExpr -> CLabel -> CmmExpr -> FCode ()+emitUpdateFrame frame lbl updatee = do+ profile <- getProfile let- hdr = fixedHdrSize dflags- off_updatee = hdr + oFFSET_StgUpdateFrame_updatee dflags- platform = targetPlatform dflags+ hdr = fixedHdrSize profile+ off_updatee = hdr + pc_OFFSET_StgUpdateFrame_updatee (platformConstants platform)+ platform = profilePlatform profile -- emitStore frame (mkLblExpr lbl) emitStore (cmmOffset platform frame off_updatee) updatee@@ -713,12 +722,12 @@ -- This function returns the address of the black hole, so it can be -- updated with the new value when available. link_caf node = do- { dflags <- getDynFlags+ { profile <- getProfile -- Call the RTS function newCAF, returning the newly-allocated -- blackhole indirection closure ; let newCAF_lbl = mkForeignLabel (fsLit "newCAF") Nothing ForeignLabelInExternalPackage IsFunction- ; let platform = targetPlatform dflags+ ; let platform = profilePlatform profile ; bh <- newTemp (bWord platform) ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl [ (baseExpr, AddrHint),@@ -727,11 +736,12 @@ -- see Note [atomic CAF entry] in rts/sm/Storage.c ; updfr <- getUpdFrameOff- ; let target = entryCode platform (closureInfoPtr dflags (CmmReg (CmmLocal node)))+ ; ptr_opts <- getPtrOpts+ ; let target = entryCode platform (closureInfoPtr ptr_opts (CmmReg (CmmLocal node))) ; emit =<< mkCmmIfThen (cmmEqWord platform (CmmReg (CmmLocal bh)) (zeroExpr platform)) -- re-enter the CAF- (mkJump dflags NativeNodeCall target [] updfr)+ (mkJump profile NativeNodeCall target [] updfr) ; return (CmmReg (CmmLocal bh)) }
compiler/GHC/StgToCmm/CgUtils.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-}+{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- --@@ -19,82 +20,84 @@ import GHC.Prelude import GHC.Platform.Regs+import GHC.Platform import GHC.Cmm import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Utils import GHC.Cmm.CLabel-import GHC.Driver.Session import GHC.Utils.Outputable -- ----------------------------------------------------------------------------- -- Information about global registers -baseRegOffset :: DynFlags -> GlobalReg -> Int--baseRegOffset dflags (VanillaReg 1 _) = oFFSET_StgRegTable_rR1 dflags-baseRegOffset dflags (VanillaReg 2 _) = oFFSET_StgRegTable_rR2 dflags-baseRegOffset dflags (VanillaReg 3 _) = oFFSET_StgRegTable_rR3 dflags-baseRegOffset dflags (VanillaReg 4 _) = oFFSET_StgRegTable_rR4 dflags-baseRegOffset dflags (VanillaReg 5 _) = oFFSET_StgRegTable_rR5 dflags-baseRegOffset dflags (VanillaReg 6 _) = oFFSET_StgRegTable_rR6 dflags-baseRegOffset dflags (VanillaReg 7 _) = oFFSET_StgRegTable_rR7 dflags-baseRegOffset dflags (VanillaReg 8 _) = oFFSET_StgRegTable_rR8 dflags-baseRegOffset dflags (VanillaReg 9 _) = oFFSET_StgRegTable_rR9 dflags-baseRegOffset dflags (VanillaReg 10 _) = oFFSET_StgRegTable_rR10 dflags-baseRegOffset _ (VanillaReg n _) = panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")")-baseRegOffset dflags (FloatReg 1) = oFFSET_StgRegTable_rF1 dflags-baseRegOffset dflags (FloatReg 2) = oFFSET_StgRegTable_rF2 dflags-baseRegOffset dflags (FloatReg 3) = oFFSET_StgRegTable_rF3 dflags-baseRegOffset dflags (FloatReg 4) = oFFSET_StgRegTable_rF4 dflags-baseRegOffset dflags (FloatReg 5) = oFFSET_StgRegTable_rF5 dflags-baseRegOffset dflags (FloatReg 6) = oFFSET_StgRegTable_rF6 dflags-baseRegOffset _ (FloatReg n) = panic ("Registers above F6 are not supported (tried to use F" ++ show n ++ ")")-baseRegOffset dflags (DoubleReg 1) = oFFSET_StgRegTable_rD1 dflags-baseRegOffset dflags (DoubleReg 2) = oFFSET_StgRegTable_rD2 dflags-baseRegOffset dflags (DoubleReg 3) = oFFSET_StgRegTable_rD3 dflags-baseRegOffset dflags (DoubleReg 4) = oFFSET_StgRegTable_rD4 dflags-baseRegOffset dflags (DoubleReg 5) = oFFSET_StgRegTable_rD5 dflags-baseRegOffset dflags (DoubleReg 6) = oFFSET_StgRegTable_rD6 dflags-baseRegOffset _ (DoubleReg n) = panic ("Registers above D6 are not supported (tried to use D" ++ show n ++ ")")-baseRegOffset dflags (XmmReg 1) = oFFSET_StgRegTable_rXMM1 dflags-baseRegOffset dflags (XmmReg 2) = oFFSET_StgRegTable_rXMM2 dflags-baseRegOffset dflags (XmmReg 3) = oFFSET_StgRegTable_rXMM3 dflags-baseRegOffset dflags (XmmReg 4) = oFFSET_StgRegTable_rXMM4 dflags-baseRegOffset dflags (XmmReg 5) = oFFSET_StgRegTable_rXMM5 dflags-baseRegOffset dflags (XmmReg 6) = oFFSET_StgRegTable_rXMM6 dflags-baseRegOffset _ (XmmReg n) = panic ("Registers above XMM6 are not supported (tried to use XMM" ++ show n ++ ")")-baseRegOffset dflags (YmmReg 1) = oFFSET_StgRegTable_rYMM1 dflags-baseRegOffset dflags (YmmReg 2) = oFFSET_StgRegTable_rYMM2 dflags-baseRegOffset dflags (YmmReg 3) = oFFSET_StgRegTable_rYMM3 dflags-baseRegOffset dflags (YmmReg 4) = oFFSET_StgRegTable_rYMM4 dflags-baseRegOffset dflags (YmmReg 5) = oFFSET_StgRegTable_rYMM5 dflags-baseRegOffset dflags (YmmReg 6) = oFFSET_StgRegTable_rYMM6 dflags-baseRegOffset _ (YmmReg n) = panic ("Registers above YMM6 are not supported (tried to use YMM" ++ show n ++ ")")-baseRegOffset dflags (ZmmReg 1) = oFFSET_StgRegTable_rZMM1 dflags-baseRegOffset dflags (ZmmReg 2) = oFFSET_StgRegTable_rZMM2 dflags-baseRegOffset dflags (ZmmReg 3) = oFFSET_StgRegTable_rZMM3 dflags-baseRegOffset dflags (ZmmReg 4) = oFFSET_StgRegTable_rZMM4 dflags-baseRegOffset dflags (ZmmReg 5) = oFFSET_StgRegTable_rZMM5 dflags-baseRegOffset dflags (ZmmReg 6) = oFFSET_StgRegTable_rZMM6 dflags-baseRegOffset _ (ZmmReg n) = panic ("Registers above ZMM6 are not supported (tried to use ZMM" ++ show n ++ ")")-baseRegOffset dflags Sp = oFFSET_StgRegTable_rSp dflags-baseRegOffset dflags SpLim = oFFSET_StgRegTable_rSpLim dflags-baseRegOffset dflags (LongReg 1) = oFFSET_StgRegTable_rL1 dflags-baseRegOffset _ (LongReg n) = panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")")-baseRegOffset dflags Hp = oFFSET_StgRegTable_rHp dflags-baseRegOffset dflags HpLim = oFFSET_StgRegTable_rHpLim dflags-baseRegOffset dflags CCCS = oFFSET_StgRegTable_rCCCS dflags-baseRegOffset dflags CurrentTSO = oFFSET_StgRegTable_rCurrentTSO dflags-baseRegOffset dflags CurrentNursery = oFFSET_StgRegTable_rCurrentNursery dflags-baseRegOffset dflags HpAlloc = oFFSET_StgRegTable_rHpAlloc dflags-baseRegOffset dflags EagerBlackholeInfo = oFFSET_stgEagerBlackholeInfo dflags-baseRegOffset dflags GCEnter1 = oFFSET_stgGCEnter1 dflags-baseRegOffset dflags GCFun = oFFSET_stgGCFun dflags-baseRegOffset _ BaseReg = panic "CgUtils.baseRegOffset:BaseReg"-baseRegOffset _ PicBaseReg = panic "CgUtils.baseRegOffset:PicBaseReg"-baseRegOffset _ MachSp = panic "CgUtils.baseRegOffset:MachSp"-baseRegOffset _ UnwindReturnReg = panic "CgUtils.baseRegOffset:UnwindReturnReg"+baseRegOffset :: Platform -> GlobalReg -> Int+baseRegOffset platform reg = case reg of+ VanillaReg 1 _ -> pc_OFFSET_StgRegTable_rR1 constants+ VanillaReg 2 _ -> pc_OFFSET_StgRegTable_rR2 constants+ VanillaReg 3 _ -> pc_OFFSET_StgRegTable_rR3 constants+ VanillaReg 4 _ -> pc_OFFSET_StgRegTable_rR4 constants+ VanillaReg 5 _ -> pc_OFFSET_StgRegTable_rR5 constants+ VanillaReg 6 _ -> pc_OFFSET_StgRegTable_rR6 constants+ VanillaReg 7 _ -> pc_OFFSET_StgRegTable_rR7 constants+ VanillaReg 8 _ -> pc_OFFSET_StgRegTable_rR8 constants+ VanillaReg 9 _ -> pc_OFFSET_StgRegTable_rR9 constants+ VanillaReg 10 _ -> pc_OFFSET_StgRegTable_rR10 constants+ VanillaReg n _ -> panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")")+ FloatReg 1 -> pc_OFFSET_StgRegTable_rF1 constants+ FloatReg 2 -> pc_OFFSET_StgRegTable_rF2 constants+ FloatReg 3 -> pc_OFFSET_StgRegTable_rF3 constants+ FloatReg 4 -> pc_OFFSET_StgRegTable_rF4 constants+ FloatReg 5 -> pc_OFFSET_StgRegTable_rF5 constants+ FloatReg 6 -> pc_OFFSET_StgRegTable_rF6 constants+ FloatReg n -> panic ("Registers above F6 are not supported (tried to use F" ++ show n ++ ")")+ DoubleReg 1 -> pc_OFFSET_StgRegTable_rD1 constants+ DoubleReg 2 -> pc_OFFSET_StgRegTable_rD2 constants+ DoubleReg 3 -> pc_OFFSET_StgRegTable_rD3 constants+ DoubleReg 4 -> pc_OFFSET_StgRegTable_rD4 constants+ DoubleReg 5 -> pc_OFFSET_StgRegTable_rD5 constants+ DoubleReg 6 -> pc_OFFSET_StgRegTable_rD6 constants+ DoubleReg n -> panic ("Registers above D6 are not supported (tried to use D" ++ show n ++ ")")+ XmmReg 1 -> pc_OFFSET_StgRegTable_rXMM1 constants+ XmmReg 2 -> pc_OFFSET_StgRegTable_rXMM2 constants+ XmmReg 3 -> pc_OFFSET_StgRegTable_rXMM3 constants+ XmmReg 4 -> pc_OFFSET_StgRegTable_rXMM4 constants+ XmmReg 5 -> pc_OFFSET_StgRegTable_rXMM5 constants+ XmmReg 6 -> pc_OFFSET_StgRegTable_rXMM6 constants+ XmmReg n -> panic ("Registers above XMM6 are not supported (tried to use XMM" ++ show n ++ ")")+ YmmReg 1 -> pc_OFFSET_StgRegTable_rYMM1 constants+ YmmReg 2 -> pc_OFFSET_StgRegTable_rYMM2 constants+ YmmReg 3 -> pc_OFFSET_StgRegTable_rYMM3 constants+ YmmReg 4 -> pc_OFFSET_StgRegTable_rYMM4 constants+ YmmReg 5 -> pc_OFFSET_StgRegTable_rYMM5 constants+ YmmReg 6 -> pc_OFFSET_StgRegTable_rYMM6 constants+ YmmReg n -> panic ("Registers above YMM6 are not supported (tried to use YMM" ++ show n ++ ")")+ ZmmReg 1 -> pc_OFFSET_StgRegTable_rZMM1 constants+ ZmmReg 2 -> pc_OFFSET_StgRegTable_rZMM2 constants+ ZmmReg 3 -> pc_OFFSET_StgRegTable_rZMM3 constants+ ZmmReg 4 -> pc_OFFSET_StgRegTable_rZMM4 constants+ ZmmReg 5 -> pc_OFFSET_StgRegTable_rZMM5 constants+ ZmmReg 6 -> pc_OFFSET_StgRegTable_rZMM6 constants+ ZmmReg n -> panic ("Registers above ZMM6 are not supported (tried to use ZMM" ++ show n ++ ")")+ Sp -> pc_OFFSET_StgRegTable_rSp constants+ SpLim -> pc_OFFSET_StgRegTable_rSpLim constants+ LongReg 1 -> pc_OFFSET_StgRegTable_rL1 constants+ LongReg n -> panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")")+ Hp -> pc_OFFSET_StgRegTable_rHp constants+ HpLim -> pc_OFFSET_StgRegTable_rHpLim constants+ CCCS -> pc_OFFSET_StgRegTable_rCCCS constants+ CurrentTSO -> pc_OFFSET_StgRegTable_rCurrentTSO constants+ CurrentNursery -> pc_OFFSET_StgRegTable_rCurrentNursery constants+ HpAlloc -> pc_OFFSET_StgRegTable_rHpAlloc constants+ EagerBlackholeInfo -> pc_OFFSET_stgEagerBlackholeInfo constants+ GCEnter1 -> pc_OFFSET_stgGCEnter1 constants+ GCFun -> pc_OFFSET_stgGCFun constants+ BaseReg -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:BaseReg"+ PicBaseReg -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:PicBaseReg"+ MachSp -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:MachSp"+ UnwindReturnReg -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:UnwindReturnReg"+ where+ !constants = platformConstants platform -- -----------------------------------------------------------------------------@@ -107,40 +110,38 @@ -- to real machine registers or stored as offsets from BaseReg. Given -- a GlobalReg, get_GlobalReg_addr always produces the -- register table address for it.-get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr-get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0-get_GlobalReg_addr dflags mid- = get_Regtable_addr_from_offset dflags (baseRegOffset dflags mid)+get_GlobalReg_addr :: Platform -> GlobalReg -> CmmExpr+get_GlobalReg_addr platform BaseReg = regTableOffset platform 0+get_GlobalReg_addr platform mid+ = get_Regtable_addr_from_offset platform (baseRegOffset platform mid) -- Calculate a literal representing an offset into the register table. -- Used when we don't have an actual BaseReg to offset from.-regTableOffset :: DynFlags -> Int -> CmmExpr-regTableOffset dflags n =- CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n))+regTableOffset :: Platform -> Int -> CmmExpr+regTableOffset platform n =+ CmmLit (CmmLabelOff mkMainCapabilityLabel (pc_OFFSET_Capability_r (platformConstants platform) + n)) -get_Regtable_addr_from_offset :: DynFlags -> Int -> CmmExpr-get_Regtable_addr_from_offset dflags offset =- if haveRegBase (targetPlatform dflags)- then CmmRegOff baseReg offset- else regTableOffset dflags offset+get_Regtable_addr_from_offset :: Platform -> Int -> CmmExpr+get_Regtable_addr_from_offset platform offset =+ if haveRegBase platform+ then cmmRegOff baseReg offset+ else regTableOffset platform offset -- | Fixup global registers so that they assign to locations within the -- RegTable if they aren't pinned for the current target.-fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl+fixStgRegisters :: Platform -> RawCmmDecl -> RawCmmDecl fixStgRegisters _ top@(CmmData _ _) = top -fixStgRegisters dflags (CmmProc info lbl live graph) =- let graph' = modifyGraph (mapGraphBlocks (fixStgRegBlock dflags)) graph+fixStgRegisters platform (CmmProc info lbl live graph) =+ let graph' = modifyGraph (mapGraphBlocks (fixStgRegBlock platform)) graph in CmmProc info lbl live graph' -fixStgRegBlock :: DynFlags -> Block CmmNode e x -> Block CmmNode e x-fixStgRegBlock dflags block = mapBlock (fixStgRegStmt dflags) block+fixStgRegBlock :: Platform -> Block CmmNode e x -> Block CmmNode e x+fixStgRegBlock platform block = mapBlock (fixStgRegStmt platform) block -fixStgRegStmt :: DynFlags -> CmmNode e x -> CmmNode e x-fixStgRegStmt dflags stmt = fixAssign $ mapExpDeep fixExpr stmt+fixStgRegStmt :: Platform -> CmmNode e x -> CmmNode e x+fixStgRegStmt platform stmt = fixAssign $ mapExpDeep fixExpr stmt where- platform = targetPlatform dflags- fixAssign stmt = case stmt of CmmAssign (CmmGlobal reg) src@@ -148,7 +149,7 @@ -- information | reg == MachSp -> stmt | otherwise ->- let baseAddr = get_GlobalReg_addr dflags reg+ let baseAddr = get_GlobalReg_addr platform reg in case reg `elem` activeStgRegs platform of True -> CmmAssign (CmmGlobal reg) src False -> CmmStore baseAddr src@@ -167,7 +168,7 @@ case reg `elem` activeStgRegs platform of True -> expr False ->- let baseAddr = get_GlobalReg_addr dflags reg+ let baseAddr = get_GlobalReg_addr platform reg in case reg of BaseReg -> baseAddr _other -> CmmLoad baseAddr (globalRegType platform reg)
compiler/GHC/StgToCmm/Closure.hs view
@@ -31,7 +31,8 @@ -- * Used by other modules CgLoc(..), SelfLoopInfo, CallMethod(..),- nodeMustPointToIt, isKnownFun, funTag, tagForArity, getCallMethod,+ nodeMustPointToIt, isKnownFun, funTag, tagForArity,+ CallOpts(..), getCallMethod, -- * ClosureInfo ClosureInfo,@@ -66,10 +67,12 @@ import GHC.Prelude import GHC.Platform+import GHC.Platform.Profile import GHC.Stg.Syntax import GHC.Runtime.Heap.Layout import GHC.Cmm+import GHC.Cmm.Utils import GHC.Cmm.Ppr.Expr() -- For Outputable instances import GHC.StgToCmm.Types @@ -87,7 +90,6 @@ import GHC.Types.RepType import GHC.Types.Basic import GHC.Utils.Outputable-import GHC.Driver.Session import GHC.Utils.Misc import Data.Coerce (coerce)@@ -308,24 +310,25 @@ -- -- Also see Note [Tagging big families] in GHC.StgToCmm.Expr -isSmallFamily :: DynFlags -> Int -> Bool-isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags+isSmallFamily :: Platform -> Int -> Bool+isSmallFamily platform fam_size = fam_size <= mAX_PTR_TAG platform -tagForCon :: DynFlags -> DataCon -> DynTag-tagForCon dflags con = min (dataConTag con) (mAX_PTR_TAG dflags)+tagForCon :: Platform -> DataCon -> DynTag+tagForCon platform con = min (dataConTag con) (mAX_PTR_TAG platform) -- NB: 1-indexed -tagForArity :: DynFlags -> RepArity -> DynTag-tagForArity dflags arity- | isSmallFamily dflags arity = arity- | otherwise = 0+tagForArity :: Platform -> RepArity -> DynTag+tagForArity platform arity+ | isSmallFamily platform arity = arity+ | otherwise = 0 -lfDynTag :: DynFlags -> LambdaFormInfo -> DynTag--- Return the tag in the low order bits of a variable bound+-- | Return the tag in the low order bits of a variable bound -- to this LambdaForm-lfDynTag dflags (LFCon con) = tagForCon dflags con-lfDynTag dflags (LFReEntrant _ arity _ _) = tagForArity dflags arity-lfDynTag _ _other = 0+lfDynTag :: Platform -> LambdaFormInfo -> DynTag+lfDynTag platform lf = case lf of+ LFCon con -> tagForCon platform con+ LFReEntrant _ arity _ _ -> tagForArity platform arity+ _other -> 0 -----------------------------------------------------------------------------@@ -365,7 +368,7 @@ -- nodeMustPointToIt ----------------------------------------------------------------------------- -nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool+nodeMustPointToIt :: Profile -> LambdaFormInfo -> Bool -- If nodeMustPointToIt is true, then the entry convention for -- this closure has R1 (the "Node" register) pointing to the -- closure itself --- the "self" argument@@ -377,11 +380,11 @@ -- non-inherited (i.e. non-top-level) function. -- The isNotTopLevel test above ensures this is ok. -nodeMustPointToIt dflags (LFThunk top no_fvs updatable NonStandardThunk _)+nodeMustPointToIt profile (LFThunk top no_fvs updatable NonStandardThunk _) = not no_fvs -- Self parameter || isNotTopLevel top -- Note [GC recovery] || updatable -- Need to push update frame- || sccProfilingEnabled dflags+ || profileIsProfiling profile -- For the non-updatable (single-entry case): -- -- True if has fvs (in which case we need access to them, and we@@ -476,7 +479,13 @@ CLabel -- The code label RepArity -- Its arity -getCallMethod :: DynFlags+data CallOpts = CallOpts+ { co_profile :: !Profile -- ^ Platform profile+ , co_loopification :: !Bool -- ^ Loopification enabled (cf @-floopification@)+ , co_ticky :: !Bool -- ^ Ticky profiling enabled (cf @-ticky@)+ }++getCallMethod :: CallOpts -> Name -- Function being applied -> Id -- Function Id used to chech if it can refer to -- CAF's and whether the function is tail-calling@@ -492,9 +501,9 @@ -> Maybe SelfLoopInfo -- can we perform a self-recursive tail call? -> CallMethod -getCallMethod dflags _ id _ n_args v_args _cg_loc+getCallMethod opts _ id _ n_args v_args _cg_loc (Just (self_loop_id, block_id, args))- | gopt Opt_Loopification dflags+ | co_loopification opts , id == self_loop_id , args `lengthIs` (n_args - v_args) -- If these patterns match then we know that:@@ -505,14 +514,14 @@ -- self-recursive tail calls] in GHC.StgToCmm.Expr for more details = JumpToIt block_id args -getCallMethod dflags name id (LFReEntrant _ arity _ _) n_args _v_args _cg_loc+getCallMethod opts name id (LFReEntrant _ arity _ _) n_args _v_args _cg_loc _self_loop_info | n_args == 0 -- No args at all- && not (sccProfilingEnabled dflags)+ && not (profileIsProfiling (co_profile opts)) -- See Note [Evaluating functions with profiling] in rts/Apply.cmm = ASSERT( arity /= 0 ) ReturnIt | n_args < arity = SlowCall -- Not enough args- | otherwise = DirectEntry (enterIdLabel (targetPlatform dflags) name (idCafInfo id)) arity+ | otherwise = DirectEntry (enterIdLabel (profilePlatform (co_profile opts)) name (idCafInfo id)) arity getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info = ASSERT( n_args == 0 ) ReturnIt@@ -522,14 +531,14 @@ -- n_args=0 because it'd be ill-typed to apply a saturated -- constructor application to anything -getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun)+getCallMethod opts name id (LFThunk _ _ updatable std_form_info is_fun) n_args _v_args _cg_loc _self_loop_info | is_fun -- it *might* be a function, so we must "call" it (which is always safe) = SlowCall -- We cannot just enter it [in eval/apply, the entry code -- is the fast-entry code] -- Since is_fun is False, we are *definitely* looking at a data value- | updatable || gopt Opt_Ticky dflags -- to catch double entry+ | updatable || co_ticky opts -- to catch double entry {- OLD: || opt_SMP I decided to remove this, because in SMP mode it doesn't matter if we enter the same thunk multiple times, so the optimisation@@ -551,7 +560,7 @@ | otherwise -- Jump direct to code for single-entry thunks = ASSERT( n_args == 0 )- DirectEntry (thunkEntryLabel dflags name (idCafInfo id) std_form_info+ DirectEntry (thunkEntryLabel (profilePlatform (co_profile opts)) name (idCafInfo id) std_form_info updatable) 0 getCallMethod _ _name _ (LFUnknown True) _n_arg _v_args _cg_locs _self_loop_info@@ -619,14 +628,14 @@ -- Building ClosureInfos -------------------------------------- -mkClosureInfo :: DynFlags+mkClosureInfo :: Profile -> Bool -- Is static -> Id -> LambdaFormInfo -> Int -> Int -- Total and pointer words -> String -- String descriptor -> ClosureInfo-mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr+mkClosureInfo profile is_static id lf_info tot_wds ptr_wds val_descr = ClosureInfo { closureName = name , closureLFInfo = lf_info , closureInfoLabel = info_lbl -- These three fields are@@ -634,11 +643,11 @@ , closureProf = prof } -- (we don't have an SRT yet) where name = idName id- sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info)- prof = mkProfilingInfo dflags id val_descr+ sm_rep = mkHeapRep profile is_static ptr_wds nonptr_wds (lfClosureType lf_info)+ prof = mkProfilingInfo profile id val_descr nonptr_wds = tot_wds - ptr_wds - info_lbl = mkClosureInfoTableLabel dflags id lf_info+ info_lbl = mkClosureInfoTableLabel (profilePlatform profile) id lf_info -------------------------------------- -- Other functions over ClosureInfo@@ -761,9 +770,9 @@ lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc) lfFunInfo _ = Nothing -funTag :: DynFlags -> ClosureInfo -> DynTag-funTag dflags (ClosureInfo { closureLFInfo = lf_info })- = lfDynTag dflags lf_info+funTag :: Platform -> ClosureInfo -> DynTag+funTag platform (ClosureInfo { closureLFInfo = lf_info })+ = lfDynTag platform lf_info isToplevClosure :: ClosureInfo -> Bool isToplevClosure (ClosureInfo { closureLFInfo = lf_info })@@ -776,25 +785,25 @@ -- Label generation -------------------------------------- -staticClosureLabel :: ClosureInfo -> CLabel-staticClosureLabel = toClosureLbl . closureInfoLabel+staticClosureLabel :: Platform -> ClosureInfo -> CLabel+staticClosureLabel platform = toClosureLbl platform . closureInfoLabel -closureSlowEntryLabel :: ClosureInfo -> CLabel-closureSlowEntryLabel = toSlowEntryLbl . closureInfoLabel+closureSlowEntryLabel :: Platform -> ClosureInfo -> CLabel+closureSlowEntryLabel platform = toSlowEntryLbl platform . closureInfoLabel closureLocalEntryLabel :: Platform -> ClosureInfo -> CLabel closureLocalEntryLabel platform- | platformTablesNextToCode platform = toInfoLbl . closureInfoLabel- | otherwise = toEntryLbl . closureInfoLabel+ | platformTablesNextToCode platform = toInfoLbl platform . closureInfoLabel+ | otherwise = toEntryLbl platform . closureInfoLabel -mkClosureInfoTableLabel :: DynFlags -> Id -> LambdaFormInfo -> CLabel-mkClosureInfoTableLabel dflags id lf_info+mkClosureInfoTableLabel :: Platform -> Id -> LambdaFormInfo -> CLabel+mkClosureInfoTableLabel platform id lf_info = case lf_info of LFThunk _ _ upd_flag (SelectorThunk offset) _- -> mkSelectorInfoLabel dflags upd_flag offset+ -> mkSelectorInfoLabel platform upd_flag offset LFThunk _ _ upd_flag (ApThunk arity) _- -> mkApInfoTableLabel dflags upd_flag arity+ -> mkApInfoTableLabel platform upd_flag arity LFThunk{} -> std_mk_lbl name cafs LFReEntrant{} -> std_mk_lbl name cafs@@ -814,29 +823,23 @@ -- invariants in "GHC.CoreToStg.Prep" anything else gets eta expanded. -thunkEntryLabel :: DynFlags -> Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel--- thunkEntryLabel is a local help function, not exported. It's used from+-- | thunkEntryLabel is a local help function, not exported. It's used from -- getCallMethod.-thunkEntryLabel dflags _thunk_id _ (ApThunk arity) upd_flag- = enterApLabel dflags upd_flag arity-thunkEntryLabel dflags _thunk_id _ (SelectorThunk offset) upd_flag- = enterSelectorLabel dflags upd_flag offset-thunkEntryLabel dflags thunk_id c _ _- = enterIdLabel (targetPlatform dflags) thunk_id c+thunkEntryLabel :: Platform -> Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel+thunkEntryLabel platform thunk_id caf_info sfi upd_flag = case sfi of+ ApThunk arity -> enterApLabel platform upd_flag arity+ SelectorThunk offset -> enterSelectorLabel platform upd_flag offset+ _ -> enterIdLabel platform thunk_id caf_info -enterApLabel :: DynFlags -> Bool -> Arity -> CLabel-enterApLabel dflags is_updatable arity- | platformTablesNextToCode platform = mkApInfoTableLabel dflags is_updatable arity- | otherwise = mkApEntryLabel dflags is_updatable arity- where- platform = targetPlatform dflags+enterApLabel :: Platform -> Bool -> Arity -> CLabel+enterApLabel platform is_updatable arity+ | platformTablesNextToCode platform = mkApInfoTableLabel platform is_updatable arity+ | otherwise = mkApEntryLabel platform is_updatable arity -enterSelectorLabel :: DynFlags -> Bool -> WordOff -> CLabel-enterSelectorLabel dflags upd_flag offset- | platformTablesNextToCode platform = mkSelectorInfoLabel dflags upd_flag offset- | otherwise = mkSelectorEntryLabel dflags upd_flag offset- where- platform = targetPlatform dflags+enterSelectorLabel :: Platform -> Bool -> WordOff -> CLabel+enterSelectorLabel platform upd_flag offset+ | platformTablesNextToCode platform = mkSelectorInfoLabel platform upd_flag offset+ | otherwise = mkSelectorEntryLabel platform upd_flag offset enterIdLabel :: Platform -> Name -> CafInfo -> CLabel enterIdLabel platform id c@@ -857,10 +860,10 @@ -- The type is determined from the type information stored with the @Id@ -- in the closure info using @closureTypeDescr@. -mkProfilingInfo :: DynFlags -> Id -> String -> ProfilingInfo-mkProfilingInfo dflags id val_descr- | not (sccProfilingEnabled dflags) = NoProfilingInfo- | otherwise = ProfilingInfo ty_descr_w8 (BS8.pack val_descr)+mkProfilingInfo :: Profile -> Id -> String -> ProfilingInfo+mkProfilingInfo profile id val_descr+ | not (profileIsProfiling profile) = NoProfilingInfo+ | otherwise = ProfilingInfo ty_descr_w8 (BS8.pack val_descr) where ty_descr_w8 = BS8.pack (getTyDescription (idType id)) @@ -891,8 +894,8 @@ -- CmmInfoTable-related things -------------------------------------- -mkDataConInfoTable :: DynFlags -> DataCon -> Bool -> Int -> Int -> CmmInfoTable-mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds+mkDataConInfoTable :: Profile -> DataCon -> Bool -> Int -> Int -> CmmInfoTable+mkDataConInfoTable profile data_con is_static ptr_wds nonptr_wds = CmmInfoTable { cit_lbl = info_lbl , cit_rep = sm_rep , cit_prof = prof@@ -901,12 +904,12 @@ where name = dataConName data_con info_lbl = mkConInfoTableLabel name NoCafRefs- sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type+ sm_rep = mkHeapRep profile is_static ptr_wds nonptr_wds cl_type cl_type = Constr (dataConTagZ data_con) (dataConIdentity data_con) -- We keep the *zero-indexed* tag in the srt_len field -- of the info table of a data constructor. - prof | not (sccProfilingEnabled dflags) = NoProfilingInfo+ prof | not (profileIsProfiling profile) = NoProfilingInfo | otherwise = ProfilingInfo ty_descr val_descr ty_descr = BS8.pack $ occNameString $ getOccName $ dataConTyCon data_con
compiler/GHC/StgToCmm/DataCon.hs view
@@ -19,6 +19,9 @@ import GHC.Prelude +import GHC.Platform+import GHC.Platform.Profile+ import GHC.Stg.Syntax import GHC.Core ( AltCon(..) ) @@ -46,7 +49,6 @@ import GHC.Types.Literal import GHC.Builtin.Utils import GHC.Utils.Outputable-import GHC.Platform import GHC.Utils.Misc import GHC.Utils.Monad (mapMaybeM) @@ -79,14 +81,16 @@ = (id_Info, gen_code) where- id_Info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label)+ platform = targetPlatform dflags+ id_Info = litIdInfo platform id (mkConLFInfo con) (CmmLabel closure_label) name = idName id caffy = idCafInfo id -- any stgArgHasCafRefs args closure_label = mkClosureLabel name caffy gen_code =- do { this_mod <- getModuleName- ; when (platformOS (targetPlatform dflags) == OSMinGW32) $+ do { profile <- getProfile+ ; this_mod <- getModuleName+ ; when (platformOS platform == OSMinGW32) $ -- Windows DLLs have a problem with static cross-DLL refs. MASSERT( not (isDllConApp dflags this_mod con (map fromNonVoid args)) ) ; ASSERT( args `lengthIs` countConRepArgs con ) return ()@@ -96,7 +100,7 @@ (tot_wds, -- #ptr_wds + #nonptr_wds ptr_wds, -- #ptr_wds nv_args_w_offsets) =- mkVirtHeapOffsetsWithPadding dflags StdHeader (addArgReps args)+ mkVirtHeapOffsetsWithPadding profile StdHeader (addArgReps args) mk_payload (Padding len _) = return (CmmInt 0 (widthFromBytes len)) mk_payload (FieldOff arg _) = do@@ -110,7 +114,7 @@ -- we're not really going to emit an info table, so having -- to make a CmmInfoTable is a bit overkill, but mkStaticClosureFields -- needs to poke around inside it.- info_tbl = mkDataConInfoTable dflags con True ptr_wds nonptr_wds+ info_tbl = mkDataConInfoTable profile con True ptr_wds nonptr_wds ; payload <- mapM mk_payload nv_args_w_offsets@@ -165,7 +169,7 @@ = return (cgInfo, return mkNop) -------- buildDynCon': the general case ------------buildDynCon' dflags binder actually_bound ccs con args+buildDynCon' _ binder actually_bound ccs con args = do { (id_info, reg) <- rhsIdInfo binder lf_info ; return (id_info, gen_code reg) }@@ -173,17 +177,19 @@ lf_info = mkConLFInfo con gen_code reg- = do { let (tot_wds, ptr_wds, args_w_offsets)- = mkVirtConstrOffsets dflags (addArgReps args)+ = do { profile <- getProfile+ ; let platform = profilePlatform profile+ (tot_wds, ptr_wds, args_w_offsets)+ = mkVirtConstrOffsets profile (addArgReps args) nonptr_wds = tot_wds - ptr_wds- info_tbl = mkDataConInfoTable dflags con False+ info_tbl = mkDataConInfoTable profile con False ptr_wds nonptr_wds ; let ticky_name | actually_bound = Just binder | otherwise = Nothing ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info use_cc blame_cc args_w_offsets- ; return (mkRhsInit dflags reg lf_info hp_plus_n) }+ ; return (mkRhsInit platform reg lf_info hp_plus_n) } where use_cc -- cost-centre to stick in the object | isCurrentCCS ccs = cccsExpr@@ -293,7 +299,7 @@ precomputedStaticConInfo_maybe dflags binder con [] -- Nullary constructors | isNullaryRepDataCon con- = Just $ litIdInfo dflags binder (mkConLFInfo con)+ = Just $ litIdInfo (targetPlatform dflags) binder (mkConLFInfo con) (CmmLabel (mkClosureLabel (dataConName con) NoCafRefs)) precomputedStaticConInfo_maybe dflags binder con [arg] -- Int/Char values with existing closures in the RTS@@ -303,12 +309,13 @@ , inRange val = let intlike_lbl = mkCmmClosureLabel rtsUnitId (fsLit label) val_int = fromIntegral val :: Int- offsetW = (val_int - (fromIntegral min_static_range)) * (fixedHdrSizeW dflags + 1)+ offsetW = (val_int - (fromIntegral min_static_range)) * (fixedHdrSizeW profile + 1) -- INTLIKE/CHARLIKE closures consist of a header and one word payload static_amode = cmmLabelOffW platform intlike_lbl offsetW- in Just $ litIdInfo dflags binder (mkConLFInfo con) static_amode+ in Just $ litIdInfo platform binder (mkConLFInfo con) static_amode where- platform = targetPlatform dflags+ profile = targetProfile dflags+ platform = profilePlatform profile intClosure = maybeIntLikeCon con charClosure = maybeCharLikeCon con getClosurePayload (NonVoid (StgLitArg (LitNumber LitNumInt val))) = Just val@@ -319,14 +326,16 @@ inRange val = val >= min_static_range && val <= max_static_range + constants = platformConstants platform+ min_static_range :: Integer min_static_range- | intClosure = fromIntegral (mIN_INTLIKE dflags)- | charClosure = fromIntegral (mIN_CHARLIKE dflags)+ | intClosure = fromIntegral (pc_MIN_INTLIKE constants)+ | charClosure = fromIntegral (pc_MIN_CHARLIKE constants) | otherwise = panic "precomputedStaticConInfo_maybe: Unknown closure type" max_static_range- | intClosure = fromIntegral (mAX_INTLIKE dflags)- | charClosure = fromIntegral (mAX_CHARLIKE dflags)+ | intClosure = fromIntegral (pc_MAX_INTLIKE constants)+ | charClosure = fromIntegral (pc_MAX_CHARLIKE constants) | otherwise = panic "precomputedStaticConInfo_maybe: Unknown closure type" label | intClosure = "stg_INTLIKE"@@ -346,10 +355,10 @@ -- found a con bindConArgs (DataAlt con) base args = ASSERT(not (isUnboxedTupleCon con))- do dflags <- getDynFlags+ do profile <- getProfile platform <- getPlatform- let (_, _, args_w_offsets) = mkVirtConstrOffsets dflags (addIdReps args)- tag = tagForCon dflags con+ let (_, _, args_w_offsets) = mkVirtConstrOffsets profile (addIdReps args)+ tag = tagForCon platform con -- The binding below forces the masking out of the tag bits -- when accessing the constructor field.
compiler/GHC/StgToCmm/Env.hs view
@@ -58,13 +58,12 @@ = CgIdInfo { cg_id = id, cg_lf = lf , cg_loc = CmmLoc expr } -litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo-litIdInfo dflags id lf lit+litIdInfo :: Platform -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo+litIdInfo platform id lf lit = CgIdInfo { cg_id = id, cg_lf = lf , cg_loc = CmmLoc (addDynTag platform (CmmLit lit) tag) } where- tag = lfDynTag dflags lf- platform = targetPlatform dflags+ tag = lfDynTag platform lf lneIdInfo :: Platform -> Id -> [NonVoid Id] -> CgIdInfo lneIdInfo platform id regs@@ -81,10 +80,9 @@ reg <- newTemp (gcWord platform) return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg) -mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph-mkRhsInit dflags reg lf_info expr- = mkAssign (CmmLocal reg) (addDynTag platform expr (lfDynTag dflags lf_info))- where platform = targetPlatform dflags+mkRhsInit :: Platform -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph+mkRhsInit platform reg lf_info expr+ = mkAssign (CmmLocal reg) (addDynTag platform expr (lfDynTag platform lf_info)) idInfoToAmode :: CgIdInfo -> CmmExpr -- Returns a CmmExpr for the *tagged* pointer@@ -124,7 +122,7 @@ getCgIdInfo :: Id -> FCode CgIdInfo getCgIdInfo id- = do { dflags <- getDynFlags+ = do { platform <- targetPlatform <$> getDynFlags ; local_binds <- getBinds -- Try local bindings first ; case lookupVarEnv local_binds id of { Just info -> return info ;@@ -141,7 +139,7 @@ mkBytesLabel name | otherwise = mkClosureLabel name $ idCafInfo id in return $- litIdInfo dflags id (mkLFImported id) (CmmLabel ext_lbl)+ litIdInfo platform id (mkLFImported id) (CmmLabel ext_lbl) else cgLookupPanic id -- Bug }}}
compiler/GHC/StgToCmm/Expr.hs view
@@ -36,9 +36,9 @@ import GHC.Cmm.BlockId import GHC.Cmm hiding ( succ ) import GHC.Cmm.Info+import GHC.Cmm.Utils ( mAX_PTR_TAG ) import GHC.Core import GHC.Core.DataCon-import GHC.Driver.Session ( mAX_PTR_TAG ) import GHC.Types.ForeignCall import GHC.Types.Id import GHC.Builtin.PrimOps@@ -71,13 +71,13 @@ -- dataToTag# :: a -> Int# -- See Note [dataToTag#] in primops.txt.pp cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do- dflags <- getDynFlags platform <- getPlatform emitComment (mkFastString "dataToTag#") tmp <- newTemp (bWord platform) _ <- withSequel (AssignTo [tmp] False) (cgIdApp a []) -- TODO: For small types look at the tag bits instead of reading info table- emitReturn [getConstrTag dflags (cmmUntag dflags (CmmReg (CmmLocal tmp)))]+ ptr_opts <- getPtrOpts+ emitReturn [getConstrTag ptr_opts (cmmUntag platform (CmmReg (CmmLocal tmp)))] cgExpr (StgOpApp op args ty) = cgOpApp op args ty cgExpr (StgConApp con args _)= cgConApp con args@@ -564,18 +564,17 @@ ; return AssignedDirectly } cgAlts gc_plan bndr (AlgAlt tycon) alts- = do { dflags <- getDynFlags- ; platform <- getPlatform+ = do { platform <- getPlatform ; (mb_deflt, branches) <- cgAlgAltRhss gc_plan bndr alts ; let !fam_sz = tyConFamilySize tycon !bndr_reg = CmmLocal (idToReg platform bndr)- !ptag_expr = cmmConstrTag1 dflags (CmmReg bndr_reg)+ !ptag_expr = cmmConstrTag1 platform (CmmReg bndr_reg) !branches' = first succ <$> branches- !maxpt = mAX_PTR_TAG dflags+ !maxpt = mAX_PTR_TAG platform (!via_ptr, !via_info) = partition ((< maxpt) . fst) branches'- !small = isSmallFamily dflags fam_sz+ !small = isSmallFamily platform fam_sz -- Is the constructor tag in the node reg? -- See Note [Tagging big families]@@ -587,8 +586,9 @@ else -- No, the get exact tag from info table when mAX_PTR_TAG -- See Note [Double switching for big families] do- let !untagged_ptr = cmmUntag dflags (CmmReg bndr_reg)- !itag_expr = getConstrTag dflags untagged_ptr+ ptr_opts <- getPtrOpts+ let !untagged_ptr = cmmUntag platform (CmmReg bndr_reg)+ !itag_expr = getConstrTag ptr_opts untagged_ptr !info0 = first pred <$> via_info if null via_ptr then emitSwitch itag_expr info0 mb_deflt 0 (fam_sz - 1)@@ -857,17 +857,17 @@ cgIdApp :: Id -> [StgArg] -> FCode ReturnKind cgIdApp fun_id args = do- dflags <- getDynFlags fun_info <- getCgIdInfo fun_id self_loop_info <- getSelfLoop+ call_opts <- getCallOpts+ profile <- getProfile let fun_arg = StgVarArg fun_id fun_name = idName fun_id fun = idInfoToAmode fun_info lf_info = cg_lf fun_info n_args = length args v_args = length $ filter (isVoidTy . stgArgType) args- node_points dflags = nodeMustPointToIt dflags lf_info- case getCallMethod dflags fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop_info of+ case getCallMethod call_opts fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop_info of -- A value in WHNF, so we can just return it. ReturnIt | isVoidTy (idType fun_id) -> emitReturn []@@ -885,7 +885,7 @@ -- A direct function call (possibly with some left-over arguments) DirectEntry lbl arity -> do { tickyDirectCall arity args- ; if node_points dflags+ ; if nodeMustPointToIt profile lf_info then directCall NativeNodeCall lbl arity (fun_arg:args) else directCall NativeDirectCall lbl arity args } @@ -1006,8 +1006,9 @@ emitEnter :: CmmExpr -> FCode ReturnKind emitEnter fun = do- { dflags <- getDynFlags+ { ptr_opts <- getPtrOpts ; platform <- getPlatform+ ; profile <- getProfile ; adjustHpBackwards ; sequel <- getSequel ; updfr_off <- getUpdFrameOff@@ -1021,9 +1022,9 @@ -- Right now, we do what the old codegen did, and omit the tag -- test, just generating an enter. Return -> do- { let entry = entryCode platform $ closureInfoPtr dflags $ CmmReg nodeReg- ; emit $ mkJump dflags NativeNodeCall entry- [cmmUntag dflags fun] updfr_off+ { let entry = entryCode platform $ closureInfoPtr ptr_opts $ CmmReg nodeReg+ ; emit $ mkJump profile NativeNodeCall entry+ [cmmUntag platform fun] updfr_off ; return AssignedDirectly } @@ -1054,21 +1055,21 @@ -- AssignTo res_regs _ -> do { lret <- newBlockId- ; let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs []+ ; let (off, _, copyin) = copyInOflow profile NativeReturn (Young lret) res_regs [] ; lcall <- newBlockId ; updfr_off <- getUpdFrameOff ; let area = Young lret- ; let (outArgs, regs, copyout) = copyOutOflow dflags NativeNodeCall Call area+ ; let (outArgs, regs, copyout) = copyOutOflow profile NativeNodeCall Call area [fun] updfr_off [] -- refer to fun via nodeReg after the copyout, to avoid having -- both live simultaneously; this sometimes enables fun to be -- inlined in the RHS of the R1 assignment.- ; let entry = entryCode platform (closureInfoPtr dflags (CmmReg nodeReg))+ ; let entry = entryCode platform (closureInfoPtr ptr_opts (CmmReg nodeReg)) the_call = toCall entry (Just lret) updfr_off off outArgs regs ; tscope <- getTickScope ; emit $ copyout <*>- mkCbranch (cmmIsTagged dflags (CmmReg nodeReg))+ mkCbranch (cmmIsTagged platform (CmmReg nodeReg)) lret lcall Nothing <*> outOfLine lcall (the_call,tscope) <*> mkLabel lret tscope <*>
compiler/GHC/StgToCmm/ExtCode.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE TupleSections #-} -- | Our extended FCode monad. -- We add a mapping from names to CmmExpr, to support local variable names in@@ -32,19 +33,24 @@ emit, emitLabel, emitAssign, emitStore, getCode, getCodeR, getCodeScoped, emitOutOfLine,- withUpdFrameOff, getUpdFrameOff+ withUpdFrameOff, getUpdFrameOff,+ getProfile, getPlatform, getPtrOpts ) where import GHC.Prelude +import GHC.Platform+import GHC.Platform.Profile+ import qualified GHC.StgToCmm.Monad as F import GHC.StgToCmm.Monad (FCode, newUnique) import GHC.Cmm import GHC.Cmm.CLabel import GHC.Cmm.Graph+import GHC.Cmm.Info import GHC.Cmm.BlockId import GHC.Driver.Session@@ -65,7 +71,7 @@ | LabelN BlockId -- ^ A blockid of some code or data. -- | An environment of named things.-type Env = UniqFM Named+type Env = UniqFM FastString Named -- | Local declarations that are in scope during code generation. type Decls = [(FastString,Named)]@@ -98,9 +104,16 @@ return (decls, u) instance HasDynFlags CmmParse where- getDynFlags = EC (\_ _ d -> do dflags <- getDynFlags- return (d, dflags))+ getDynFlags = EC (\_ _ d -> (d,) <$> getDynFlags) +getProfile :: CmmParse Profile+getProfile = EC (\_ _ d -> (d,) <$> F.getProfile)++getPlatform :: CmmParse Platform+getPlatform = EC (\_ _ d -> (d,) <$> F.getPlatform)++getPtrOpts :: CmmParse PtrOpts+getPtrOpts = EC (\_ _ d -> (d,) <$> F.getPtrOpts) -- | Takes the variable declarations and imports from the monad -- and makes an environment, which is looped back into the computation.
compiler/GHC/StgToCmm/Foreign.hs view
@@ -22,6 +22,9 @@ import GHC.Prelude hiding( succ, (<*>) ) +import GHC.Platform+import GHC.Platform.Profile+ import GHC.Stg.Syntax import GHC.StgToCmm.Prof (storeCurCCS, ccsType) import GHC.StgToCmm.Env@@ -40,8 +43,6 @@ import GHC.Cmm.CLabel import GHC.Runtime.Heap.Layout import GHC.Types.ForeignCall-import GHC.Driver.Session-import GHC.Platform import GHC.Data.Maybe import GHC.Utils.Outputable import GHC.Types.Unique.Supply@@ -216,8 +217,8 @@ -> FCode ReturnKind emitForeignCall safety results target args | not (playSafe safety) = do- dflags <- getDynFlags- let (caller_save, caller_load) = callerSaveVolatileRegs dflags+ platform <- getPlatform+ let (caller_save, caller_load) = callerSaveVolatileRegs platform emit caller_save target' <- load_target_into_temp target args' <- mapM maybe_assign_temp args@@ -226,13 +227,13 @@ return AssignedDirectly | otherwise = do- dflags <- getDynFlags+ profile <- getProfile platform <- getPlatform updfr_off <- getUpdFrameOff target' <- load_target_into_temp target args' <- mapM maybe_assign_temp args k <- newBlockId- let (off, _, copyout) = copyInOflow dflags NativeReturn (Young k) results []+ let (off, _, copyout) = copyInOflow profile NativeReturn (Young k) results [] -- see Note [safe foreign call convention] tscope <- getTickScope emit $@@ -283,32 +284,35 @@ emitSaveThreadState :: FCode () emitSaveThreadState = do- dflags <- getDynFlags- code <- saveThreadState dflags+ profile <- getProfile+ code <- saveThreadState profile emit code -- | Produce code to save the current thread state to @CurrentTSO@-saveThreadState :: MonadUnique m => DynFlags -> m CmmAGraph-saveThreadState dflags = do- let platform = targetPlatform dflags+saveThreadState :: MonadUnique m => Profile -> m CmmAGraph+saveThreadState profile = do+ let platform = profilePlatform profile tso <- newTemp (gcWord platform)- close_nursery <- closeNursery dflags tso- pure $ catAGraphs [- -- tso = CurrentTSO;- mkAssign (CmmLocal tso) currentTSOExpr,- -- tso->stackobj->sp = Sp;- mkStore (cmmOffset platform- (CmmLoad (cmmOffset platform- (CmmReg (CmmLocal tso))- (tso_stackobj dflags))- (bWord platform))- (stack_SP dflags))- spExpr,- close_nursery,- -- and save the current cost centre stack in the TSO when profiling:- if sccProfilingEnabled dflags then- mkStore (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) cccsExpr- else mkNop+ close_nursery <- closeNursery profile tso+ pure $ catAGraphs+ [ -- tso = CurrentTSO;+ mkAssign (CmmLocal tso) currentTSOExpr++ , -- tso->stackobj->sp = Sp;+ mkStore (cmmOffset platform+ (CmmLoad (cmmOffset platform+ (CmmReg (CmmLocal tso))+ (tso_stackobj profile))+ (bWord platform))+ (stack_SP profile))+ spExpr++ , close_nursery++ , -- and save the current cost centre stack in the TSO when profiling:+ if profileIsProfiling profile+ then mkStore (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS profile)) cccsExpr+ else mkNop ] @@ -323,26 +327,26 @@ -- are live, we might have to save them all. emitSaveRegs :: FCode () emitSaveRegs = do- dflags <- getDynFlags- let regs = realArgRegsCover dflags- save = catAGraphs (map (callerSaveGlobalReg dflags) regs)+ platform <- getPlatform+ let regs = realArgRegsCover platform+ save = catAGraphs (map (callerSaveGlobalReg platform) regs) emit save -- | Restore STG registers (see 'emitSaveRegs') emitRestoreRegs :: FCode () emitRestoreRegs = do- dflags <- getDynFlags- let regs = realArgRegsCover dflags- save = catAGraphs (map (callerRestoreGlobalReg dflags) regs)- emit save+ platform <- getPlatform+ let regs = realArgRegsCover platform+ restore = catAGraphs (map (callerRestoreGlobalReg platform) regs)+ emit restore emitCloseNursery :: FCode () emitCloseNursery = do- dflags <- getDynFlags- platform <- getPlatform+ profile <- getProfile+ let platform = profilePlatform profile tso <- newTemp (bWord platform)- code <- closeNursery dflags tso+ code <- closeNursery profile tso emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code {- |@@ -366,24 +370,24 @@ cn->free = Hp + WDS(1); @ -}-closeNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph-closeNursery df tso = do- let tsoreg = CmmLocal tso- platform = targetPlatform df+closeNursery :: MonadUnique m => Profile -> LocalReg -> m CmmAGraph+closeNursery profile tso = do+ let tsoreg = CmmLocal tso+ platform = profilePlatform profile cnreg <- CmmLocal <$> newTemp (bWord platform) pure $ catAGraphs [ mkAssign cnreg currentNurseryExpr, -- CurrentNursery->free = Hp+1;- mkStore (nursery_bdescr_free df cnreg) (cmmOffsetW platform hpExpr 1),+ mkStore (nursery_bdescr_free platform cnreg) (cmmOffsetW platform hpExpr 1), let alloc = CmmMachOp (mo_wordSub platform) [ cmmOffsetW platform hpExpr 1- , CmmLoad (nursery_bdescr_start df cnreg) (bWord platform)+ , CmmLoad (nursery_bdescr_start platform cnreg) (bWord platform) ] - alloc_limit = cmmOffset platform (CmmReg tsoreg) (tso_alloc_limit df)+ alloc_limit = cmmOffset platform (CmmReg tsoreg) (tso_alloc_limit profile) in -- tso->alloc_limit += alloc@@ -394,51 +398,51 @@ emitLoadThreadState :: FCode () emitLoadThreadState = do- dflags <- getDynFlags- code <- loadThreadState dflags+ profile <- getProfile+ code <- loadThreadState profile emit code -- | Produce code to load the current thread state from @CurrentTSO@-loadThreadState :: MonadUnique m => DynFlags -> m CmmAGraph-loadThreadState dflags = do- let platform = targetPlatform dflags+loadThreadState :: MonadUnique m => Profile -> m CmmAGraph+loadThreadState profile = do+ let platform = profilePlatform profile tso <- newTemp (gcWord platform) stack <- newTemp (gcWord platform)- open_nursery <- openNursery dflags tso+ open_nursery <- openNursery profile tso pure $ catAGraphs [ -- tso = CurrentTSO; mkAssign (CmmLocal tso) currentTSOExpr, -- stack = tso->stackobj;- mkAssign (CmmLocal stack) (CmmLoad (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord platform)),+ mkAssign (CmmLocal stack) (CmmLoad (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_stackobj profile)) (bWord platform)), -- Sp = stack->sp;- mkAssign spReg (CmmLoad (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord platform)),+ mkAssign spReg (CmmLoad (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_SP profile)) (bWord platform)), -- SpLim = stack->stack + RESERVED_STACK_WORDS;- mkAssign spLimReg (cmmOffsetW platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_STACK dflags))- (rESERVED_STACK_WORDS dflags)),+ mkAssign spLimReg (cmmOffsetW platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_STACK profile))+ (pc_RESERVED_STACK_WORDS (platformConstants platform))), -- HpAlloc = 0; -- HpAlloc is assumed to be set to non-zero only by a failed -- a heap check, see HeapStackCheck.cmm:GC_GENERIC mkAssign hpAllocReg (zeroExpr platform), open_nursery, -- and load the current cost centre stack from the TSO when profiling:- if sccProfilingEnabled dflags+ if profileIsProfiling profile then storeCurCCS (CmmLoad (cmmOffset platform (CmmReg (CmmLocal tso))- (tso_CCCS dflags)) (ccsType platform))+ (tso_CCCS profile)) (ccsType platform)) else mkNop ] emitOpenNursery :: FCode () emitOpenNursery = do- dflags <- getDynFlags- platform <- getPlatform+ profile <- getProfile+ let platform = profilePlatform profile tso <- newTemp (bWord platform)- code <- openNursery dflags tso+ code <- openNursery profile tso emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code {- |-@openNursery dflags tso@ produces code to open the nursery. A local register+@openNursery profile tso@ produces code to open the nursery. A local register holding the value of @CurrentTSO@ is expected for efficiency. Opening the nursery corresponds to the following code:@@ -465,10 +469,10 @@ HpLim = bdstart + CurrentNursery->blocks*BLOCK_SIZE_W - 1; @ -}-openNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph-openNursery dflags tso = do- let tsoreg = CmmLocal tso- platform = targetPlatform dflags+openNursery :: MonadUnique m => Profile -> LocalReg -> m CmmAGraph+openNursery profile tso = do+ let tsoreg = CmmLocal tso+ platform = profilePlatform profile cnreg <- CmmLocal <$> newTemp (bWord platform) bdfreereg <- CmmLocal <$> newTemp (bWord platform) bdstartreg <- CmmLocal <$> newTemp (bWord platform)@@ -479,12 +483,12 @@ -- stg_returnToStackTop in rts/StgStartup.cmm. pure $ catAGraphs [ mkAssign cnreg currentNurseryExpr,- mkAssign bdfreereg (CmmLoad (nursery_bdescr_free dflags cnreg) (bWord platform)),+ mkAssign bdfreereg (CmmLoad (nursery_bdescr_free platform cnreg) (bWord platform)), -- Hp = CurrentNursery->free - 1; mkAssign hpReg (cmmOffsetW platform (CmmReg bdfreereg) (-1)), - mkAssign bdstartreg (CmmLoad (nursery_bdescr_start dflags cnreg) (bWord platform)),+ mkAssign bdstartreg (CmmLoad (nursery_bdescr_start platform cnreg) (bWord platform)), -- HpLim = CurrentNursery->start + -- CurrentNursery->blocks*BLOCK_SIZE_W - 1;@@ -494,8 +498,8 @@ (cmmOffset platform (CmmMachOp (mo_wordMul platform) [ CmmMachOp (MO_SS_Conv W32 (wordWidth platform))- [CmmLoad (nursery_bdescr_blocks dflags cnreg) b32],- mkIntExpr platform (bLOCK_SIZE dflags)+ [CmmLoad (nursery_bdescr_blocks platform cnreg) b32],+ mkIntExpr platform (pc_BLOCK_SIZE (platformConstants platform)) ]) (-1) )@@ -505,7 +509,7 @@ let alloc = CmmMachOp (mo_wordSub platform) [CmmReg bdfreereg, CmmReg bdstartreg] - alloc_limit = cmmOffset platform (CmmReg tsoreg) (tso_alloc_limit dflags)+ alloc_limit = cmmOffset platform (CmmReg tsoreg) (tso_alloc_limit profile) in -- tso->alloc_limit += alloc@@ -516,24 +520,24 @@ ] nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks- :: DynFlags -> CmmReg -> CmmExpr-nursery_bdescr_free dflags cn =- cmmOffset (targetPlatform dflags) (CmmReg cn) (oFFSET_bdescr_free dflags)-nursery_bdescr_start dflags cn =- cmmOffset (targetPlatform dflags) (CmmReg cn) (oFFSET_bdescr_start dflags)-nursery_bdescr_blocks dflags cn =- cmmOffset (targetPlatform dflags) (CmmReg cn) (oFFSET_bdescr_blocks dflags)+ :: Platform -> CmmReg -> CmmExpr+nursery_bdescr_free platform cn =+ cmmOffset platform (CmmReg cn) (pc_OFFSET_bdescr_free (platformConstants platform))+nursery_bdescr_start platform cn =+ cmmOffset platform (CmmReg cn) (pc_OFFSET_bdescr_start (platformConstants platform))+nursery_bdescr_blocks platform cn =+ cmmOffset platform (CmmReg cn) (pc_OFFSET_bdescr_blocks (platformConstants platform)) -tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: DynFlags -> ByteOff-tso_stackobj dflags = closureField dflags (oFFSET_StgTSO_stackobj dflags)-tso_alloc_limit dflags = closureField dflags (oFFSET_StgTSO_alloc_limit dflags)-tso_CCCS dflags = closureField dflags (oFFSET_StgTSO_cccs dflags)-stack_STACK dflags = closureField dflags (oFFSET_StgStack_stack dflags)-stack_SP dflags = closureField dflags (oFFSET_StgStack_sp dflags)+tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: Profile -> ByteOff+tso_stackobj profile = closureField profile (pc_OFFSET_StgTSO_stackobj (profileConstants profile))+tso_alloc_limit profile = closureField profile (pc_OFFSET_StgTSO_alloc_limit (profileConstants profile))+tso_CCCS profile = closureField profile (pc_OFFSET_StgTSO_cccs (profileConstants profile))+stack_STACK profile = closureField profile (pc_OFFSET_StgStack_stack (profileConstants profile))+stack_SP profile = closureField profile (pc_OFFSET_StgStack_sp (profileConstants profile)) -closureField :: DynFlags -> ByteOff -> ByteOff-closureField dflags off = off + fixedHdrSize dflags+closureField :: Profile -> ByteOff -> ByteOff+closureField profile off = off + fixedHdrSize profile -- Note [Unlifted boxed arguments to foreign calls] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -601,8 +605,8 @@ = return Nothing | otherwise = do { cmm <- getArgAmode (NonVoid arg)- ; dflags <- getDynFlags- ; return (Just (add_shim dflags typ cmm, hint)) }+ ; profile <- getProfile+ ; return (Just (add_shim profile typ cmm, hint)) } where arg_ty = stgArgType arg arg_reps = typePrimRep arg_ty@@ -618,14 +622,14 @@ | StgByteArrayType -- See Note [Unlifted boxed arguments to foreign calls]-add_shim :: DynFlags -> StgFArgType -> CmmExpr -> CmmExpr-add_shim dflags ty expr = case ty of- StgPlainType -> expr- StgArrayType -> cmmOffsetB platform expr (arrPtrsHdrSize dflags)- StgSmallArrayType -> cmmOffsetB platform expr (smallArrPtrsHdrSize dflags)- StgByteArrayType -> cmmOffsetB platform expr (arrWordsHdrSize dflags)+add_shim :: Profile -> StgFArgType -> CmmExpr -> CmmExpr+add_shim profile ty expr = case ty of+ StgPlainType -> expr+ StgArrayType -> cmmOffsetB platform expr (arrPtrsHdrSize profile)+ StgSmallArrayType -> cmmOffsetB platform expr (smallArrPtrsHdrSize profile)+ StgByteArrayType -> cmmOffsetB platform expr (arrWordsHdrSize profile) where- platform = targetPlatform dflags+ platform = profilePlatform profile -- From a function, extract information needed to determine -- the offset of each argument when used as a C FFI argument.
compiler/GHC/StgToCmm/Heap.hs view
@@ -47,6 +47,7 @@ import GHC.Unit import GHC.Driver.Session import GHC.Platform+import GHC.Platform.Profile import GHC.Data.FastString( mkFastString, fsLit ) import GHC.Utils.Panic( sorry ) @@ -135,20 +136,19 @@ hpStore base payload -- Bump the virtual heap pointer- dflags <- getDynFlags- setVirtHp (virt_hp + heapClosureSizeW dflags rep)+ profile <- getProfile+ setVirtHp (virt_hp + heapClosureSizeW profile rep) return base emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () emitSetDynHdr base info_ptr ccs- = do dflags <- getDynFlags- let platform = targetPlatform dflags- hpStore base (zip (header dflags) [0, platformWordSizeInBytes platform ..])+ = do profile <- getProfile+ hpStore base (zip (header profile) [0, profileWordSizeInBytes profile ..]) where- header :: DynFlags -> [CmmExpr]- header dflags = [info_ptr] ++ dynProfHdr dflags ccs+ header :: Profile -> [CmmExpr]+ header profile = [info_ptr] ++ dynProfHdr profile ccs -- ToDo: Parallel stuff -- No ticky header @@ -167,17 +167,17 @@ -- and adding a static link field if necessary. mkStaticClosureFields- :: DynFlags+ :: Profile -> CmmInfoTable -> CostCentreStack -> CafInfo -> [CmmLit] -- Payload -> [CmmLit] -- The full closure-mkStaticClosureFields dflags info_tbl ccs caf_refs payload- = mkStaticClosure dflags info_lbl ccs payload padding+mkStaticClosureFields profile info_tbl ccs caf_refs payload+ = mkStaticClosure profile info_lbl ccs payload padding static_link_field saved_info_field where- platform = targetPlatform dflags+ platform = profilePlatform profile info_lbl = cit_lbl info_tbl -- CAFs must have consistent layout, regardless of whether they@@ -219,11 +219,11 @@ -- See Note [STATIC_LINK fields] -- in rts/sm/Storage.h -mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit]+mkStaticClosure :: Profile -> CLabel -> CostCentreStack -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]-mkStaticClosure dflags info_lbl ccs payload padding static_link_field saved_info_field+mkStaticClosure profile info_lbl ccs payload padding static_link_field saved_info_field = [CmmLabel info_lbl]- ++ staticProfHdr dflags ccs+ ++ staticProfHdr profile ccs ++ payload ++ padding ++ static_link_field@@ -333,17 +333,19 @@ -> FCode () -> FCode () -entryHeapCheck cl_info nodeSet arity args code- = entryHeapCheck' is_fastf node arity args code- where+entryHeapCheck cl_info nodeSet arity args code = do+ platform <- getPlatform+ let node = case nodeSet of Just r -> CmmReg (CmmLocal r)- Nothing -> CmmLit (CmmLabel $ staticClosureLabel cl_info)+ Nothing -> CmmLit (CmmLabel $ staticClosureLabel platform cl_info) is_fastf = case closureFunInfo cl_info of Just (_, ArgGen _) -> False _otherwise -> True + entryHeapCheck' is_fastf node arity args code+ -- | lower-level version for "GHC.Cmm.Parser" entryHeapCheck' :: Bool -- is a known function pattern -> CmmExpr -- expression for the closure pointer@@ -352,7 +354,7 @@ -> FCode () -> FCode () entryHeapCheck' is_fastf node arity args code- = do dflags <- getDynFlags+ = do profile <- getProfile let is_thunk = arity == 0 args' = map (CmmReg . CmmLocal) args@@ -367,13 +369,13 @@ -} gc_call upd | is_thunk- = mkJump dflags NativeNodeCall stg_gc_enter1 [node] upd+ = mkJump profile NativeNodeCall stg_gc_enter1 [node] upd | is_fastf- = mkJump dflags NativeNodeCall stg_gc_fun (node : args') upd+ = mkJump profile NativeNodeCall stg_gc_fun (node : args') upd | otherwise- = mkJump dflags Slow stg_gc_fun (node : args') upd+ = mkJump profile Slow stg_gc_fun (node : args') upd updfr_sz <- getUpdFrameOff @@ -404,13 +406,13 @@ altOrNoEscapeHeapCheck :: Bool -> [LocalReg] -> FCode a -> FCode a altOrNoEscapeHeapCheck checkYield regs code = do- dflags <- getDynFlags+ profile <- getProfile platform <- getPlatform case cannedGCEntryPoint platform regs of Nothing -> genericGC checkYield code Just gc -> do lret <- newBlockId- let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) regs []+ let (off, _, copyin) = copyInOflow profile NativeReturn (Young lret) regs [] lcont <- newBlockId tscope <- getTickScope emitOutOfLine lret (copyin <*> mkBranch lcont, tscope)@@ -434,9 +436,9 @@ -> FCode a -> FCode a cannedGCReturnsTo checkYield cont_on_stack gc regs lret off code- = do dflags <- getDynFlags+ = do profile <- getProfile updfr_sz <- getUpdFrameOff- heapCheck False checkYield (gc_call dflags gc updfr_sz) code+ heapCheck False checkYield (gc_call profile gc updfr_sz) code where reg_exprs = map (CmmReg . CmmLocal) regs -- Note [stg_gc arguments]@@ -445,11 +447,11 @@ -- to the canned heap-check routines, because we are in a case -- alternative and hence the [LocalReg] was passed to us in the -- NativeReturn convention.- gc_call dflags label sp+ gc_call profile label sp | cont_on_stack- = mkJumpReturnsTo dflags label NativeReturn reg_exprs lret off sp+ = mkJumpReturnsTo profile label NativeReturn reg_exprs lret off sp | otherwise- = mkCallReturnsTo dflags label NativeReturn reg_exprs lret off sp []+ = mkCallReturnsTo profile label NativeReturn reg_exprs lret off sp [] genericGC :: Bool -> FCode a -> FCode a genericGC checkYield code@@ -521,8 +523,7 @@ = getHeapUsage $ \ hpHw -> -- Emit heap checks, but be sure to do it lazily so -- that the conditionals on hpHw don't cause a black hole- do { dflags <- getDynFlags- ; platform <- getPlatform+ do { platform <- getPlatform ; let mb_alloc_bytes | hpHw > mBLOCK_SIZE = sorry $ unlines [" Trying to allocate more than "++show mBLOCK_SIZE++" bytes.",@@ -533,7 +534,10 @@ "structures in code."] | hpHw > 0 = Just (mkIntExpr platform (hpHw * (platformWordSizeInBytes platform))) | otherwise = Nothing- where mBLOCK_SIZE = bLOCKS_PER_MBLOCK dflags * bLOCK_SIZE_W dflags+ where+ constants = platformConstants platform+ bLOCK_SIZE_W = pc_BLOCK_SIZE (platformConstants platform) `quot` platformWordSizeInBytes platform+ mBLOCK_SIZE = pc_BLOCKS_PER_MBLOCK constants * bLOCK_SIZE_W stk_hwm | checkStack = Just (CmmLit CmmHighStackMark) | otherwise = Nothing ; codeOnly $ do_checks stk_hwm checkYield mb_alloc_bytes do_gc
compiler/GHC/StgToCmm/Layout.hs view
@@ -54,6 +54,7 @@ import GHC.Types.Basic ( RepArity ) import GHC.Driver.Session import GHC.Platform+import GHC.Platform.Profile import GHC.Unit import GHC.Utils.Misc@@ -78,7 +79,7 @@ -- emitReturn :: [CmmExpr] -> FCode ReturnKind emitReturn results- = do { dflags <- getDynFlags+ = do { profile <- getProfile ; platform <- getPlatform ; sequel <- getSequel ; updfr_off <- getUpdFrameOff@@ -86,7 +87,7 @@ Return -> do { adjustHpBackwards ; let e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord platform)- ; emit (mkReturn dflags (entryCode platform e) results updfr_off)+ ; emit (mkReturn profile (entryCode platform e) results updfr_off) } AssignTo regs adjust -> do { when adjust adjustHpBackwards@@ -113,19 +114,19 @@ :: (Convention, Convention) -> CmmExpr -> [CmmExpr] -> [CmmExpr] -> FCode ReturnKind emitCallWithExtraStack (callConv, retConv) fun args extra_stack- = do { dflags <- getDynFlags+ = do { profile <- getProfile ; adjustHpBackwards ; sequel <- getSequel ; updfr_off <- getUpdFrameOff ; case sequel of Return -> do- emit $ mkJumpExtra dflags callConv fun args updfr_off extra_stack+ emit $ mkJumpExtra profile callConv fun args updfr_off extra_stack return AssignedDirectly AssignTo res_regs _ -> do k <- newBlockId let area = Young k- (off, _, copyin) = copyInOflow dflags retConv area res_regs []- copyout = mkCallReturnsTo dflags fun callConv args k off updfr_off+ (off, _, copyin) = copyInOflow profile retConv area res_regs []+ copyout = mkCallReturnsTo profile fun callConv args k off updfr_off extra_stack tscope <- getTickScope emit (copyout <*> mkLabel k tscope <*> copyin)@@ -191,7 +192,8 @@ -- (slowCall fun args) applies fun to args, returning the results to Sequel slowCall fun stg_args = do dflags <- getDynFlags- platform <- getPlatform+ profile <- getProfile+ let platform = profilePlatform profile argsreps <- getArgRepsAmodes stg_args let (rts_fun, arity) = slowCallPattern (map fst argsreps) @@ -207,9 +209,10 @@ let n_args = length stg_args if n_args > arity && optLevel dflags >= 2 then do+ ptr_opts <- getPtrOpts funv <- (CmmReg . CmmLocal) `fmap` assignTemp fun fun_iptr <- (CmmReg . CmmLocal) `fmap`- assignTemp (closureInfoPtr dflags (cmmUntag dflags funv))+ assignTemp (closureInfoPtr ptr_opts (cmmUntag platform funv)) -- ToDo: we could do slightly better here by reusing the -- continuation from the slow call, which we have in r.@@ -230,11 +233,11 @@ is_tagged_lbl <- newBlockId end_lbl <- newBlockId - let correct_arity = cmmEqWord platform (funInfoArity dflags fun_iptr)+ let correct_arity = cmmEqWord platform (funInfoArity profile fun_iptr) (mkIntExpr platform n_args) tscope <- getTickScope- emit (mkCbranch (cmmIsTagged dflags funv)+ emit (mkCbranch (cmmIsTagged platform funv) is_tagged_lbl slow_lbl (Just True) <*> mkLabel is_tagged_lbl tscope <*> mkCbranch correct_arity fast_lbl slow_lbl (Just True)@@ -411,7 +414,7 @@ | ThunkHeader mkVirtHeapOffsetsWithPadding- :: DynFlags+ :: Profile -> ClosureHeader -- What kind of header to account for -> [NonVoid (PrimRep, a)] -- Things to make offsets for -> ( WordOff -- Total number of words allocated@@ -426,18 +429,18 @@ -- mkVirtHeapOffsetsWithPadding always returns boxed things with smaller offsets -- than the unboxed things -mkVirtHeapOffsetsWithPadding dflags header things =+mkVirtHeapOffsetsWithPadding profile header things = ASSERT(not (any (isVoidRep . fst . fromNonVoid) things)) ( tot_wds , bytesToWordsRoundUp platform bytes_of_ptrs , concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad ) where- platform = targetPlatform dflags+ platform = profilePlatform profile hdr_words = case header of NoHeader -> 0- StdHeader -> fixedHdrSizeW dflags- ThunkHeader -> thunkHdrSize dflags+ StdHeader -> fixedHdrSizeW profile+ ThunkHeader -> thunkHdrSize profile hdr_bytes = wordsToBytes platform hdr_words (ptrs, non_ptrs) = partition (isGcPtrRep . fst . fromNonVoid) things@@ -485,36 +488,36 @@ mkVirtHeapOffsets- :: DynFlags+ :: Profile -> ClosureHeader -- What kind of header to account for -> [NonVoid (PrimRep,a)] -- Things to make offsets for -> (WordOff, -- _Total_ number of words allocated WordOff, -- Number of words allocated for *pointers* [(NonVoid a, ByteOff)])-mkVirtHeapOffsets dflags header things =+mkVirtHeapOffsets profile header things = ( tot_wds , ptr_wds , [ (field, offset) | (FieldOff field offset) <- things_offsets ] ) where (tot_wds, ptr_wds, things_offsets) =- mkVirtHeapOffsetsWithPadding dflags header things+ mkVirtHeapOffsetsWithPadding profile header things -- | Just like mkVirtHeapOffsets, but for constructors mkVirtConstrOffsets- :: DynFlags -> [NonVoid (PrimRep, a)]+ :: Profile -> [NonVoid (PrimRep, a)] -> (WordOff, WordOff, [(NonVoid a, ByteOff)])-mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags StdHeader+mkVirtConstrOffsets profile = mkVirtHeapOffsets profile StdHeader -- | Just like mkVirtConstrOffsets, but used when we don't have the actual -- arguments. Useful when e.g. generating info tables; we just need to know -- sizes of pointer and non-pointer fields.-mkVirtConstrSizes :: DynFlags -> [NonVoid PrimRep] -> (WordOff, WordOff)-mkVirtConstrSizes dflags field_reps+mkVirtConstrSizes :: Profile -> [NonVoid PrimRep] -> (WordOff, WordOff)+mkVirtConstrSizes profile field_reps = (tot_wds, ptr_wds) where (tot_wds, ptr_wds, _) =- mkVirtConstrOffsets dflags+ mkVirtConstrOffsets profile (map (\nv_rep -> NonVoid (fromNonVoid nv_rep, ())) field_reps) -------------------------------------------------------------------------@@ -601,28 +604,28 @@ -> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body -> FCode () emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body- = do { dflags <- getDynFlags+ = do { profile <- getProfile ; platform <- getPlatform -- Bind the binder itself, but only if it's not a top-level -- binding. We need non-top let-bindings to refer to the -- top-level binding, which this binding would incorrectly shadow. ; node <- if top_lvl then return $ idToReg platform (NonVoid bndr) else bindToReg (NonVoid bndr) lf_info- ; let node_points = nodeMustPointToIt dflags lf_info+ ; let node_points = nodeMustPointToIt profile lf_info ; arg_regs <- bindArgsToRegs args ; let args' = if node_points then (node : arg_regs) else arg_regs- conv = if nodeMustPointToIt dflags lf_info then NativeNodeCall+ conv = if nodeMustPointToIt profile lf_info then NativeNodeCall else NativeDirectCall- (offset, _, _) = mkCallEntry dflags conv args' []- ; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs)+ (offset, _, _) = mkCallEntry profile conv args' []+ ; emitClosureAndInfoTable (profilePlatform profile) info_tbl conv args' $ body (offset, node, arg_regs) } -- Data constructors need closures, but not with all the argument handling -- needed for functions. The shared part goes here.-emitClosureAndInfoTable ::- CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()-emitClosureAndInfoTable info_tbl conv args body+emitClosureAndInfoTable+ :: Platform -> CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()+emitClosureAndInfoTable platform info_tbl conv args body = do { (_, blks) <- getCodeScoped body- ; let entry_lbl = toEntryLbl (cit_lbl info_tbl)+ ; let entry_lbl = toEntryLbl platform (cit_lbl info_tbl) ; emitProcWithConvention conv (Just info_tbl) entry_lbl args blks }
compiler/GHC/StgToCmm/Monad.hs view
@@ -22,8 +22,9 @@ emitOutOfLine, emitAssign, emitStore, emitComment, emitTick, emitUnwind, - getCmm, aGraphToGraph, getPlatform,+ getCmm, aGraphToGraph, getPlatform, getProfile, getCodeR, getCode, getCodeScoped, getHeapUsage,+ getCallOpts, getPtrOpts, mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto, mkCmmIfThenElse', mkCmmIfThen', mkCmmIfGoto',@@ -62,6 +63,7 @@ import GHC.Prelude hiding( sequence, succ ) import GHC.Platform+import GHC.Platform.Profile import GHC.Cmm import GHC.StgToCmm.Closure import GHC.Driver.Session@@ -69,6 +71,7 @@ import GHC.Cmm.Graph as CmmGraph import GHC.Cmm.BlockId import GHC.Cmm.CLabel+import GHC.Cmm.Info import GHC.Runtime.Heap.Layout import GHC.Unit import GHC.Types.Id@@ -471,9 +474,32 @@ instance HasDynFlags FCode where getDynFlags = liftM cgd_dflags getInfoDown +getProfile :: FCode Profile+getProfile = targetProfile <$> getDynFlags+ getPlatform :: FCode Platform-getPlatform = targetPlatform <$> getDynFlags+getPlatform = profilePlatform <$> getProfile +getCallOpts :: FCode CallOpts+getCallOpts = do+ dflags <- getDynFlags+ profile <- getProfile+ pure $ CallOpts+ { co_profile = profile+ , co_loopification = gopt Opt_Loopification dflags+ , co_ticky = gopt Opt_Ticky dflags+ }++getPtrOpts :: FCode PtrOpts+getPtrOpts = do+ dflags <- getDynFlags+ profile <- getProfile+ pure $ PtrOpts+ { po_profile = profile+ , po_align_check = gopt Opt_AlignmentSanitisation dflags+ }++ withInfoDown :: FCode a -> CgInfoDownwards -> FCode a withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state @@ -742,8 +768,8 @@ } emitProcWithStackFrame conv mb_info lbl stk_args args (graph, tscope) True -- do layout- = do { dflags <- getDynFlags- ; let (offset, live, entry) = mkCallEntry dflags conv args stk_args+ = do { profile <- getProfile+ ; let (offset, live, entry) = mkCallEntry profile conv args stk_args graph' = entry CmmGraph.<*> graph ; emitProc mb_info lbl live (graph', tscope) offset True }@@ -837,12 +863,12 @@ mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmExpr] -> UpdFrameOffset -> [CmmExpr] -> FCode CmmAGraph mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do- dflags <- getDynFlags- k <- newBlockId- tscp <- getTickScope+ profile <- getProfile+ k <- newBlockId+ tscp <- getTickScope let area = Young k- (off, _, copyin) = copyInOflow dflags retConv area results []- copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack+ (off, _, copyin) = copyInOflow profile retConv area results []+ copyout = mkCallReturnsTo profile f callConv actuals k off updfr_off extra_stack return $ catAGraphs [copyout, mkLabel k tscp, copyin] mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmExpr] -> UpdFrameOffset
compiler/GHC/StgToCmm/Prim.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-} #if __GLASGOW_HASKELL__ <= 808 -- GHC 8.10 deprecates this flag, but GHC 8.8 needs it@@ -26,6 +27,9 @@ import GHC.Prelude hiding ((<*>)) +import GHC.Platform+import GHC.Platform.Profile+ import GHC.StgToCmm.Layout import GHC.StgToCmm.Foreign import GHC.StgToCmm.Env@@ -36,7 +40,7 @@ import GHC.StgToCmm.Prof ( costCentreFrom ) import GHC.Driver.Session-import GHC.Platform+import GHC.Driver.Backend import GHC.Types.Basic import GHC.Cmm.BlockId import GHC.Cmm.Graph@@ -85,40 +89,27 @@ cgOpApp (StgPrimOp primop) args res_ty = do dflags <- getDynFlags cmm_args <- getNonVoidArgAmodes args- case emitPrimOp dflags primop cmm_args of- PrimopCmmEmit_External -> do -- out-of-line- let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))- emitCall (NativeNodeCall, NativeReturn) fun cmm_args-- PrimopCmmEmit_Raw f -> do- exprs <- f res_ty- emitReturn exprs-- PrimopCmmEmit_IntoRegs f -- inline- | ReturnsPrim VoidRep <- result_info- -> do f []- emitReturn []-- | ReturnsPrim rep <- result_info- -> do platform <- getPlatform- res <- newTemp (primRepCmmType platform rep)- f [res]- emitReturn [CmmReg (CmmLocal res)]-- | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon- -> do (regs, _hints) <- newUnboxedTupleRegs res_ty- f regs- emitReturn (map (CmmReg . CmmLocal) regs)-- | otherwise -> panic "cgOpApp"- where- result_info = getPrimOpResultInfo primop+ cmmPrimOpApp dflags primop cmm_args (Just res_ty) cgOpApp (StgPrimCallOp primcall) args _res_ty = do { cmm_args <- getNonVoidArgAmodes args ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall)) ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args } +cmmPrimOpApp :: DynFlags -> PrimOp -> [CmmExpr] -> Maybe Type -> FCode ReturnKind+cmmPrimOpApp dflags primop cmm_args mres_ty =+ case emitPrimOp dflags primop cmm_args of+ PrimopCmmEmit_Internal f ->+ let+ -- if the result type isn't explicitly given, we directly use the+ -- result type of the primop.+ res_ty = fromMaybe (primOpResultType primop) mres_ty+ in emitReturn =<< f res_ty+ PrimopCmmEmit_External -> do+ let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))+ emitCall (NativeNodeCall, NativeReturn) fun cmm_args++ -- | Interpret the argument as an unsigned value, assuming the value -- is given in two-complement form in the given width. --@@ -141,8 +132,7 @@ shouldInlinePrimOp :: DynFlags -> PrimOp -> [CmmExpr] -> Bool shouldInlinePrimOp dflags op args = case emitPrimOp dflags op args of PrimopCmmEmit_External -> False- PrimopCmmEmit_IntoRegs _ -> True- PrimopCmmEmit_Raw _ -> True+ PrimopCmmEmit_Internal _ -> True -- TODO: Several primop implementations (e.g. 'doNewByteArrayOp') use -- ByteOff (or some other fixed width signed type) to represent@@ -167,117 +157,117 @@ -> PrimOp -- ^ The primop -> [CmmExpr] -- ^ The primop arguments -> PrimopCmmEmit-emitPrimOp dflags = \case+emitPrimOp dflags primop = case primop of NewByteArrayOp_Char -> \case [(CmmLit (CmmInt n w))] | asUnsigned w n <= fromIntegral (maxInlineAllocSize dflags)- -> opAllDone $ \ [res] -> doNewByteArrayOp res (fromInteger n)+ -> opIntoRegs $ \ [res] -> doNewByteArrayOp res (fromInteger n) _ -> PrimopCmmEmit_External NewArrayOp -> \case [(CmmLit (CmmInt n w)), init] | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)- -> opAllDone $ \[res] -> doNewArrayOp res (arrPtrsRep dflags (fromInteger n)) mkMAP_DIRTY_infoLabel+ -> opIntoRegs $ \[res] -> doNewArrayOp res (arrPtrsRep platform (fromInteger n)) mkMAP_DIRTY_infoLabel [ (mkIntExpr platform (fromInteger n),- fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags)- , (mkIntExpr platform (nonHdrSizeW (arrPtrsRep dflags (fromInteger n))),- fixedHdrSize dflags + oFFSET_StgMutArrPtrs_size dflags)+ fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform))+ , (mkIntExpr platform (nonHdrSizeW (arrPtrsRep platform (fromInteger n))),+ fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_size (platformConstants platform)) ] (fromInteger n) init _ -> PrimopCmmEmit_External CopyArrayOp -> \case [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->- opAllDone $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)+ opIntoRegs $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n) _ -> PrimopCmmEmit_External CopyMutableArrayOp -> \case [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->- opAllDone $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)+ opIntoRegs $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n) _ -> PrimopCmmEmit_External CopyArrayArrayOp -> \case [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->- opAllDone $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)+ opIntoRegs $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n) _ -> PrimopCmmEmit_External CopyMutableArrayArrayOp -> \case [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->- opAllDone $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)+ opIntoRegs $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n) _ -> PrimopCmmEmit_External CloneArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)- -> opAllDone $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)+ -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n) _ -> PrimopCmmEmit_External CloneMutableArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)- -> opAllDone $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)+ -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n) _ -> PrimopCmmEmit_External FreezeArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)- -> opAllDone $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)+ -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n) _ -> PrimopCmmEmit_External ThawArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)- -> opAllDone $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)+ -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n) _ -> PrimopCmmEmit_External NewSmallArrayOp -> \case [(CmmLit (CmmInt n w)), init] | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)- -> opAllDone $ \ [res] ->+ -> opIntoRegs $ \ [res] -> doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel [ (mkIntExpr platform (fromInteger n),- fixedHdrSize dflags + oFFSET_StgSmallMutArrPtrs_ptrs dflags)+ fixedHdrSize profile + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)) ] (fromInteger n) init _ -> PrimopCmmEmit_External CopySmallArrayOp -> \case [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->- opAllDone $ \ [] -> doCopySmallArrayOp src src_off dst dst_off (fromInteger n)+ opIntoRegs $ \ [] -> doCopySmallArrayOp src src_off dst dst_off (fromInteger n) _ -> PrimopCmmEmit_External CopySmallMutableArrayOp -> \case [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->- opAllDone $ \ [] -> doCopySmallMutableArrayOp src src_off dst dst_off (fromInteger n)+ opIntoRegs $ \ [] -> doCopySmallMutableArrayOp src src_off dst dst_off (fromInteger n) _ -> PrimopCmmEmit_External CloneSmallArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)- -> opAllDone $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)+ -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n) _ -> PrimopCmmEmit_External CloneSmallMutableArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)- -> opAllDone $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)+ -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n) _ -> PrimopCmmEmit_External FreezeSmallArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)- -> opAllDone $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)+ -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n) _ -> PrimopCmmEmit_External ThawSmallArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)- -> opAllDone $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)+ -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n) _ -> PrimopCmmEmit_External -- First we handle various awkward cases specially. - ParOp -> \[arg] -> opAllDone $ \[res] -> do+ ParOp -> \[arg] -> opIntoRegs $ \[res] -> do -- for now, just implement this in a C function -- later, we might want to inline it. emitCCall@@ -285,7 +275,7 @@ (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction))) [(baseExpr, AddrHint), (arg,AddrHint)] - SparkOp -> \[arg] -> opAllDone $ \[res] -> do+ SparkOp -> \[arg] -> opIntoRegs $ \[res] -> do -- returns the value of arg in res. We're going to therefore -- refer to arg twice (once to pass to newSpark(), and once to -- assign to res), so put it in a temporary.@@ -297,25 +287,25 @@ [(baseExpr, AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)] emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp)) - GetCCSOfOp -> \[arg] -> opAllDone $ \[res] -> do+ GetCCSOfOp -> \[arg] -> opIntoRegs $ \[res] -> do let val- | sccProfilingEnabled dflags = costCentreFrom dflags (cmmUntag dflags arg)+ | profileIsProfiling profile = costCentreFrom platform (cmmUntag platform arg) | otherwise = CmmLit (zeroCLit platform) emitAssign (CmmLocal res) val - GetCurrentCCSOp -> \[_] -> opAllDone $ \[res] -> do+ GetCurrentCCSOp -> \[_] -> opIntoRegs $ \[res] -> do emitAssign (CmmLocal res) cccsExpr - MyThreadIdOp -> \[] -> opAllDone $ \[res] -> do+ MyThreadIdOp -> \[] -> opIntoRegs $ \[res] -> do emitAssign (CmmLocal res) currentTSOExpr - ReadMutVarOp -> \[mutv] -> opAllDone $ \[res] -> do- emitAssign (CmmLocal res) (cmmLoadIndexW platform mutv (fixedHdrSizeW dflags) (gcWord platform))+ ReadMutVarOp -> \[mutv] -> opIntoRegs $ \[res] -> do+ emitAssign (CmmLocal res) (cmmLoadIndexW platform mutv (fixedHdrSizeW profile) (gcWord platform)) - WriteMutVarOp -> \[mutv, var] -> opAllDone $ \res@[] -> do+ WriteMutVarOp -> \[mutv, var] -> opIntoRegs $ \res@[] -> do old_val <- CmmLocal <$> newTemp (cmmExprType platform var)- emitAssign old_val (cmmLoadIndexW platform mutv (fixedHdrSizeW dflags) (gcWord platform))+ emitAssign old_val (cmmLoadIndexW platform mutv (fixedHdrSizeW profile) (gcWord platform)) -- Without this write barrier, other CPUs may see this pointer before -- the writes for the closure it points to have occurred.@@ -323,7 +313,7 @@ -- that the read of old_val comes before another core's write to the -- MutVar's value. emitPrimCall res MO_WriteBarrier []- emitStore (cmmOffsetW platform mutv (fixedHdrSizeW dflags)) var+ emitStore (cmmOffsetW platform mutv (fixedHdrSizeW profile)) var emitCCall [{-no results-}] (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))@@ -331,8 +321,8 @@ -- #define sizzeofByteArrayzh(r,a) \ -- r = ((StgArrBytes *)(a))->bytes- SizeofByteArrayOp -> \[arg] -> opAllDone $ \[res] -> do- emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW dflags) (bWord platform))+ SizeofByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do+ emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform)) -- #define sizzeofMutableByteArrayzh(r,a) \ -- r = ((StgArrBytes *)(a))->bytes@@ -340,31 +330,31 @@ -- #define getSizzeofMutableByteArrayzh(r,a) \ -- r = ((StgArrBytes *)(a))->bytes- GetSizeofMutableByteArrayOp -> \[arg] -> opAllDone $ \[res] -> do- emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW dflags) (bWord platform))+ GetSizeofMutableByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do+ emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform)) -- #define touchzh(o) /* nothing */- TouchOp -> \args@[_] -> opAllDone $ \res@[] -> do+ TouchOp -> \args@[_] -> opIntoRegs $ \res@[] -> do emitPrimCall res MO_Touch args -- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)- ByteArrayContents_Char -> \[arg] -> opAllDone $ \[res] -> do- emitAssign (CmmLocal res) (cmmOffsetB platform arg (arrWordsHdrSize dflags))+ ByteArrayContents_Char -> \[arg] -> opIntoRegs $ \[res] -> do+ emitAssign (CmmLocal res) (cmmOffsetB platform arg (arrWordsHdrSize profile)) -- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn)- StableNameToIntOp -> \[arg] -> opAllDone $ \[res] -> do- emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW dflags) (bWord platform))+ StableNameToIntOp -> \[arg] -> opIntoRegs $ \[res] -> do+ emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform)) - ReallyUnsafePtrEqualityOp -> \[arg1, arg2] -> opAllDone $ \[res] -> do+ ReallyUnsafePtrEqualityOp -> \[arg1, arg2] -> opIntoRegs $ \[res] -> do emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq platform) [arg1,arg2]) -- #define addrToHValuezh(r,a) r=(P_)a- AddrToAnyOp -> \[arg] -> opAllDone $ \[res] -> do+ AddrToAnyOp -> \[arg] -> opIntoRegs $ \[res] -> do emitAssign (CmmLocal res) arg -- #define hvalueToAddrzh(r, a) r=(W_)a- AnyToAddrOp -> \[arg] -> opAllDone $ \[res] -> do+ AnyToAddrOp -> \[arg] -> opIntoRegs $ \[res] -> do emitAssign (CmmLocal res) arg {- Freezing arrays-of-ptrs requires changing an info table, for the@@ -377,73 +367,73 @@ -- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_DIRTY_info); -- r = a; -- }- UnsafeFreezeArrayOp -> \[arg] -> opAllDone $ \[res] -> do+ UnsafeFreezeArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do emit $ catAGraphs [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)), mkAssign (CmmLocal res) arg ]- UnsafeFreezeArrayArrayOp -> \[arg] -> opAllDone $ \[res] -> do+ UnsafeFreezeArrayArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do emit $ catAGraphs [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)), mkAssign (CmmLocal res) arg ]- UnsafeFreezeSmallArrayOp -> \[arg] -> opAllDone $ \[res] -> do+ UnsafeFreezeSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do emit $ catAGraphs [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN_DIRTY_infoLabel)), mkAssign (CmmLocal res) arg ] -- #define unsafeFreezzeByteArrayzh(r,a) r=(a)- UnsafeFreezeByteArrayOp -> \[arg] -> opAllDone $ \[res] -> do+ UnsafeFreezeByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do emitAssign (CmmLocal res) arg -- Reading/writing pointer arrays - ReadArrayOp -> \[obj, ix] -> opAllDone $ \[res] -> do+ ReadArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> do doReadPtrArrayOp res obj ix- IndexArrayOp -> \[obj, ix] -> opAllDone $ \[res] -> do+ IndexArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> do doReadPtrArrayOp res obj ix- WriteArrayOp -> \[obj, ix, v] -> opAllDone $ \[] -> do+ WriteArrayOp -> \[obj, ix, v] -> opIntoRegs $ \[] -> do doWritePtrArrayOp obj ix v - IndexArrayArrayOp_ByteArray -> \[obj, ix] -> opAllDone $ \[res] -> do+ IndexArrayArrayOp_ByteArray -> \[obj, ix] -> opIntoRegs $ \[res] -> do doReadPtrArrayOp res obj ix- IndexArrayArrayOp_ArrayArray -> \[obj, ix] -> opAllDone $ \[res] -> do+ IndexArrayArrayOp_ArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] -> do doReadPtrArrayOp res obj ix- ReadArrayArrayOp_ByteArray -> \[obj, ix] -> opAllDone $ \[res] -> do+ ReadArrayArrayOp_ByteArray -> \[obj, ix] -> opIntoRegs $ \[res] -> do doReadPtrArrayOp res obj ix- ReadArrayArrayOp_MutableByteArray -> \[obj, ix] -> opAllDone $ \[res] -> do+ ReadArrayArrayOp_MutableByteArray -> \[obj, ix] -> opIntoRegs $ \[res] -> do doReadPtrArrayOp res obj ix- ReadArrayArrayOp_ArrayArray -> \[obj, ix] -> opAllDone $ \[res] -> do+ ReadArrayArrayOp_ArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] -> do doReadPtrArrayOp res obj ix- ReadArrayArrayOp_MutableArrayArray -> \[obj, ix] -> opAllDone $ \[res] -> do+ ReadArrayArrayOp_MutableArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] -> do doReadPtrArrayOp res obj ix- WriteArrayArrayOp_ByteArray -> \[obj,ix,v] -> opAllDone $ \[] -> do+ WriteArrayArrayOp_ByteArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> do doWritePtrArrayOp obj ix v- WriteArrayArrayOp_MutableByteArray -> \[obj,ix,v] -> opAllDone $ \[] -> do+ WriteArrayArrayOp_MutableByteArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> do doWritePtrArrayOp obj ix v- WriteArrayArrayOp_ArrayArray -> \[obj,ix,v] -> opAllDone $ \[] -> do+ WriteArrayArrayOp_ArrayArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> do doWritePtrArrayOp obj ix v- WriteArrayArrayOp_MutableArrayArray -> \[obj,ix,v] -> opAllDone $ \[] -> do+ WriteArrayArrayOp_MutableArrayArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> do doWritePtrArrayOp obj ix v - ReadSmallArrayOp -> \[obj, ix] -> opAllDone $ \[res] -> do+ ReadSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> do doReadSmallPtrArrayOp res obj ix- IndexSmallArrayOp -> \[obj, ix] -> opAllDone $ \[res] -> do+ IndexSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> do doReadSmallPtrArrayOp res obj ix- WriteSmallArrayOp -> \[obj,ix,v] -> opAllDone $ \[] -> do+ WriteSmallArrayOp -> \[obj,ix,v] -> opIntoRegs $ \[] -> do doWriteSmallPtrArrayOp obj ix v -- Getting the size of pointer arrays - SizeofArrayOp -> \[arg] -> opAllDone $ \[res] -> do+ SizeofArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg- (fixedHdrSizeW dflags + bytesToWordsRoundUp platform (oFFSET_StgMutArrPtrs_ptrs dflags))+ (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] -> opAllDone $ \[res] -> do+ SizeofSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg- (fixedHdrSizeW dflags + bytesToWordsRoundUp platform (oFFSET_StgSmallMutArrPtrs_ptrs dflags))+ (fixedHdrSizeW profile + bytesToWordsRoundUp platform (pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform))) (bWord platform)) SizeofSmallMutableArrayOp -> emitPrimOp dflags SizeofSmallArrayOp@@ -451,419 +441,419 @@ -- IndexXXXoffAddr - IndexOffAddrOp_Char -> \args -> opAllDone $ \res -> do+ IndexOffAddrOp_Char -> \args -> opIntoRegs $ \res -> do doIndexOffAddrOp (Just (mo_u_8ToWord platform)) b8 res args- IndexOffAddrOp_WideChar -> \args -> opAllDone $ \res -> do+ IndexOffAddrOp_WideChar -> \args -> opIntoRegs $ \res -> do doIndexOffAddrOp (Just (mo_u_32ToWord platform)) b32 res args- IndexOffAddrOp_Int -> \args -> opAllDone $ \res -> do+ IndexOffAddrOp_Int -> \args -> opIntoRegs $ \res -> do doIndexOffAddrOp Nothing (bWord platform) res args- IndexOffAddrOp_Word -> \args -> opAllDone $ \res -> do+ IndexOffAddrOp_Word -> \args -> opIntoRegs $ \res -> do doIndexOffAddrOp Nothing (bWord platform) res args- IndexOffAddrOp_Addr -> \args -> opAllDone $ \res -> do+ IndexOffAddrOp_Addr -> \args -> opIntoRegs $ \res -> do doIndexOffAddrOp Nothing (bWord platform) res args- IndexOffAddrOp_Float -> \args -> opAllDone $ \res -> do+ IndexOffAddrOp_Float -> \args -> opIntoRegs $ \res -> do doIndexOffAddrOp Nothing f32 res args- IndexOffAddrOp_Double -> \args -> opAllDone $ \res -> do+ IndexOffAddrOp_Double -> \args -> opIntoRegs $ \res -> do doIndexOffAddrOp Nothing f64 res args- IndexOffAddrOp_StablePtr -> \args -> opAllDone $ \res -> do+ IndexOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res -> do doIndexOffAddrOp Nothing (bWord platform) res args- IndexOffAddrOp_Int8 -> \args -> opAllDone $ \res -> do+ IndexOffAddrOp_Int8 -> \args -> opIntoRegs $ \res -> do doIndexOffAddrOp (Just (mo_s_8ToWord platform)) b8 res args- IndexOffAddrOp_Int16 -> \args -> opAllDone $ \res -> do+ IndexOffAddrOp_Int16 -> \args -> opIntoRegs $ \res -> do doIndexOffAddrOp (Just (mo_s_16ToWord platform)) b16 res args- IndexOffAddrOp_Int32 -> \args -> opAllDone $ \res -> do+ IndexOffAddrOp_Int32 -> \args -> opIntoRegs $ \res -> do doIndexOffAddrOp (Just (mo_s_32ToWord platform)) b32 res args- IndexOffAddrOp_Int64 -> \args -> opAllDone $ \res -> do+ IndexOffAddrOp_Int64 -> \args -> opIntoRegs $ \res -> do doIndexOffAddrOp Nothing b64 res args- IndexOffAddrOp_Word8 -> \args -> opAllDone $ \res -> do+ IndexOffAddrOp_Word8 -> \args -> opIntoRegs $ \res -> do doIndexOffAddrOp (Just (mo_u_8ToWord platform)) b8 res args- IndexOffAddrOp_Word16 -> \args -> opAllDone $ \res -> do+ IndexOffAddrOp_Word16 -> \args -> opIntoRegs $ \res -> do doIndexOffAddrOp (Just (mo_u_16ToWord platform)) b16 res args- IndexOffAddrOp_Word32 -> \args -> opAllDone $ \res -> do+ IndexOffAddrOp_Word32 -> \args -> opIntoRegs $ \res -> do doIndexOffAddrOp (Just (mo_u_32ToWord platform)) b32 res args- IndexOffAddrOp_Word64 -> \args -> opAllDone $ \res -> do+ IndexOffAddrOp_Word64 -> \args -> opIntoRegs $ \res -> do doIndexOffAddrOp Nothing b64 res args -- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr. - ReadOffAddrOp_Char -> \args -> opAllDone $ \res -> do+ ReadOffAddrOp_Char -> \args -> opIntoRegs $ \res -> do doIndexOffAddrOp (Just (mo_u_8ToWord platform)) b8 res args- ReadOffAddrOp_WideChar -> \args -> opAllDone $ \res -> do+ ReadOffAddrOp_WideChar -> \args -> opIntoRegs $ \res -> do doIndexOffAddrOp (Just (mo_u_32ToWord platform)) b32 res args- ReadOffAddrOp_Int -> \args -> opAllDone $ \res -> do+ ReadOffAddrOp_Int -> \args -> opIntoRegs $ \res -> do doIndexOffAddrOp Nothing (bWord platform) res args- ReadOffAddrOp_Word -> \args -> opAllDone $ \res -> do+ ReadOffAddrOp_Word -> \args -> opIntoRegs $ \res -> do doIndexOffAddrOp Nothing (bWord platform) res args- ReadOffAddrOp_Addr -> \args -> opAllDone $ \res -> do+ ReadOffAddrOp_Addr -> \args -> opIntoRegs $ \res -> do doIndexOffAddrOp Nothing (bWord platform) res args- ReadOffAddrOp_Float -> \args -> opAllDone $ \res -> do+ ReadOffAddrOp_Float -> \args -> opIntoRegs $ \res -> do doIndexOffAddrOp Nothing f32 res args- ReadOffAddrOp_Double -> \args -> opAllDone $ \res -> do+ ReadOffAddrOp_Double -> \args -> opIntoRegs $ \res -> do doIndexOffAddrOp Nothing f64 res args- ReadOffAddrOp_StablePtr -> \args -> opAllDone $ \res -> do+ ReadOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res -> do doIndexOffAddrOp Nothing (bWord platform) res args- ReadOffAddrOp_Int8 -> \args -> opAllDone $ \res -> do+ ReadOffAddrOp_Int8 -> \args -> opIntoRegs $ \res -> do doIndexOffAddrOp (Just (mo_s_8ToWord platform)) b8 res args- ReadOffAddrOp_Int16 -> \args -> opAllDone $ \res -> do+ ReadOffAddrOp_Int16 -> \args -> opIntoRegs $ \res -> do doIndexOffAddrOp (Just (mo_s_16ToWord platform)) b16 res args- ReadOffAddrOp_Int32 -> \args -> opAllDone $ \res -> do+ ReadOffAddrOp_Int32 -> \args -> opIntoRegs $ \res -> do doIndexOffAddrOp (Just (mo_s_32ToWord platform)) b32 res args- ReadOffAddrOp_Int64 -> \args -> opAllDone $ \res -> do+ ReadOffAddrOp_Int64 -> \args -> opIntoRegs $ \res -> do doIndexOffAddrOp Nothing b64 res args- ReadOffAddrOp_Word8 -> \args -> opAllDone $ \res -> do+ ReadOffAddrOp_Word8 -> \args -> opIntoRegs $ \res -> do doIndexOffAddrOp (Just (mo_u_8ToWord platform)) b8 res args- ReadOffAddrOp_Word16 -> \args -> opAllDone $ \res -> do+ ReadOffAddrOp_Word16 -> \args -> opIntoRegs $ \res -> do doIndexOffAddrOp (Just (mo_u_16ToWord platform)) b16 res args- ReadOffAddrOp_Word32 -> \args -> opAllDone $ \res -> do+ ReadOffAddrOp_Word32 -> \args -> opIntoRegs $ \res -> do doIndexOffAddrOp (Just (mo_u_32ToWord platform)) b32 res args- ReadOffAddrOp_Word64 -> \args -> opAllDone $ \res -> do+ ReadOffAddrOp_Word64 -> \args -> opIntoRegs $ \res -> do doIndexOffAddrOp Nothing b64 res args -- IndexXXXArray - IndexByteArrayOp_Char -> \args -> opAllDone $ \res -> do+ IndexByteArrayOp_Char -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOp (Just (mo_u_8ToWord platform)) b8 res args- IndexByteArrayOp_WideChar -> \args -> opAllDone $ \res -> do+ IndexByteArrayOp_WideChar -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOp (Just (mo_u_32ToWord platform)) b32 res args- IndexByteArrayOp_Int -> \args -> opAllDone $ \res -> do+ IndexByteArrayOp_Int -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOp Nothing (bWord platform) res args- IndexByteArrayOp_Word -> \args -> opAllDone $ \res -> do+ IndexByteArrayOp_Word -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOp Nothing (bWord platform) res args- IndexByteArrayOp_Addr -> \args -> opAllDone $ \res -> do+ IndexByteArrayOp_Addr -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOp Nothing (bWord platform) res args- IndexByteArrayOp_Float -> \args -> opAllDone $ \res -> do+ IndexByteArrayOp_Float -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOp Nothing f32 res args- IndexByteArrayOp_Double -> \args -> opAllDone $ \res -> do+ IndexByteArrayOp_Double -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOp Nothing f64 res args- IndexByteArrayOp_StablePtr -> \args -> opAllDone $ \res -> do+ IndexByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOp Nothing (bWord platform) res args- IndexByteArrayOp_Int8 -> \args -> opAllDone $ \res -> do+ IndexByteArrayOp_Int8 -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOp (Just (mo_s_8ToWord platform)) b8 res args- IndexByteArrayOp_Int16 -> \args -> opAllDone $ \res -> do+ IndexByteArrayOp_Int16 -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOp (Just (mo_s_16ToWord platform)) b16 res args- IndexByteArrayOp_Int32 -> \args -> opAllDone $ \res -> do+ IndexByteArrayOp_Int32 -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOp (Just (mo_s_32ToWord platform)) b32 res args- IndexByteArrayOp_Int64 -> \args -> opAllDone $ \res -> do+ IndexByteArrayOp_Int64 -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOp Nothing b64 res args- IndexByteArrayOp_Word8 -> \args -> opAllDone $ \res -> do+ IndexByteArrayOp_Word8 -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOp (Just (mo_u_8ToWord platform)) b8 res args- IndexByteArrayOp_Word16 -> \args -> opAllDone $ \res -> do+ IndexByteArrayOp_Word16 -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOp (Just (mo_u_16ToWord platform)) b16 res args- IndexByteArrayOp_Word32 -> \args -> opAllDone $ \res -> do+ IndexByteArrayOp_Word32 -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOp (Just (mo_u_32ToWord platform)) b32 res args- IndexByteArrayOp_Word64 -> \args -> opAllDone $ \res -> do+ IndexByteArrayOp_Word64 -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOp Nothing b64 res args -- ReadXXXArray, identical to IndexXXXArray. - ReadByteArrayOp_Char -> \args -> opAllDone $ \res -> do+ ReadByteArrayOp_Char -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOp (Just (mo_u_8ToWord platform)) b8 res args- ReadByteArrayOp_WideChar -> \args -> opAllDone $ \res -> do+ ReadByteArrayOp_WideChar -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOp (Just (mo_u_32ToWord platform)) b32 res args- ReadByteArrayOp_Int -> \args -> opAllDone $ \res -> do+ ReadByteArrayOp_Int -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOp Nothing (bWord platform) res args- ReadByteArrayOp_Word -> \args -> opAllDone $ \res -> do+ ReadByteArrayOp_Word -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOp Nothing (bWord platform) res args- ReadByteArrayOp_Addr -> \args -> opAllDone $ \res -> do+ ReadByteArrayOp_Addr -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOp Nothing (bWord platform) res args- ReadByteArrayOp_Float -> \args -> opAllDone $ \res -> do+ ReadByteArrayOp_Float -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOp Nothing f32 res args- ReadByteArrayOp_Double -> \args -> opAllDone $ \res -> do+ ReadByteArrayOp_Double -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOp Nothing f64 res args- ReadByteArrayOp_StablePtr -> \args -> opAllDone $ \res -> do+ ReadByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOp Nothing (bWord platform) res args- ReadByteArrayOp_Int8 -> \args -> opAllDone $ \res -> do+ ReadByteArrayOp_Int8 -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOp (Just (mo_s_8ToWord platform)) b8 res args- ReadByteArrayOp_Int16 -> \args -> opAllDone $ \res -> do+ ReadByteArrayOp_Int16 -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOp (Just (mo_s_16ToWord platform)) b16 res args- ReadByteArrayOp_Int32 -> \args -> opAllDone $ \res -> do+ ReadByteArrayOp_Int32 -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOp (Just (mo_s_32ToWord platform)) b32 res args- ReadByteArrayOp_Int64 -> \args -> opAllDone $ \res -> do+ ReadByteArrayOp_Int64 -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOp Nothing b64 res args- ReadByteArrayOp_Word8 -> \args -> opAllDone $ \res -> do+ ReadByteArrayOp_Word8 -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOp (Just (mo_u_8ToWord platform)) b8 res args- ReadByteArrayOp_Word16 -> \args -> opAllDone $ \res -> do+ ReadByteArrayOp_Word16 -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOp (Just (mo_u_16ToWord platform)) b16 res args- ReadByteArrayOp_Word32 -> \args -> opAllDone $ \res -> do+ ReadByteArrayOp_Word32 -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOp (Just (mo_u_32ToWord platform)) b32 res args- ReadByteArrayOp_Word64 -> \args -> opAllDone $ \res -> do+ ReadByteArrayOp_Word64 -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOp Nothing b64 res args -- IndexWord8ArrayAsXXX - IndexByteArrayOp_Word8AsChar -> \args -> opAllDone $ \res -> do+ IndexByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOpAs (Just (mo_u_8ToWord platform)) b8 b8 res args- IndexByteArrayOp_Word8AsWideChar -> \args -> opAllDone $ \res -> do+ IndexByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOpAs (Just (mo_u_32ToWord platform)) b32 b8 res args- IndexByteArrayOp_Word8AsInt -> \args -> opAllDone $ \res -> do+ IndexByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOpAs Nothing (bWord platform) b8 res args- IndexByteArrayOp_Word8AsWord -> \args -> opAllDone $ \res -> do+ IndexByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOpAs Nothing (bWord platform) b8 res args- IndexByteArrayOp_Word8AsAddr -> \args -> opAllDone $ \res -> do+ IndexByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOpAs Nothing (bWord platform) b8 res args- IndexByteArrayOp_Word8AsFloat -> \args -> opAllDone $ \res -> do+ IndexByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOpAs Nothing f32 b8 res args- IndexByteArrayOp_Word8AsDouble -> \args -> opAllDone $ \res -> do+ IndexByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOpAs Nothing f64 b8 res args- IndexByteArrayOp_Word8AsStablePtr -> \args -> opAllDone $ \res -> do+ IndexByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOpAs Nothing (bWord platform) b8 res args- IndexByteArrayOp_Word8AsInt16 -> \args -> opAllDone $ \res -> do+ IndexByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOpAs (Just (mo_s_16ToWord platform)) b16 b8 res args- IndexByteArrayOp_Word8AsInt32 -> \args -> opAllDone $ \res -> do+ IndexByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOpAs (Just (mo_s_32ToWord platform)) b32 b8 res args- IndexByteArrayOp_Word8AsInt64 -> \args -> opAllDone $ \res -> do+ IndexByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOpAs Nothing b64 b8 res args- IndexByteArrayOp_Word8AsWord16 -> \args -> opAllDone $ \res -> do+ IndexByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOpAs (Just (mo_u_16ToWord platform)) b16 b8 res args- IndexByteArrayOp_Word8AsWord32 -> \args -> opAllDone $ \res -> do+ IndexByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOpAs (Just (mo_u_32ToWord platform)) b32 b8 res args- IndexByteArrayOp_Word8AsWord64 -> \args -> opAllDone $ \res -> do+ IndexByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOpAs Nothing b64 b8 res args -- ReadInt8ArrayAsXXX, identical to IndexInt8ArrayAsXXX - ReadByteArrayOp_Word8AsChar -> \args -> opAllDone $ \res -> do+ ReadByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOpAs (Just (mo_u_8ToWord platform)) b8 b8 res args- ReadByteArrayOp_Word8AsWideChar -> \args -> opAllDone $ \res -> do+ ReadByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOpAs (Just (mo_u_32ToWord platform)) b32 b8 res args- ReadByteArrayOp_Word8AsInt -> \args -> opAllDone $ \res -> do+ ReadByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOpAs Nothing (bWord platform) b8 res args- ReadByteArrayOp_Word8AsWord -> \args -> opAllDone $ \res -> do+ ReadByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOpAs Nothing (bWord platform) b8 res args- ReadByteArrayOp_Word8AsAddr -> \args -> opAllDone $ \res -> do+ ReadByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOpAs Nothing (bWord platform) b8 res args- ReadByteArrayOp_Word8AsFloat -> \args -> opAllDone $ \res -> do+ ReadByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOpAs Nothing f32 b8 res args- ReadByteArrayOp_Word8AsDouble -> \args -> opAllDone $ \res -> do+ ReadByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOpAs Nothing f64 b8 res args- ReadByteArrayOp_Word8AsStablePtr -> \args -> opAllDone $ \res -> do+ ReadByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOpAs Nothing (bWord platform) b8 res args- ReadByteArrayOp_Word8AsInt16 -> \args -> opAllDone $ \res -> do+ ReadByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOpAs (Just (mo_s_16ToWord platform)) b16 b8 res args- ReadByteArrayOp_Word8AsInt32 -> \args -> opAllDone $ \res -> do+ ReadByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOpAs (Just (mo_s_32ToWord platform)) b32 b8 res args- ReadByteArrayOp_Word8AsInt64 -> \args -> opAllDone $ \res -> do+ ReadByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOpAs Nothing b64 b8 res args- ReadByteArrayOp_Word8AsWord16 -> \args -> opAllDone $ \res -> do+ ReadByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOpAs (Just (mo_u_16ToWord platform)) b16 b8 res args- ReadByteArrayOp_Word8AsWord32 -> \args -> opAllDone $ \res -> do+ ReadByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOpAs (Just (mo_u_32ToWord platform)) b32 b8 res args- ReadByteArrayOp_Word8AsWord64 -> \args -> opAllDone $ \res -> do+ ReadByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> do doIndexByteArrayOpAs Nothing b64 b8 res args -- WriteXXXoffAddr - WriteOffAddrOp_Char -> \args -> opAllDone $ \res -> do+ WriteOffAddrOp_Char -> \args -> opIntoRegs $ \res -> do doWriteOffAddrOp (Just (mo_WordTo8 platform)) b8 res args- WriteOffAddrOp_WideChar -> \args -> opAllDone $ \res -> do+ WriteOffAddrOp_WideChar -> \args -> opIntoRegs $ \res -> do doWriteOffAddrOp (Just (mo_WordTo32 platform)) b32 res args- WriteOffAddrOp_Int -> \args -> opAllDone $ \res -> do+ WriteOffAddrOp_Int -> \args -> opIntoRegs $ \res -> do doWriteOffAddrOp Nothing (bWord platform) res args- WriteOffAddrOp_Word -> \args -> opAllDone $ \res -> do+ WriteOffAddrOp_Word -> \args -> opIntoRegs $ \res -> do doWriteOffAddrOp Nothing (bWord platform) res args- WriteOffAddrOp_Addr -> \args -> opAllDone $ \res -> do+ WriteOffAddrOp_Addr -> \args -> opIntoRegs $ \res -> do doWriteOffAddrOp Nothing (bWord platform) res args- WriteOffAddrOp_Float -> \args -> opAllDone $ \res -> do+ WriteOffAddrOp_Float -> \args -> opIntoRegs $ \res -> do doWriteOffAddrOp Nothing f32 res args- WriteOffAddrOp_Double -> \args -> opAllDone $ \res -> do+ WriteOffAddrOp_Double -> \args -> opIntoRegs $ \res -> do doWriteOffAddrOp Nothing f64 res args- WriteOffAddrOp_StablePtr -> \args -> opAllDone $ \res -> do+ WriteOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res -> do doWriteOffAddrOp Nothing (bWord platform) res args- WriteOffAddrOp_Int8 -> \args -> opAllDone $ \res -> do+ WriteOffAddrOp_Int8 -> \args -> opIntoRegs $ \res -> do doWriteOffAddrOp (Just (mo_WordTo8 platform)) b8 res args- WriteOffAddrOp_Int16 -> \args -> opAllDone $ \res -> do+ WriteOffAddrOp_Int16 -> \args -> opIntoRegs $ \res -> do doWriteOffAddrOp (Just (mo_WordTo16 platform)) b16 res args- WriteOffAddrOp_Int32 -> \args -> opAllDone $ \res -> do+ WriteOffAddrOp_Int32 -> \args -> opIntoRegs $ \res -> do doWriteOffAddrOp (Just (mo_WordTo32 platform)) b32 res args- WriteOffAddrOp_Int64 -> \args -> opAllDone $ \res -> do+ WriteOffAddrOp_Int64 -> \args -> opIntoRegs $ \res -> do doWriteOffAddrOp Nothing b64 res args- WriteOffAddrOp_Word8 -> \args -> opAllDone $ \res -> do+ WriteOffAddrOp_Word8 -> \args -> opIntoRegs $ \res -> do doWriteOffAddrOp (Just (mo_WordTo8 platform)) b8 res args- WriteOffAddrOp_Word16 -> \args -> opAllDone $ \res -> do+ WriteOffAddrOp_Word16 -> \args -> opIntoRegs $ \res -> do doWriteOffAddrOp (Just (mo_WordTo16 platform)) b16 res args- WriteOffAddrOp_Word32 -> \args -> opAllDone $ \res -> do+ WriteOffAddrOp_Word32 -> \args -> opIntoRegs $ \res -> do doWriteOffAddrOp (Just (mo_WordTo32 platform)) b32 res args- WriteOffAddrOp_Word64 -> \args -> opAllDone $ \res -> do+ WriteOffAddrOp_Word64 -> \args -> opIntoRegs $ \res -> do doWriteOffAddrOp Nothing b64 res args -- WriteXXXArray - WriteByteArrayOp_Char -> \args -> opAllDone $ \res -> do+ WriteByteArrayOp_Char -> \args -> opIntoRegs $ \res -> do doWriteByteArrayOp (Just (mo_WordTo8 platform)) b8 res args- WriteByteArrayOp_WideChar -> \args -> opAllDone $ \res -> do+ WriteByteArrayOp_WideChar -> \args -> opIntoRegs $ \res -> do doWriteByteArrayOp (Just (mo_WordTo32 platform)) b32 res args- WriteByteArrayOp_Int -> \args -> opAllDone $ \res -> do+ WriteByteArrayOp_Int -> \args -> opIntoRegs $ \res -> do doWriteByteArrayOp Nothing (bWord platform) res args- WriteByteArrayOp_Word -> \args -> opAllDone $ \res -> do+ WriteByteArrayOp_Word -> \args -> opIntoRegs $ \res -> do doWriteByteArrayOp Nothing (bWord platform) res args- WriteByteArrayOp_Addr -> \args -> opAllDone $ \res -> do+ WriteByteArrayOp_Addr -> \args -> opIntoRegs $ \res -> do doWriteByteArrayOp Nothing (bWord platform) res args- WriteByteArrayOp_Float -> \args -> opAllDone $ \res -> do+ WriteByteArrayOp_Float -> \args -> opIntoRegs $ \res -> do doWriteByteArrayOp Nothing f32 res args- WriteByteArrayOp_Double -> \args -> opAllDone $ \res -> do+ WriteByteArrayOp_Double -> \args -> opIntoRegs $ \res -> do doWriteByteArrayOp Nothing f64 res args- WriteByteArrayOp_StablePtr -> \args -> opAllDone $ \res -> do+ WriteByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res -> do doWriteByteArrayOp Nothing (bWord platform) res args- WriteByteArrayOp_Int8 -> \args -> opAllDone $ \res -> do+ WriteByteArrayOp_Int8 -> \args -> opIntoRegs $ \res -> do doWriteByteArrayOp (Just (mo_WordTo8 platform)) b8 res args- WriteByteArrayOp_Int16 -> \args -> opAllDone $ \res -> do+ WriteByteArrayOp_Int16 -> \args -> opIntoRegs $ \res -> do doWriteByteArrayOp (Just (mo_WordTo16 platform)) b16 res args- WriteByteArrayOp_Int32 -> \args -> opAllDone $ \res -> do+ WriteByteArrayOp_Int32 -> \args -> opIntoRegs $ \res -> do doWriteByteArrayOp (Just (mo_WordTo32 platform)) b32 res args- WriteByteArrayOp_Int64 -> \args -> opAllDone $ \res -> do+ WriteByteArrayOp_Int64 -> \args -> opIntoRegs $ \res -> do doWriteByteArrayOp Nothing b64 res args- WriteByteArrayOp_Word8 -> \args -> opAllDone $ \res -> do+ WriteByteArrayOp_Word8 -> \args -> opIntoRegs $ \res -> do doWriteByteArrayOp (Just (mo_WordTo8 platform)) b8 res args- WriteByteArrayOp_Word16 -> \args -> opAllDone $ \res -> do+ WriteByteArrayOp_Word16 -> \args -> opIntoRegs $ \res -> do doWriteByteArrayOp (Just (mo_WordTo16 platform)) b16 res args- WriteByteArrayOp_Word32 -> \args -> opAllDone $ \res -> do+ WriteByteArrayOp_Word32 -> \args -> opIntoRegs $ \res -> do doWriteByteArrayOp (Just (mo_WordTo32 platform)) b32 res args- WriteByteArrayOp_Word64 -> \args -> opAllDone $ \res -> do+ WriteByteArrayOp_Word64 -> \args -> opIntoRegs $ \res -> do doWriteByteArrayOp Nothing b64 res args -- WriteInt8ArrayAsXXX - WriteByteArrayOp_Word8AsChar -> \args -> opAllDone $ \res -> do+ WriteByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res -> do doWriteByteArrayOp (Just (mo_WordTo8 platform)) b8 res args- WriteByteArrayOp_Word8AsWideChar -> \args -> opAllDone $ \res -> do+ WriteByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> do doWriteByteArrayOp (Just (mo_WordTo32 platform)) b8 res args- WriteByteArrayOp_Word8AsInt -> \args -> opAllDone $ \res -> do+ WriteByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res -> do doWriteByteArrayOp Nothing b8 res args- WriteByteArrayOp_Word8AsWord -> \args -> opAllDone $ \res -> do+ WriteByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res -> do doWriteByteArrayOp Nothing b8 res args- WriteByteArrayOp_Word8AsAddr -> \args -> opAllDone $ \res -> do+ WriteByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> do doWriteByteArrayOp Nothing b8 res args- WriteByteArrayOp_Word8AsFloat -> \args -> opAllDone $ \res -> do+ WriteByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> do doWriteByteArrayOp Nothing b8 res args- WriteByteArrayOp_Word8AsDouble -> \args -> opAllDone $ \res -> do+ WriteByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> do doWriteByteArrayOp Nothing b8 res args- WriteByteArrayOp_Word8AsStablePtr -> \args -> opAllDone $ \res -> do+ WriteByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> do doWriteByteArrayOp Nothing b8 res args- WriteByteArrayOp_Word8AsInt16 -> \args -> opAllDone $ \res -> do+ WriteByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> do doWriteByteArrayOp (Just (mo_WordTo16 platform)) b8 res args- WriteByteArrayOp_Word8AsInt32 -> \args -> opAllDone $ \res -> do+ WriteByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> do doWriteByteArrayOp (Just (mo_WordTo32 platform)) b8 res args- WriteByteArrayOp_Word8AsInt64 -> \args -> opAllDone $ \res -> do+ WriteByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> do doWriteByteArrayOp Nothing b8 res args- WriteByteArrayOp_Word8AsWord16 -> \args -> opAllDone $ \res -> do+ WriteByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> do doWriteByteArrayOp (Just (mo_WordTo16 platform)) b8 res args- WriteByteArrayOp_Word8AsWord32 -> \args -> opAllDone $ \res -> do+ WriteByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> do doWriteByteArrayOp (Just (mo_WordTo32 platform)) b8 res args- WriteByteArrayOp_Word8AsWord64 -> \args -> opAllDone $ \res -> do+ WriteByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> do doWriteByteArrayOp Nothing b8 res args -- Copying and setting byte arrays- CopyByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opAllDone $ \[] -> do+ CopyByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opIntoRegs $ \[] -> do doCopyByteArrayOp src src_off dst dst_off n- CopyMutableByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opAllDone $ \[] -> do+ CopyMutableByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opIntoRegs $ \[] -> do doCopyMutableByteArrayOp src src_off dst dst_off n- CopyByteArrayToAddrOp -> \[src,src_off,dst,n] -> opAllDone $ \[] -> do+ CopyByteArrayToAddrOp -> \[src,src_off,dst,n] -> opIntoRegs $ \[] -> do doCopyByteArrayToAddrOp src src_off dst n- CopyMutableByteArrayToAddrOp -> \[src,src_off,dst,n] -> opAllDone $ \[] -> do+ CopyMutableByteArrayToAddrOp -> \[src,src_off,dst,n] -> opIntoRegs $ \[] -> do doCopyMutableByteArrayToAddrOp src src_off dst n- CopyAddrToByteArrayOp -> \[src,dst,dst_off,n] -> opAllDone $ \[] -> do+ CopyAddrToByteArrayOp -> \[src,dst,dst_off,n] -> opIntoRegs $ \[] -> do doCopyAddrToByteArrayOp src dst dst_off n- SetByteArrayOp -> \[ba,off,len,c] -> opAllDone $ \[] -> do+ SetByteArrayOp -> \[ba,off,len,c] -> opIntoRegs $ \[] -> do doSetByteArrayOp ba off len c -- Comparing byte arrays- CompareByteArraysOp -> \[ba1,ba1_off,ba2,ba2_off,n] -> opAllDone $ \[res] -> do+ CompareByteArraysOp -> \[ba1,ba1_off,ba2,ba2_off,n] -> opIntoRegs $ \[res] -> do doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n - BSwap16Op -> \[w] -> opAllDone $ \[res] -> do+ BSwap16Op -> \[w] -> opIntoRegs $ \[res] -> do emitBSwapCall res w W16- BSwap32Op -> \[w] -> opAllDone $ \[res] -> do+ BSwap32Op -> \[w] -> opIntoRegs $ \[res] -> do emitBSwapCall res w W32- BSwap64Op -> \[w] -> opAllDone $ \[res] -> do+ BSwap64Op -> \[w] -> opIntoRegs $ \[res] -> do emitBSwapCall res w W64- BSwapOp -> \[w] -> opAllDone $ \[res] -> do+ BSwapOp -> \[w] -> opIntoRegs $ \[res] -> do emitBSwapCall res w (wordWidth platform) - BRev8Op -> \[w] -> opAllDone $ \[res] -> do+ BRev8Op -> \[w] -> opIntoRegs $ \[res] -> do emitBRevCall res w W8- BRev16Op -> \[w] -> opAllDone $ \[res] -> do+ BRev16Op -> \[w] -> opIntoRegs $ \[res] -> do emitBRevCall res w W16- BRev32Op -> \[w] -> opAllDone $ \[res] -> do+ BRev32Op -> \[w] -> opIntoRegs $ \[res] -> do emitBRevCall res w W32- BRev64Op -> \[w] -> opAllDone $ \[res] -> do+ BRev64Op -> \[w] -> opIntoRegs $ \[res] -> do emitBRevCall res w W64- BRevOp -> \[w] -> opAllDone $ \[res] -> do+ BRevOp -> \[w] -> opIntoRegs $ \[res] -> do emitBRevCall res w (wordWidth platform) -- Population count- PopCnt8Op -> \[w] -> opAllDone $ \[res] -> do+ PopCnt8Op -> \[w] -> opIntoRegs $ \[res] -> do emitPopCntCall res w W8- PopCnt16Op -> \[w] -> opAllDone $ \[res] -> do+ PopCnt16Op -> \[w] -> opIntoRegs $ \[res] -> do emitPopCntCall res w W16- PopCnt32Op -> \[w] -> opAllDone $ \[res] -> do+ PopCnt32Op -> \[w] -> opIntoRegs $ \[res] -> do emitPopCntCall res w W32- PopCnt64Op -> \[w] -> opAllDone $ \[res] -> do+ PopCnt64Op -> \[w] -> opIntoRegs $ \[res] -> do emitPopCntCall res w W64- PopCntOp -> \[w] -> opAllDone $ \[res] -> do+ PopCntOp -> \[w] -> opIntoRegs $ \[res] -> do emitPopCntCall res w (wordWidth platform) -- Parallel bit deposit- Pdep8Op -> \[src, mask] -> opAllDone $ \[res] -> do+ Pdep8Op -> \[src, mask] -> opIntoRegs $ \[res] -> do emitPdepCall res src mask W8- Pdep16Op -> \[src, mask] -> opAllDone $ \[res] -> do+ Pdep16Op -> \[src, mask] -> opIntoRegs $ \[res] -> do emitPdepCall res src mask W16- Pdep32Op -> \[src, mask] -> opAllDone $ \[res] -> do+ Pdep32Op -> \[src, mask] -> opIntoRegs $ \[res] -> do emitPdepCall res src mask W32- Pdep64Op -> \[src, mask] -> opAllDone $ \[res] -> do+ Pdep64Op -> \[src, mask] -> opIntoRegs $ \[res] -> do emitPdepCall res src mask W64- PdepOp -> \[src, mask] -> opAllDone $ \[res] -> do+ PdepOp -> \[src, mask] -> opIntoRegs $ \[res] -> do emitPdepCall res src mask (wordWidth platform) -- Parallel bit extract- Pext8Op -> \[src, mask] -> opAllDone $ \[res] -> do+ Pext8Op -> \[src, mask] -> opIntoRegs $ \[res] -> do emitPextCall res src mask W8- Pext16Op -> \[src, mask] -> opAllDone $ \[res] -> do+ Pext16Op -> \[src, mask] -> opIntoRegs $ \[res] -> do emitPextCall res src mask W16- Pext32Op -> \[src, mask] -> opAllDone $ \[res] -> do+ Pext32Op -> \[src, mask] -> opIntoRegs $ \[res] -> do emitPextCall res src mask W32- Pext64Op -> \[src, mask] -> opAllDone $ \[res] -> do+ Pext64Op -> \[src, mask] -> opIntoRegs $ \[res] -> do emitPextCall res src mask W64- PextOp -> \[src, mask] -> opAllDone $ \[res] -> do+ PextOp -> \[src, mask] -> opIntoRegs $ \[res] -> do emitPextCall res src mask (wordWidth platform) -- count leading zeros- Clz8Op -> \[w] -> opAllDone $ \[res] -> do+ Clz8Op -> \[w] -> opIntoRegs $ \[res] -> do emitClzCall res w W8- Clz16Op -> \[w] -> opAllDone $ \[res] -> do+ Clz16Op -> \[w] -> opIntoRegs $ \[res] -> do emitClzCall res w W16- Clz32Op -> \[w] -> opAllDone $ \[res] -> do+ Clz32Op -> \[w] -> opIntoRegs $ \[res] -> do emitClzCall res w W32- Clz64Op -> \[w] -> opAllDone $ \[res] -> do+ Clz64Op -> \[w] -> opIntoRegs $ \[res] -> do emitClzCall res w W64- ClzOp -> \[w] -> opAllDone $ \[res] -> do+ ClzOp -> \[w] -> opIntoRegs $ \[res] -> do emitClzCall res w (wordWidth platform) -- count trailing zeros- Ctz8Op -> \[w] -> opAllDone $ \[res] -> do+ Ctz8Op -> \[w] -> opIntoRegs $ \[res] -> do emitCtzCall res w W8- Ctz16Op -> \[w] -> opAllDone $ \[res] -> do+ Ctz16Op -> \[w] -> opIntoRegs $ \[res] -> do emitCtzCall res w W16- Ctz32Op -> \[w] -> opAllDone $ \[res] -> do+ Ctz32Op -> \[w] -> opIntoRegs $ \[res] -> do emitCtzCall res w W32- Ctz64Op -> \[w] -> opAllDone $ \[res] -> do+ Ctz64Op -> \[w] -> opIntoRegs $ \[res] -> do emitCtzCall res w W64- CtzOp -> \[w] -> opAllDone $ \[res] -> do+ CtzOp -> \[w] -> opIntoRegs $ \[res] -> do emitCtzCall res w (wordWidth platform) -- Unsigned int to floating point conversions- Word2FloatOp -> \[w] -> opAllDone $ \[res] -> do+ Word2FloatOp -> \[w] -> opIntoRegs $ \[res] -> do emitPrimCall [res] (MO_UF_Conv W32) [w]- Word2DoubleOp -> \[w] -> opAllDone $ \[res] -> do+ Word2DoubleOp -> \[w] -> opIntoRegs $ \[res] -> do emitPrimCall [res] (MO_UF_Conv W64) [w] -- Atomic operations- InterlockedExchange_Addr -> \[src, value] -> opAllDone $ \[res] ->+ InterlockedExchange_Addr -> \[src, value] -> opIntoRegs $ \[res] -> emitPrimCall [res] (MO_Xchg (wordWidth platform)) [src, value]- InterlockedExchange_Int -> \[src, value] -> opAllDone $ \[res] ->+ InterlockedExchange_Int -> \[src, value] -> opIntoRegs $ \[res] -> emitPrimCall [res] (MO_Xchg (wordWidth platform)) [src, value] -- SIMD primops- (VecBroadcastOp vcat n w) -> \[e] -> opAllDone $ \[res] -> do+ (VecBroadcastOp vcat n w) -> \[e] -> opIntoRegs $ \[res] -> do checkVecCompatibility dflags vcat n w doVecPackOp (vecElemInjectCast platform vcat w) ty zeros (replicate n e) res where@@ -879,7 +869,7 @@ ty :: CmmType ty = vecVmmType vcat n w - (VecPackOp vcat n w) -> \es -> opAllDone $ \[res] -> do+ (VecPackOp vcat n w) -> \es -> opIntoRegs $ \[res] -> do checkVecCompatibility dflags vcat n w when (es `lengthIsNot` n) $ panic "emitPrimOp: VecPackOp has wrong number of arguments"@@ -897,7 +887,7 @@ ty :: CmmType ty = vecVmmType vcat n w - (VecUnpackOp vcat n w) -> \[arg] -> opAllDone $ \res -> do+ (VecUnpackOp vcat n w) -> \[arg] -> opIntoRegs $ \res -> do checkVecCompatibility dflags vcat n w when (res `lengthIsNot` n) $ panic "emitPrimOp: VecUnpackOp has wrong number of results"@@ -906,56 +896,56 @@ ty :: CmmType ty = vecVmmType vcat n w - (VecInsertOp vcat n w) -> \[v,e,i] -> opAllDone $ \[res] -> do+ (VecInsertOp vcat n w) -> \[v,e,i] -> opIntoRegs $ \[res] -> do checkVecCompatibility dflags vcat n w doVecInsertOp (vecElemInjectCast platform vcat w) ty v e i res where ty :: CmmType ty = vecVmmType vcat n w - (VecIndexByteArrayOp vcat n w) -> \args -> opAllDone $ \res0 -> do+ (VecIndexByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do checkVecCompatibility dflags vcat n w doIndexByteArrayOp Nothing ty res0 args where ty :: CmmType ty = vecVmmType vcat n w - (VecReadByteArrayOp vcat n w) -> \args -> opAllDone $ \res0 -> do+ (VecReadByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do checkVecCompatibility dflags vcat n w doIndexByteArrayOp Nothing ty res0 args where ty :: CmmType ty = vecVmmType vcat n w - (VecWriteByteArrayOp vcat n w) -> \args -> opAllDone $ \res0 -> do+ (VecWriteByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do checkVecCompatibility dflags vcat n w doWriteByteArrayOp Nothing ty res0 args where ty :: CmmType ty = vecVmmType vcat n w - (VecIndexOffAddrOp vcat n w) -> \args -> opAllDone $ \res0 -> do+ (VecIndexOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do checkVecCompatibility dflags vcat n w doIndexOffAddrOp Nothing ty res0 args where ty :: CmmType ty = vecVmmType vcat n w - (VecReadOffAddrOp vcat n w) -> \args -> opAllDone $ \res0 -> do+ (VecReadOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do checkVecCompatibility dflags vcat n w doIndexOffAddrOp Nothing ty res0 args where ty :: CmmType ty = vecVmmType vcat n w - (VecWriteOffAddrOp vcat n w) -> \args -> opAllDone $ \res0 -> do+ (VecWriteOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do checkVecCompatibility dflags vcat n w doWriteOffAddrOp Nothing ty res0 args where ty :: CmmType ty = vecVmmType vcat n w - (VecIndexScalarByteArrayOp vcat n w) -> \args -> opAllDone $ \res0 -> do+ (VecIndexScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do checkVecCompatibility dflags vcat n w doIndexByteArrayOpAs Nothing vecty ty res0 args where@@ -965,7 +955,7 @@ ty :: CmmType ty = vecCmmCat vcat w - (VecReadScalarByteArrayOp vcat n w) -> \args -> opAllDone $ \res0 -> do+ (VecReadScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do checkVecCompatibility dflags vcat n w doIndexByteArrayOpAs Nothing vecty ty res0 args where@@ -975,14 +965,14 @@ ty :: CmmType ty = vecCmmCat vcat w - (VecWriteScalarByteArrayOp vcat n w) -> \args -> opAllDone $ \res0 -> do+ (VecWriteScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do checkVecCompatibility dflags vcat n w doWriteByteArrayOp Nothing ty res0 args where ty :: CmmType ty = vecCmmCat vcat w - (VecIndexScalarOffAddrOp vcat n w) -> \args -> opAllDone $ \res0 -> do+ (VecIndexScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do checkVecCompatibility dflags vcat n w doIndexOffAddrOpAs Nothing vecty ty res0 args where@@ -992,7 +982,7 @@ ty :: CmmType ty = vecCmmCat vcat w - (VecReadScalarOffAddrOp vcat n w) -> \args -> opAllDone $ \res0 -> do+ (VecReadScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do checkVecCompatibility dflags vcat n w doIndexOffAddrOpAs Nothing vecty ty res0 args where@@ -1002,7 +992,7 @@ ty :: CmmType ty = vecCmmCat vcat w - (VecWriteScalarOffAddrOp vcat n w) -> \args -> opAllDone $ \res0 -> do+ (VecWriteScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do checkVecCompatibility dflags vcat n w doWriteOffAddrOp Nothing ty res0 args where@@ -1010,59 +1000,59 @@ ty = vecCmmCat vcat w -- Prefetch- PrefetchByteArrayOp3 -> \args -> opAllDone $ \[] -> do+ PrefetchByteArrayOp3 -> \args -> opIntoRegs $ \[] -> do doPrefetchByteArrayOp 3 args- PrefetchMutableByteArrayOp3 -> \args -> opAllDone $ \[] -> do+ PrefetchMutableByteArrayOp3 -> \args -> opIntoRegs $ \[] -> do doPrefetchMutableByteArrayOp 3 args- PrefetchAddrOp3 -> \args -> opAllDone $ \[] -> do+ PrefetchAddrOp3 -> \args -> opIntoRegs $ \[] -> do doPrefetchAddrOp 3 args- PrefetchValueOp3 -> \args -> opAllDone $ \[] -> do+ PrefetchValueOp3 -> \args -> opIntoRegs $ \[] -> do doPrefetchValueOp 3 args - PrefetchByteArrayOp2 -> \args -> opAllDone $ \[] -> do+ PrefetchByteArrayOp2 -> \args -> opIntoRegs $ \[] -> do doPrefetchByteArrayOp 2 args- PrefetchMutableByteArrayOp2 -> \args -> opAllDone $ \[] -> do+ PrefetchMutableByteArrayOp2 -> \args -> opIntoRegs $ \[] -> do doPrefetchMutableByteArrayOp 2 args- PrefetchAddrOp2 -> \args -> opAllDone $ \[] -> do+ PrefetchAddrOp2 -> \args -> opIntoRegs $ \[] -> do doPrefetchAddrOp 2 args- PrefetchValueOp2 -> \args -> opAllDone $ \[] -> do+ PrefetchValueOp2 -> \args -> opIntoRegs $ \[] -> do doPrefetchValueOp 2 args- PrefetchByteArrayOp1 -> \args -> opAllDone $ \[] -> do+ PrefetchByteArrayOp1 -> \args -> opIntoRegs $ \[] -> do doPrefetchByteArrayOp 1 args- PrefetchMutableByteArrayOp1 -> \args -> opAllDone $ \[] -> do+ PrefetchMutableByteArrayOp1 -> \args -> opIntoRegs $ \[] -> do doPrefetchMutableByteArrayOp 1 args- PrefetchAddrOp1 -> \args -> opAllDone $ \[] -> do+ PrefetchAddrOp1 -> \args -> opIntoRegs $ \[] -> do doPrefetchAddrOp 1 args- PrefetchValueOp1 -> \args -> opAllDone $ \[] -> do+ PrefetchValueOp1 -> \args -> opIntoRegs $ \[] -> do doPrefetchValueOp 1 args - PrefetchByteArrayOp0 -> \args -> opAllDone $ \[] -> do+ PrefetchByteArrayOp0 -> \args -> opIntoRegs $ \[] -> do doPrefetchByteArrayOp 0 args- PrefetchMutableByteArrayOp0 -> \args -> opAllDone $ \[] -> do+ PrefetchMutableByteArrayOp0 -> \args -> opIntoRegs $ \[] -> do doPrefetchMutableByteArrayOp 0 args- PrefetchAddrOp0 -> \args -> opAllDone $ \[] -> do+ PrefetchAddrOp0 -> \args -> opIntoRegs $ \[] -> do doPrefetchAddrOp 0 args- PrefetchValueOp0 -> \args -> opAllDone $ \[] -> do+ PrefetchValueOp0 -> \args -> opIntoRegs $ \[] -> do doPrefetchValueOp 0 args -- Atomic read-modify-write- FetchAddByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do+ FetchAddByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> do doAtomicRMW res AMO_Add mba ix (bWord platform) n- FetchSubByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do+ FetchSubByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> do doAtomicRMW res AMO_Sub mba ix (bWord platform) n- FetchAndByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do+ FetchAndByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> do doAtomicRMW res AMO_And mba ix (bWord platform) n- FetchNandByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do+ FetchNandByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> do doAtomicRMW res AMO_Nand mba ix (bWord platform) n- FetchOrByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do+ FetchOrByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> do doAtomicRMW res AMO_Or mba ix (bWord platform) n- FetchXorByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do+ FetchXorByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> do doAtomicRMW res AMO_Xor mba ix (bWord platform) n- AtomicReadByteArrayOp_Int -> \[mba, ix] -> opAllDone $ \[res] -> do+ AtomicReadByteArrayOp_Int -> \[mba, ix] -> opIntoRegs $ \[res] -> do doAtomicReadByteArray res mba ix (bWord platform)- AtomicWriteByteArrayOp_Int -> \[mba, ix, val] -> opAllDone $ \[] -> do+ AtomicWriteByteArrayOp_Int -> \[mba, ix, val] -> opIntoRegs $ \[] -> do doAtomicWriteByteArray mba ix (bWord platform) val- CasByteArrayOp_Int -> \[mba, ix, old, new] -> opAllDone $ \[res] -> do+ CasByteArrayOp_Int -> \[mba, ix, old, new] -> opIntoRegs $ \[res] -> do doCasByteArray res mba ix (bWord platform) old new -- The rest just translate straightforwardly@@ -1074,12 +1064,12 @@ ChrOp -> \args -> opNop args -- Int# and Char# are rep'd the same OrdOp -> \args -> opNop args - Narrow8IntOp -> \args -> opNarrow platform args (MO_SS_Conv, W8)- Narrow16IntOp -> \args -> opNarrow platform args (MO_SS_Conv, W16)- Narrow32IntOp -> \args -> opNarrow platform args (MO_SS_Conv, W32)- Narrow8WordOp -> \args -> opNarrow platform args (MO_UU_Conv, W8)- Narrow16WordOp -> \args -> opNarrow platform args (MO_UU_Conv, W16)- Narrow32WordOp -> \args -> opNarrow platform args (MO_UU_Conv, W32)+ Narrow8IntOp -> \args -> opNarrow args (MO_SS_Conv, W8)+ Narrow16IntOp -> \args -> opNarrow args (MO_SS_Conv, W16)+ Narrow32IntOp -> \args -> opNarrow args (MO_SS_Conv, W32)+ Narrow8WordOp -> \args -> opNarrow args (MO_UU_Conv, W8)+ Narrow16WordOp -> \args -> opNarrow args (MO_UU_Conv, W16)+ Narrow32WordOp -> \args -> opNarrow args (MO_UU_Conv, W32) DoublePowerOp -> \args -> opCallish args MO_F64_Pwr DoubleSinOp -> \args -> opCallish args MO_F64_Sin@@ -1333,6 +1323,7 @@ SameMutVarOp -> \args -> opTranslate args (mo_wordEq platform) SameMVarOp -> \args -> opTranslate args (mo_wordEq platform)+ SameIOPortOp -> \args -> opTranslate args (mo_wordEq platform) SameMutableArrayOp -> \args -> opTranslate args (mo_wordEq platform) SameMutableByteArrayOp -> \args -> opTranslate args (mo_wordEq platform) SameMutableArrayArrayOp -> \args -> opTranslate args (mo_wordEq platform)@@ -1408,7 +1399,7 @@ else Right genericWordMul2Op IntMul2Op -> \args -> opCallishHandledLater args $- if ncg && x86ish+ if ncg && x86ish || llvm then Left (MO_S_Mul2 (wordWidth platform)) else Right genericIntMul2Op @@ -1424,7 +1415,7 @@ -- tagToEnum# is special: we need to pull the constructor -- out of the table, and perform an appropriate return.- TagToEnumOp -> \[amode] -> PrimopCmmEmit_Raw $ \res_ty -> do+ TagToEnumOp -> \[amode] -> PrimopCmmEmit_Internal $ \res_ty -> do -- If you're reading this code in the attempt to figure -- out why the compiler panic'ed here, it is probably because -- you used tagToEnum# in a non-monomorphic setting, e.g.,@@ -1480,6 +1471,9 @@ ReadMVarOp -> alwaysExternal TryReadMVarOp -> alwaysExternal IsEmptyMVarOp -> alwaysExternal+ NewIOPortrOp -> alwaysExternal+ ReadIOPortOp -> alwaysExternal+ WriteIOPortOp -> alwaysExternal DelayOp -> alwaysExternal WaitReadOp -> alwaysExternal WaitWriteOp -> alwaysExternal@@ -1526,7 +1520,64 @@ SetThreadAllocationCounter -> alwaysExternal where- platform = targetPlatform dflags+ profile = targetProfile dflags+ platform = profilePlatform profile+ result_info = getPrimOpResultInfo primop++ opNop :: [CmmExpr] -> PrimopCmmEmit+ opNop args = opIntoRegs $ \[res] -> emitAssign (CmmLocal res) arg+ where [arg] = args++ opNarrow+ :: [CmmExpr]+ -> (Width -> Width -> MachOp, Width)+ -> PrimopCmmEmit+ opNarrow args (mop, rep) = opIntoRegs $ \[res] -> emitAssign (CmmLocal res) $+ CmmMachOp (mop rep (wordWidth platform)) [CmmMachOp (mop (wordWidth platform) rep) [arg]]+ where [arg] = args++ -- | These primops are implemented by CallishMachOps, because they sometimes+ -- turn into foreign calls depending on the backend.+ opCallish :: [CmmExpr] -> CallishMachOp -> PrimopCmmEmit+ opCallish args prim = opIntoRegs $ \[res] -> emitPrimCall [res] prim args++ opTranslate :: [CmmExpr] -> MachOp -> PrimopCmmEmit+ opTranslate args mop = opIntoRegs $ \[res] -> do+ let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args)+ emit stmt++ -- | Basically a "manual" case, rather than one of the common repetitive forms+ -- above. The results are a parameter to the returned function so we know the+ -- choice of variant never depends on them.+ opCallishHandledLater+ :: [CmmExpr]+ -> Either CallishMachOp GenericOp+ -> PrimopCmmEmit+ opCallishHandledLater args callOrNot = opIntoRegs $ \res0 -> case callOrNot of+ Left op -> emit $ mkUnsafeCall (PrimTarget op) res0 args+ Right gen -> gen res0 args++ opIntoRegs+ :: ([LocalReg] -- where to put the results+ -> FCode ())+ -> PrimopCmmEmit+ opIntoRegs f = PrimopCmmEmit_Internal $ \res_ty -> do+ regs <- if+ | ReturnsPrim VoidRep <- result_info+ -> pure []++ | ReturnsPrim rep <- result_info+ -> do reg <- newTemp (primRepCmmType platform rep)+ pure [reg]++ | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon+ -> do (regs, _hints) <- newUnboxedTupleRegs res_ty+ pure regs++ | otherwise -> panic "cgOpApp"+ f regs+ pure $ map (CmmReg . CmmLocal) regs+ alwaysExternal = \_ -> PrimopCmmEmit_External -- Note [QuotRem optimization] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1547,12 +1598,8 @@ [_, CmmLit (CmmInt n _) ] -> isJust (exactLog2 n) _ -> False - ncg = case hscTarget dflags of- HscAsm -> True- _ -> False- llvm = case hscTarget dflags of- HscLlvm -> True- _ -> False+ ncg = backend dflags == NCG+ llvm = backend dflags == LLVM x86ish = case platformArch platform of ArchX86 -> True ArchX86_64 -> True@@ -1563,54 +1610,12 @@ _ -> False data PrimopCmmEmit+ -- | Out of line fake primop that's actually just a foreign call to other+ -- (presumably) C--. = PrimopCmmEmit_External- | PrimopCmmEmit_IntoRegs ([LocalReg] -- where to put the results- -> FCode ())- -- | Manual escape hatch, this is just for the '@TagToEnum@'- -- primop for now. It would be nice to remove this special case but that is- -- future work.- | PrimopCmmEmit_Raw (Type -- the return type, some primops are specialized to it- -> FCode [CmmExpr]) -- just for TagToEnum for now--opNop :: [CmmExpr] -> PrimopCmmEmit-opNop args = PrimopCmmEmit_IntoRegs $ \[res] -> emitAssign (CmmLocal res) arg- where [arg] = args--opNarrow- :: Platform- -> [CmmExpr]- -> (Width -> Width -> MachOp, Width)- -> PrimopCmmEmit-opNarrow platform args (mop, rep) = PrimopCmmEmit_IntoRegs $ \[res] -> emitAssign (CmmLocal res) $- CmmMachOp (mop rep (wordWidth platform)) [CmmMachOp (mop (wordWidth platform) rep) [arg]]- where [arg] = args---- | These primops are implemented by CallishMachOps, because they sometimes--- turn into foreign calls depending on the backend.-opCallish :: [CmmExpr] -> CallishMachOp -> PrimopCmmEmit-opCallish args prim = PrimopCmmEmit_IntoRegs $ \[res] -> emitPrimCall [res] prim args--opTranslate :: [CmmExpr] -> MachOp -> PrimopCmmEmit-opTranslate args mop = PrimopCmmEmit_IntoRegs $ \[res] -> do- let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args)- emit stmt---- | Basically a "manual" case, rather than one of the common repetitive forms--- above. The results are a parameter to the returned function so we know the--- choice of variant never depends on them.-opCallishHandledLater- :: [CmmExpr]- -> Either CallishMachOp GenericOp- -> PrimopCmmEmit-opCallishHandledLater args callOrNot = PrimopCmmEmit_IntoRegs $ \res0 -> case callOrNot of- Left op -> emit $ mkUnsafeCall (PrimTarget op) res0 args- Right gen -> gen res0 args--opAllDone- :: ([LocalReg] -- where to put the results- -> FCode ())- -> PrimopCmmEmit-opAllDone f = PrimopCmmEmit_IntoRegs $ f+ -- | Real primop turned into inline C--.+ | PrimopCmmEmit_Internal (Type -- the return type, some primops are specialized to it+ -> FCode [CmmExpr]) -- just for TagToEnum for now type GenericOp = [CmmFormal] -> [CmmActual] -> FCode () @@ -1868,18 +1873,15 @@ genericWordMul2Op _ _ = panic "genericWordMul2Op" genericIntMul2Op :: GenericOp-genericIntMul2Op [res_c, res_h, res_l] [arg_x, arg_y]+genericIntMul2Op [res_c, res_h, res_l] both_args@[arg_x, arg_y] = do dflags <- getDynFlags platform <- getPlatform -- Implement algorithm from Hacker's Delight, 2nd edition, p.174 let t = cmmExprType platform arg_x p <- newTemp t -- 1) compute the multiplication as if numbers were unsigned- let wordMul2 = case emitPrimOp dflags WordMul2Op [arg_x,arg_y] of- PrimopCmmEmit_External -> panic "Unsupported out-of-line WordMul2Op"- PrimopCmmEmit_IntoRegs f -> f- PrimopCmmEmit_Raw _ -> panic "Unsupported inline WordMul2Op"- wordMul2 [p,res_l]+ _ <- withSequel (AssignTo [p, res_l] False) $+ cmmPrimOpApp dflags WordMul2Op both_args Nothing -- 2) correct the high bits of the unsigned result let carryFill x = CmmMachOp (MO_S_Shr ww) [x, wwm1] sub x y = CmmMachOp (MO_Sub ww) [x, y]@@ -1964,8 +1966,8 @@ -> [CmmExpr] -> FCode () doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]- = do dflags <- getDynFlags- mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr rep idx+ = do profile <- getProfile+ mkBasicIndexedRead (arrWordsHdrSize profile) maybe_post_read_cast rep res addr rep idx doIndexByteArrayOp _ _ _ _ = panic "GHC.StgToCmm.Prim: doIndexByteArrayOp" @@ -1976,8 +1978,8 @@ -> [CmmExpr] -> FCode () doIndexByteArrayOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]- = do dflags <- getDynFlags- mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx_rep idx+ = do profile <- getProfile+ mkBasicIndexedRead (arrWordsHdrSize profile) maybe_post_read_cast rep res addr idx_rep idx doIndexByteArrayOpAs _ _ _ _ _ = panic "GHC.StgToCmm.Prim: doIndexByteArrayOpAs" @@ -1986,9 +1988,9 @@ -> CmmExpr -> FCode () doReadPtrArrayOp res addr idx- = do dflags <- getDynFlags+ = do profile <- getProfile platform <- getPlatform- mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing (gcWord platform) res addr (gcWord platform) idx+ mkBasicIndexedRead (arrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx doWriteOffAddrOp :: Maybe MachOp -> CmmType@@ -2006,8 +2008,8 @@ -> [CmmExpr] -> FCode () doWriteByteArrayOp maybe_pre_write_cast idx_ty [] [addr,idx,val]- = do dflags <- getDynFlags- mkBasicIndexedWrite (arrWordsHdrSize dflags) maybe_pre_write_cast addr idx_ty idx val+ = do profile <- getProfile+ mkBasicIndexedWrite (arrWordsHdrSize profile) maybe_pre_write_cast addr idx_ty idx val doWriteByteArrayOp _ _ _ _ = panic "GHC.StgToCmm.Prim: doWriteByteArrayOp" @@ -2016,10 +2018,10 @@ -> CmmExpr -> FCode () doWritePtrArrayOp addr idx val- = do dflags <- getDynFlags+ = do profile <- getProfile platform <- getPlatform let ty = cmmExprType platform val- hdr_size = arrPtrsHdrSize dflags+ hdr_size = arrPtrsHdrSize profile -- Update remembered set for non-moving collector whenUpdRemSetEnabled $ emitUpdRemSetPush (cmmLoadIndexOffExpr platform hdr_size ty addr ty idx)@@ -2034,15 +2036,15 @@ emit $ mkStore ( cmmOffsetExpr platform (cmmOffsetExprW platform (cmmOffsetB platform addr hdr_size)- (loadArrPtrsSize dflags addr))+ (loadArrPtrsSize profile addr)) (CmmMachOp (mo_wordUShr platform) [idx,- mkIntExpr platform (mUT_ARR_PTRS_CARD_BITS dflags)])+ mkIntExpr platform (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform))]) ) (CmmLit (CmmInt 1 W8)) -loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr-loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB platform addr off) (bWord platform)- where off = fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags- platform = targetPlatform dflags+loadArrPtrsSize :: Profile -> CmmExpr -> CmmExpr+loadArrPtrsSize profile addr = CmmLoad (cmmOffsetB platform addr off) (bWord platform)+ where off = fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (profileConstants profile)+ platform = profilePlatform profile mkBasicIndexedRead :: ByteOff -- Initial offset in bytes -> Maybe MachOp -- Optional result cast@@ -2167,16 +2169,17 @@ checkVecCompatibility :: DynFlags -> PrimOpVecCat -> Length -> Width -> FCode () checkVecCompatibility dflags vcat l w = do- when (hscTarget dflags /= HscLlvm) $ do+ when (backend dflags /= LLVM) $ do sorry $ unlines ["SIMD vector instructions require the LLVM back-end." ,"Please use -fllvm."] check vecWidth vcat l w where+ platform = targetPlatform dflags check :: Width -> PrimOpVecCat -> Length -> Width -> FCode ()- check W128 FloatVec 4 W32 | not (isSseEnabled dflags) =+ check W128 FloatVec 4 W32 | not (isSseEnabled platform) = sorry $ "128-bit wide single-precision floating point " ++ "SIMD vector instructions require at least -msse."- check W128 _ _ _ | not (isSse2Enabled dflags) =+ check W128 _ _ _ | not (isSse2Enabled platform) = sorry $ "128-bit wide integer and double precision " ++ "SIMD vector instructions require at least -msse2." check W256 FloatVec _ _ | not (isAvxEnabled dflags) =@@ -2303,8 +2306,8 @@ -> [CmmExpr] -> FCode () doPrefetchByteArrayOp locality [addr,idx]- = do dflags <- getDynFlags- mkBasicPrefetch locality (arrWordsHdrSize dflags) addr idx+ = do profile <- getProfile+ mkBasicPrefetch locality (arrWordsHdrSize profile) addr idx doPrefetchByteArrayOp _ _ = panic "GHC.StgToCmm.Prim: doPrefetchByteArrayOp" @@ -2313,8 +2316,8 @@ -> [CmmExpr] -> FCode () doPrefetchMutableByteArrayOp locality [addr,idx]- = do dflags <- getDynFlags- mkBasicPrefetch locality (arrWordsHdrSize dflags) addr idx+ = do profile <- getProfile+ mkBasicPrefetch locality (arrWordsHdrSize profile) addr idx doPrefetchMutableByteArrayOp _ _ = panic "GHC.StgToCmm.Prim: doPrefetchByteArrayOp" @@ -2356,21 +2359,21 @@ -- 'MutableByteArray#'. doNewByteArrayOp :: CmmFormal -> ByteOff -> FCode () doNewByteArrayOp res_r n = do- dflags <- getDynFlags+ profile <- getProfile platform <- getPlatform let info_ptr = mkLblExpr mkArrWords_infoLabel rep = arrWordsRep platform n - tickyAllocPrim (mkIntExpr platform (arrWordsHdrSize dflags))+ tickyAllocPrim (mkIntExpr platform (arrWordsHdrSize profile)) (mkIntExpr platform (nonHdrSize platform rep)) (zeroExpr platform) - let hdr_size = fixedHdrSize dflags+ let hdr_size = fixedHdrSize profile base <- allocHeapClosure rep info_ptr cccsExpr [ (mkIntExpr platform n,- hdr_size + oFFSET_StgArrBytes_bytes dflags)+ hdr_size + pc_OFFSET_StgArrBytes_bytes (platformConstants platform)) ] emit $ mkAssign (CmmLocal res_r) base@@ -2381,10 +2384,10 @@ doCompareByteArraysOp :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n = do- dflags <- getDynFlags+ profile <- getProfile platform <- getPlatform- ba1_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba1 (arrWordsHdrSize dflags)) ba1_off- ba2_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba2 (arrWordsHdrSize dflags)) ba2_off+ ba1_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba1 (arrWordsHdrSize profile)) ba1_off+ ba2_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba2 (arrWordsHdrSize profile)) ba2_off -- short-cut in case of equal pointers avoiding a costly -- subroutine call to the memcmp(3) routine; the Cmm logic below@@ -2470,14 +2473,14 @@ -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () emitCopyByteArray copy src src_off dst dst_off n = do- dflags <- getDynFlags+ profile <- getProfile platform <- getPlatform let byteArrayAlignment = wordAlignment platform srcOffAlignment = cmmExprAlignment src_off dstOffAlignment = cmmExprAlignment dst_off align = minimum [byteArrayAlignment, srcOffAlignment, dstOffAlignment]- dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize dflags)) dst_off- src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize dflags)) src_off+ dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize profile)) dst_off+ src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize profile)) src_off copy src dst dst_p src_p n align -- | Takes a source 'ByteArray#', an offset in the source array, a@@ -2486,9 +2489,9 @@ doCopyByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () doCopyByteArrayToAddrOp src src_off dst_p bytes = do -- Use memcpy (we are allowed to assume the arrays aren't overlapping)- dflags <- getDynFlags+ profile <- getProfile platform <- getPlatform- src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize dflags)) src_off+ src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize profile)) src_off emitMemcpyCall dst_p src_p bytes (mkAlignment 1) -- | Takes a source 'MutableByteArray#', an offset in the source array, a@@ -2504,9 +2507,9 @@ doCopyAddrToByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () doCopyAddrToByteArrayOp src_p dst dst_off bytes = do -- Use memcpy (we are allowed to assume the arrays aren't overlapping)- dflags <- getDynFlags+ profile <- getProfile platform <- getPlatform- dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize dflags)) dst_off+ dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize profile)) dst_off emitMemcpyCall dst_p src_p bytes (mkAlignment 1) @@ -2519,14 +2522,14 @@ doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () doSetByteArrayOp ba off len c = do- dflags <- getDynFlags+ profile <- getProfile platform <- getPlatform let byteArrayAlignment = wordAlignment platform -- known since BA is allocated on heap offsetAlignment = cmmExprAlignment off align = min byteArrayAlignment offsetAlignment - p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba (arrWordsHdrSize dflags)) off+ p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba (arrWordsHdrSize profile)) off emitMemsetCall p c len align -- ----------------------------------------------------------------------------@@ -2541,12 +2544,12 @@ -> CmmExpr -- ^ initial element -> FCode () doNewArrayOp res_r rep info payload n init = do- dflags <- getDynFlags+ profile <- getProfile platform <- getPlatform let info_ptr = mkLblExpr info - tickyAllocPrim (mkIntExpr platform (hdrSize dflags rep))+ tickyAllocPrim (mkIntExpr platform (hdrSize profile rep)) (mkIntExpr platform (nonHdrSize platform rep)) (zeroExpr platform) @@ -2556,7 +2559,7 @@ emit $ mkAssign arr base -- Initialise all elements of the array- let mkOff off = cmmOffsetW platform (CmmReg arr) (hdrSizeW dflags rep + off)+ let mkOff off = cmmOffsetW platform (CmmReg arr) (hdrSizeW profile rep + off) initialization = [ mkStore (mkOff off) init | off <- [0.. n - 1] ] emit (catAGraphs initialization) @@ -2625,7 +2628,7 @@ -> FCode () emitCopyArray copy src0 src_off dst0 dst_off0 n = when (n /= 0) $ do- dflags <- getDynFlags+ profile <- getProfile platform <- getPlatform -- Passed as arguments (be careful)@@ -2634,23 +2637,23 @@ dst_off <- assignTempE dst_off0 -- Nonmoving collector write barrier- emitCopyUpdRemSetPush platform (arrPtrsHdrSizeW dflags) dst dst_off n+ emitCopyUpdRemSetPush platform (arrPtrsHdrSizeW profile) dst dst_off n -- Set the dirty bit in the header. emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) dst_elems_p <- assignTempE $ cmmOffsetB platform dst- (arrPtrsHdrSize dflags)+ (arrPtrsHdrSize profile) dst_p <- assignTempE $ cmmOffsetExprW platform dst_elems_p dst_off src_p <- assignTempE $ cmmOffsetExprW platform- (cmmOffsetB platform src (arrPtrsHdrSize dflags)) src_off+ (cmmOffsetB platform src (arrPtrsHdrSize profile)) src_off let bytes = wordsToBytes platform n copy src dst dst_p src_p bytes -- The base address of the destination card table dst_cards_p <- assignTempE $ cmmOffsetExprW platform dst_elems_p- (loadArrPtrsSize dflags dst)+ (loadArrPtrsSize profile dst) emitSetCards dst_off dst_cards_p n @@ -2692,7 +2695,7 @@ -> FCode () emitCopySmallArray copy src0 src_off dst0 dst_off n = when (n /= 0) $ do- dflags <- getDynFlags+ profile <- getProfile platform <- getPlatform -- Passed as arguments (be careful)@@ -2700,15 +2703,15 @@ dst <- assignTempE dst0 -- Nonmoving collector write barrier- emitCopyUpdRemSetPush platform (smallArrPtrsHdrSizeW dflags) dst dst_off n+ emitCopyUpdRemSetPush platform (smallArrPtrsHdrSizeW profile) dst dst_off n -- Set the dirty bit in the header. emit (setInfo dst (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel))) dst_p <- assignTempE $ cmmOffsetExprW platform- (cmmOffsetB platform dst (smallArrPtrsHdrSize dflags)) dst_off+ (cmmOffsetB platform dst (smallArrPtrsHdrSize profile)) dst_off src_p <- assignTempE $ cmmOffsetExprW platform- (cmmOffsetB platform src (smallArrPtrsHdrSize dflags)) src_off+ (cmmOffsetB platform src (smallArrPtrsHdrSize profile)) src_off let bytes = wordsToBytes platform n copy src dst dst_p src_p bytes@@ -2720,33 +2723,34 @@ emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff -> FCode () emitCloneArray info_p res_r src src_off n = do- dflags <- getDynFlags+ profile <- getProfile platform <- getPlatform let info_ptr = mkLblExpr info_p- rep = arrPtrsRep dflags n+ rep = arrPtrsRep platform n - tickyAllocPrim (mkIntExpr platform (arrPtrsHdrSize dflags))+ tickyAllocPrim (mkIntExpr platform (arrPtrsHdrSize profile)) (mkIntExpr platform (nonHdrSize platform rep)) (zeroExpr platform) - let hdr_size = fixedHdrSize dflags+ let hdr_size = fixedHdrSize profile+ constants = platformConstants platform base <- allocHeapClosure rep info_ptr cccsExpr [ (mkIntExpr platform n,- hdr_size + oFFSET_StgMutArrPtrs_ptrs dflags)+ hdr_size + pc_OFFSET_StgMutArrPtrs_ptrs constants) , (mkIntExpr platform (nonHdrSizeW rep),- hdr_size + oFFSET_StgMutArrPtrs_size dflags)+ hdr_size + pc_OFFSET_StgMutArrPtrs_size constants) ] arr <- CmmLocal `fmap` newTemp (bWord platform) emit $ mkAssign arr base dst_p <- assignTempE $ cmmOffsetB platform (CmmReg arr)- (arrPtrsHdrSize dflags)+ (arrPtrsHdrSize profile) src_p <- assignTempE $ cmmOffsetExprW platform src (cmmAddWord platform- (mkIntExpr platform (arrPtrsHdrSizeW dflags)) src_off)+ (mkIntExpr platform (arrPtrsHdrSizeW profile)) src_off) emitMemcpyCall dst_p src_p (mkIntExpr platform (wordsToBytes platform n)) (wordAlignment platform)@@ -2760,31 +2764,31 @@ emitCloneSmallArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff -> FCode () emitCloneSmallArray info_p res_r src src_off n = do- dflags <- getDynFlags+ profile <- getProfile platform <- getPlatform let info_ptr = mkLblExpr info_p rep = smallArrPtrsRep n - tickyAllocPrim (mkIntExpr platform (smallArrPtrsHdrSize dflags))+ tickyAllocPrim (mkIntExpr platform (smallArrPtrsHdrSize profile)) (mkIntExpr platform (nonHdrSize platform rep)) (zeroExpr platform) - let hdr_size = fixedHdrSize dflags+ let hdr_size = fixedHdrSize profile base <- allocHeapClosure rep info_ptr cccsExpr [ (mkIntExpr platform n,- hdr_size + oFFSET_StgSmallMutArrPtrs_ptrs dflags)+ hdr_size + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)) ] arr <- CmmLocal `fmap` newTemp (bWord platform) emit $ mkAssign arr base dst_p <- assignTempE $ cmmOffsetB platform (CmmReg arr)- (smallArrPtrsHdrSize dflags)+ (smallArrPtrsHdrSize profile) src_p <- assignTempE $ cmmOffsetExprW platform src (cmmAddWord platform- (mkIntExpr platform (smallArrPtrsHdrSizeW dflags)) src_off)+ (mkIntExpr platform (smallArrPtrsHdrSizeW profile)) src_off) emitMemcpyCall dst_p src_p (mkIntExpr platform (wordsToBytes platform n)) (wordAlignment platform)@@ -2797,10 +2801,9 @@ -- Marks the relevant cards as dirty. emitSetCards :: CmmExpr -> CmmExpr -> WordOff -> FCode () emitSetCards dst_start dst_cards_start n = do- dflags <- getDynFlags platform <- getPlatform- start_card <- assignTempE $ cardCmm dflags dst_start- let end_card = cardCmm dflags+ start_card <- assignTempE $ cardCmm platform dst_start+ let end_card = cardCmm platform (cmmSubWord platform (cmmAddWord platform dst_start (mkIntExpr platform n)) (mkIntExpr platform 1))@@ -2810,10 +2813,9 @@ (mkAlignment 1) -- no alignment (1 byte) -- Convert an element index to a card index-cardCmm :: DynFlags -> CmmExpr -> CmmExpr-cardCmm dflags i =- cmmUShrWord platform i (mkIntExpr platform (mUT_ARR_PTRS_CARD_BITS dflags))- where platform = targetPlatform dflags+cardCmm :: Platform -> CmmExpr -> CmmExpr+cardCmm platform i =+ cmmUShrWord platform i (mkIntExpr platform (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform))) ------------------------------------------------------------------------------ -- SmallArray PrimOp implementations@@ -2823,9 +2825,9 @@ -> CmmExpr -> FCode () doReadSmallPtrArrayOp res addr idx = do- dflags <- getDynFlags+ profile <- getProfile platform <- getPlatform- mkBasicIndexedRead (smallArrPtrsHdrSize dflags) Nothing (gcWord platform) res addr+ mkBasicIndexedRead (smallArrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx doWriteSmallPtrArrayOp :: CmmExpr@@ -2833,17 +2835,17 @@ -> CmmExpr -> FCode () doWriteSmallPtrArrayOp addr idx val = do- dflags <- getDynFlags+ profile <- getProfile platform <- getPlatform let ty = cmmExprType platform val -- Update remembered set for non-moving collector tmp <- newTemp ty- mkBasicIndexedRead (smallArrPtrsHdrSize dflags) Nothing ty tmp addr ty idx+ mkBasicIndexedRead (smallArrPtrsHdrSize profile) Nothing ty tmp addr ty idx whenUpdRemSetEnabled $ emitUpdRemSetPush (CmmReg (CmmLocal tmp)) emitPrimCall [] MO_WriteBarrier [] -- #12469- mkBasicIndexedWrite (smallArrPtrsHdrSize dflags) Nothing addr ty idx val+ mkBasicIndexedWrite (smallArrPtrsHdrSize profile) Nothing addr ty idx val emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel))) ------------------------------------------------------------------------------@@ -2860,10 +2862,10 @@ -> CmmExpr -- ^ Op argument (e.g. amount to add) -> FCode () doAtomicRMW res amop mba idx idx_ty n = do- dflags <- getDynFlags+ profile <- getProfile platform <- getPlatform let width = typeWidth idx_ty- addr = cmmIndexOffExpr platform (arrWordsHdrSize dflags)+ addr = cmmIndexOffExpr platform (arrWordsHdrSize profile) width mba idx emitPrimCall [ res ]@@ -2878,10 +2880,10 @@ -> CmmType -- ^ Type of element by which we are indexing -> FCode () doAtomicReadByteArray res mba idx idx_ty = do- dflags <- getDynFlags+ profile <- getProfile platform <- getPlatform let width = typeWidth idx_ty- addr = cmmIndexOffExpr platform (arrWordsHdrSize dflags)+ addr = cmmIndexOffExpr platform (arrWordsHdrSize profile) width mba idx emitPrimCall [ res ]@@ -2896,10 +2898,10 @@ -> CmmExpr -- ^ Value to write -> FCode () doAtomicWriteByteArray mba idx idx_ty val = do- dflags <- getDynFlags+ profile <- getProfile platform <- getPlatform let width = typeWidth idx_ty- addr = cmmIndexOffExpr platform (arrWordsHdrSize dflags)+ addr = cmmIndexOffExpr platform (arrWordsHdrSize profile) width mba idx emitPrimCall [ {- no results -} ]@@ -2915,10 +2917,10 @@ -> CmmExpr -- ^ New value -> FCode () doCasByteArray res mba idx idx_ty old new = do- dflags <- getDynFlags+ profile <- getProfile platform <- getPlatform let width = (typeWidth idx_ty)- addr = cmmIndexOffExpr platform (arrWordsHdrSize dflags)+ addr = cmmIndexOffExpr platform (arrWordsHdrSize profile) width mba idx emitPrimCall [ res ]
compiler/GHC/StgToCmm/Prof.hs view
@@ -26,6 +26,7 @@ import GHC.Prelude import GHC.Platform+import GHC.Platform.Profile import GHC.StgToCmm.Closure import GHC.StgToCmm.Utils import GHC.StgToCmm.Monad@@ -67,32 +68,30 @@ mkCCostCentreStack :: CostCentreStack -> CmmLit mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs) -costCentreFrom :: DynFlags- -> CmmExpr -- A closure pointer+costCentreFrom :: Platform+ -> CmmExpr -- A closure pointer -> CmmExpr -- The cost centre from that closure-costCentreFrom dflags cl = CmmLoad (cmmOffsetB platform cl (oFFSET_StgHeader_ccs dflags)) (ccsType platform)- where platform = targetPlatform dflags+costCentreFrom platform cl = CmmLoad (cmmOffsetB platform cl (pc_OFFSET_StgHeader_ccs (platformConstants platform))) (ccsType platform) -- | The profiling header words in a static closure-staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit]-staticProfHdr dflags ccs- | sccProfilingEnabled dflags = [mkCCostCentreStack ccs, staticLdvInit platform]+staticProfHdr :: Profile -> CostCentreStack -> [CmmLit]+staticProfHdr profile ccs+ | profileIsProfiling profile = [mkCCostCentreStack ccs, staticLdvInit platform] | otherwise = []- where platform = targetPlatform dflags+ where platform = profilePlatform profile -- | Profiling header words in a dynamic closure-dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr]-dynProfHdr dflags ccs- | sccProfilingEnabled dflags = [ccs, dynLdvInit dflags]+dynProfHdr :: Profile -> CmmExpr -> [CmmExpr]+dynProfHdr profile ccs+ | profileIsProfiling profile = [ccs, dynLdvInit (profilePlatform profile)] | otherwise = [] -- | Initialise the profiling field of an update frame initUpdFrameProf :: CmmExpr -> FCode () initUpdFrameProf frame = ifProfiling $ -- frame->header.prof.ccs = CCCS- do dflags <- getDynFlags- platform <- getPlatform- emitStore (cmmOffset platform frame (oFFSET_StgHeader_ccs dflags)) cccsExpr+ do platform <- getPlatform+ emitStore (cmmOffset platform frame (pc_OFFSET_StgHeader_ccs (platformConstants platform))) cccsExpr -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0) -- is unnecessary because it is not used anyhow. @@ -152,9 +151,9 @@ profDynAlloc :: SMRep -> CmmExpr -> FCode () profDynAlloc rep ccs = ifProfiling $- do dflags <- getDynFlags- platform <- getPlatform- profAlloc (mkIntExpr platform (heapClosureSizeW dflags rep)) ccs+ do profile <- targetProfile <$> getDynFlags+ let platform = profilePlatform profile+ profAlloc (mkIntExpr platform (heapClosureSizeW profile rep)) ccs -- | Record the allocation of a closure (size is given by a CmmExpr) -- The size must be in words, because the allocation counter in a CCS counts@@ -162,16 +161,16 @@ profAlloc :: CmmExpr -> CmmExpr -> FCode () profAlloc words ccs = ifProfiling $- do dflags <- getDynFlags- platform <- getPlatform- let alloc_rep = rEP_CostCentreStack_mem_alloc dflags- emit (addToMemE alloc_rep- (cmmOffsetB platform ccs (oFFSET_CostCentreStack_mem_alloc dflags))+ do profile <- targetProfile <$> getDynFlags+ let platform = profilePlatform profile+ let alloc_rep = rEP_CostCentreStack_mem_alloc platform+ emit $ addToMemE alloc_rep+ (cmmOffsetB platform ccs (pc_OFFSET_CostCentreStack_mem_alloc (platformConstants platform))) (CmmMachOp (MO_UU_Conv (wordWidth platform) (typeWidth alloc_rep)) $- [CmmMachOp (mo_wordSub platform) [words,- mkIntExpr platform (profHdrSize dflags)]]))- -- subtract the "profiling overhead", which is the- -- profiling header in a closure.+ -- subtract the "profiling overhead", which is the+ -- profiling header in a closure.+ [CmmMachOp (mo_wordSub platform) [ words, mkIntExpr platform (profHdrSize profile)]]+ ) -- ----------------------------------------------------------------------- -- Setting the current cost centre on entry to a closure@@ -179,23 +178,23 @@ enterCostCentreThunk :: CmmExpr -> FCode () enterCostCentreThunk closure = ifProfiling $ do- dflags <- getDynFlags- emit $ storeCurCCS (costCentreFrom dflags closure)+ platform <- getPlatform+ emit $ storeCurCCS (costCentreFrom platform closure) enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode () enterCostCentreFun ccs closure = ifProfiling $ do if isCurrentCCS ccs- then do dflags <- getDynFlags+ then do platform <- getPlatform emitRtsCall rtsUnitId (fsLit "enterFunCCS") [(baseExpr, AddrHint),- (costCentreFrom dflags closure, AddrHint)] False+ (costCentreFrom platform closure, AddrHint)] False else return () -- top-level function, nothing to do ifProfiling :: FCode () -> FCode () ifProfiling code- = do dflags <- getDynFlags- if sccProfilingEnabled dflags+ = do profile <- targetProfile <$> getDynFlags+ if profileIsProfiling profile then code else return () @@ -206,10 +205,9 @@ initCostCentres :: CollectedCCs -> FCode () -- Emit the declarations initCostCentres (local_CCs, singleton_CCSs)- = do dflags <- getDynFlags- when (sccProfilingEnabled dflags) $- do mapM_ emitCostCentreDecl local_CCs- mapM_ emitCostCentreStackDecl singleton_CCSs+ = ifProfiling $ do+ mapM_ emitCostCentreDecl local_CCs+ mapM_ emitCostCentreStackDecl singleton_CCSs emitCostCentreDecl :: CostCentre -> FCode ()@@ -243,11 +241,10 @@ emitCostCentreStackDecl ccs = case maybeSingletonCCS ccs of Just cc ->- do dflags <- getDynFlags- platform <- getPlatform+ do platform <- getPlatform let mk_lits cc = zero platform : mkCCostCentre cc :- replicate (sizeof_ccs_words dflags - 2) (zero platform)+ replicate (sizeof_ccs_words platform - 2) (zero platform) -- Note: to avoid making any assumptions about how the -- C compiler (that compiles the RTS, in particular) does -- layouts of structs containing long-longs, simply@@ -261,27 +258,26 @@ zero64 :: CmmLit zero64 = CmmInt 0 W64 -sizeof_ccs_words :: DynFlags -> Int-sizeof_ccs_words dflags+sizeof_ccs_words :: Platform -> Int+sizeof_ccs_words platform -- round up to the next word. | ms == 0 = ws | otherwise = ws + 1 where- platform = targetPlatform dflags- (ws,ms) = sIZEOF_CostCentreStack dflags `divMod` platformWordSizeInBytes platform+ (ws,ms) = pc_SIZEOF_CostCentreStack (platformConstants platform) `divMod` platformWordSizeInBytes platform -- --------------------------------------------------------------------------- -- Set the current cost centre stack emitSetCCC :: CostCentre -> Bool -> Bool -> FCode () emitSetCCC cc tick push- = do dflags <- getDynFlags- platform <- getPlatform- if not (sccProfilingEnabled dflags)+ = do profile <- targetProfile <$> getDynFlags+ let platform = profilePlatform profile+ if not (profileIsProfiling profile) then return () else do tmp <- newTemp (ccsType platform) pushCostCentre tmp cccsExpr cc- when tick $ emit (bumpSccCount dflags (CmmReg (CmmLocal tmp)))+ when tick $ emit (bumpSccCount platform (CmmReg (CmmLocal tmp))) when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp))) pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()@@ -292,11 +288,10 @@ (CmmLit (mkCCostCentre cc), AddrHint)] False -bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph-bumpSccCount dflags ccs- = addToMem (rEP_CostCentreStack_scc_count dflags)- (cmmOffsetB platform ccs (oFFSET_CostCentreStack_scc_count dflags)) 1- where platform = targetPlatform dflags+bumpSccCount :: Platform -> CmmExpr -> CmmAGraph+bumpSccCount platform ccs+ = addToMem (rEP_CostCentreStack_scc_count platform)+ (cmmOffsetB platform ccs (pc_OFFSET_CostCentreStack_scc_count (platformConstants platform))) 1 ----------------------------------------------------------------------------- --@@ -313,22 +308,20 @@ -- -- Initial value of the LDV field in a dynamic closure ---dynLdvInit :: DynFlags -> CmmExpr-dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE+dynLdvInit :: Platform -> CmmExpr+dynLdvInit platform = -- (era << LDV_SHIFT) | LDV_STATE_CREATE CmmMachOp (mo_wordOr platform) [- CmmMachOp (mo_wordShl platform) [loadEra dflags, mkIntExpr platform (lDV_SHIFT dflags)],- CmmLit (mkWordCLit platform (iLDV_STATE_CREATE dflags))+ CmmMachOp (mo_wordShl platform) [loadEra platform, mkIntExpr platform (pc_LDV_SHIFT (platformConstants platform))],+ CmmLit (mkWordCLit platform (pc_ILDV_STATE_CREATE (platformConstants platform))) ]- where- platform = targetPlatform dflags -- -- Initialise the LDV word of a new closure -- ldvRecordCreate :: CmmExpr -> FCode () ldvRecordCreate closure = do- dflags <- getDynFlags- emit $ mkStore (ldvWord dflags closure) (dynLdvInit dflags)+ platform <- getPlatform+ emit $ mkStore (ldvWord platform closure) (dynLdvInit platform) -- -- | Called when a closure is entered, marks the closure as having@@ -337,40 +330,37 @@ -- ldvEnterClosure :: ClosureInfo -> CmmReg -> FCode () ldvEnterClosure closure_info node_reg = do- dflags <- getDynFlags platform <- getPlatform- let tag = funTag dflags closure_info+ let tag = funTag platform closure_info -- don't forget to subtract node's tag ldvEnter (cmmOffsetB platform (CmmReg node_reg) (-tag)) ldvEnter :: CmmExpr -> FCode () -- Argument is a closure pointer ldvEnter cl_ptr = do- dflags <- getDynFlags platform <- getPlatform- let -- don't forget to subtract node's tag- ldv_wd = ldvWord dflags cl_ptr+ let constants = platformConstants platform+ -- don't forget to subtract node's tag+ ldv_wd = ldvWord platform cl_ptr new_ldv_wd = cmmOrWord platform (cmmAndWord platform (CmmLoad ldv_wd (bWord platform))- (CmmLit (mkWordCLit platform (iLDV_CREATE_MASK dflags))))- (cmmOrWord platform (loadEra dflags) (CmmLit (mkWordCLit platform (iLDV_STATE_USE dflags))))+ (CmmLit (mkWordCLit platform (pc_ILDV_CREATE_MASK constants))))+ (cmmOrWord platform (loadEra platform) (CmmLit (mkWordCLit platform (pc_ILDV_STATE_USE constants)))) ifProfiling $ -- if (era > 0) { -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) | -- era | LDV_STATE_USE }- emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt platform) [loadEra dflags, CmmLit (zeroCLit platform)])+ emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt platform) [loadEra platform, CmmLit (zeroCLit platform)]) (mkStore ldv_wd new_ldv_wd) mkNop -loadEra :: DynFlags -> CmmExpr-loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth platform))+loadEra :: Platform -> CmmExpr+loadEra platform = CmmMachOp (MO_UU_Conv (cIntWidth platform) (wordWidth platform)) [CmmLoad (mkLblExpr (mkRtsCmmDataLabel (fsLit "era")))- (cInt dflags)]- where platform = targetPlatform dflags+ (cInt platform)] -ldvWord :: DynFlags -> CmmExpr -> CmmExpr--- Takes the address of a closure, and returns+-- | Takes the address of a closure, and returns -- the address of the LDV word in the closure-ldvWord dflags closure_ptr- = cmmOffsetB platform closure_ptr (oFFSET_StgHeader_ldvw dflags)- where platform = targetPlatform dflags+ldvWord :: Platform -> CmmExpr -> CmmExpr+ldvWord platform closure_ptr+ = cmmOffsetB platform closure_ptr (pc_OFFSET_StgHeader_ldvw (platformConstants platform))
compiler/GHC/StgToCmm/Ticky.hs view
@@ -103,6 +103,8 @@ import GHC.Prelude import GHC.Platform+import GHC.Platform.Profile+ import GHC.StgToCmm.ArgRep ( slowCallPattern , toArgRep , argRepString ) import GHC.StgToCmm.Closure import GHC.StgToCmm.Utils@@ -340,20 +342,20 @@ -- ticky_entry_ctrs = & (f_ct); /* mark it as "registered" */ -- f_ct.registeredp = 1 } registerTickyCtr ctr_lbl = do- dflags <- getDynFlags platform <- getPlatform let+ constants = platformConstants platform -- krc: code generator doesn't handle Not, so we test for Eq 0 instead test = CmmMachOp (MO_Eq (wordWidth platform)) [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl- (oFFSET_StgEntCounter_registeredp dflags))) (bWord platform),+ (pc_OFFSET_StgEntCounter_registeredp constants))) (bWord platform), zeroExpr platform] register_stmts- = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_link dflags)))+ = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl (pc_OFFSET_StgEntCounter_link constants))) (CmmLoad ticky_entry_ctrs (bWord platform)) , mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl) , mkStore (CmmLit (cmmLabelOffB ctr_lbl- (oFFSET_StgEntCounter_registeredp dflags)))+ (pc_OFFSET_StgEntCounter_registeredp constants))) (mkIntExpr platform 1) ] ticky_entry_ctrs = mkLblExpr (mkRtsCmmDataLabel (fsLit "ticky_entry_ctrs")) emit =<< mkCmmIfThen test (catAGraphs register_stmts)@@ -440,9 +442,9 @@ -- -- TODO what else to count while we're here? tickyDynAlloc mb_id rep lf = ifTicky $ do- dflags <- getDynFlags- let platform = targetPlatform dflags- bytes = platformWordSizeInBytes platform * heapClosureSizeW dflags rep+ profile <- getProfile+ let platform = profilePlatform profile+ bytes = platformWordSizeInBytes platform * heapClosureSizeW profile rep countGlobal tot ctr = do bumpTickyCounterBy tot bytes@@ -482,8 +484,7 @@ -- Must be lazy in the amount of allocation! tickyAllocHeap genuine hp = ifTicky $- do { dflags <- getDynFlags- ; platform <- getPlatform+ do { platform <- getPlatform ; ticky_ctr <- getTickyCtrLabel ; emit $ catAGraphs $ -- only test hp from within the emit so that the monadic@@ -492,8 +493,8 @@ if hp == 0 then [] else let !bytes = platformWordSizeInBytes platform * hp in [ -- Bump the allocation total in the closure's StgEntCounter- addToMem (rEP_StgEntCounter_allocs dflags)- (CmmLit (cmmLabelOffB ticky_ctr (oFFSET_StgEntCounter_allocs dflags)))+ addToMem (rEP_StgEntCounter_allocs platform)+ (CmmLit (cmmLabelOffB ticky_ctr (pc_OFFSET_StgEntCounter_allocs (platformConstants platform)))) bytes, -- Bump the global allocation total ALLOC_HEAP_tot addToMemLbl (bWord platform)@@ -576,13 +577,13 @@ bumpTickyEntryCount :: CLabel -> FCode () bumpTickyEntryCount lbl = do- dflags <- getDynFlags- bumpTickyLit (cmmLabelOffB lbl (oFFSET_StgEntCounter_entry_count dflags))+ platform <- getPlatform+ bumpTickyLit (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_entry_count (platformConstants platform))) bumpTickyAllocd :: CLabel -> Int -> FCode () bumpTickyAllocd lbl bytes = do- dflags <- getDynFlags- bumpTickyLitBy (cmmLabelOffB lbl (oFFSET_StgEntCounter_allocd dflags)) bytes+ platform <- getPlatform+ bumpTickyLitBy (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_allocd (platformConstants platform))) bytes bumpTickyLbl :: CLabel -> FCode () bumpTickyLbl lhs = bumpTickyLitBy (cmmLabelOffB lhs 0) 1@@ -608,9 +609,8 @@ bumpHistogram :: FastString -> Int -> FCode () bumpHistogram lbl n = do- dflags <- getDynFlags platform <- getPlatform- let offset = n `min` (tICKY_BIN_COUNT dflags - 1)+ let offset = n `min` (pc_TICKY_BIN_COUNT (platformConstants platform) - 1) emit (addToMem (bWord platform) (cmmIndexExpr platform (wordWidth platform)
compiler/GHC/StgToCmm/Utils.hs view
@@ -197,9 +197,9 @@ -> Bool -- True <=> CmmSafe call -> FCode () emitRtsCallGen res lbl args safe- = do { dflags <- getDynFlags+ = do { platform <- targetPlatform <$> getDynFlags ; updfr_off <- getUpdFrameOff- ; let (caller_save, caller_load) = callerSaveVolatileRegs dflags+ ; let (caller_save, caller_load) = callerSaveVolatileRegs platform ; emit caller_save ; call updfr_off ; emit caller_load }@@ -245,13 +245,11 @@ -- "GHC.Cmm.Node". Right now the workaround is to avoid inlining across -- unsafe foreign calls in rewriteAssignments, but this is strictly -- temporary.-callerSaveVolatileRegs :: DynFlags -> (CmmAGraph, CmmAGraph)-callerSaveVolatileRegs dflags = (caller_save, caller_load)+callerSaveVolatileRegs :: Platform -> (CmmAGraph, CmmAGraph)+callerSaveVolatileRegs platform = (caller_save, caller_load) where- platform = targetPlatform dflags-- caller_save = catAGraphs (map (callerSaveGlobalReg dflags) regs_to_save)- caller_load = catAGraphs (map (callerRestoreGlobalReg dflags) regs_to_save)+ caller_save = catAGraphs (map (callerSaveGlobalReg platform) regs_to_save)+ caller_load = catAGraphs (map (callerRestoreGlobalReg platform) regs_to_save) system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery {- ,SparkHd,SparkTl,SparkBase,SparkLim -}@@ -259,14 +257,14 @@ regs_to_save = filter (callerSaves platform) system_regs -callerSaveGlobalReg :: DynFlags -> GlobalReg -> CmmAGraph-callerSaveGlobalReg dflags reg- = mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg))+callerSaveGlobalReg :: Platform -> GlobalReg -> CmmAGraph+callerSaveGlobalReg platform reg+ = mkStore (get_GlobalReg_addr platform reg) (CmmReg (CmmGlobal reg)) -callerRestoreGlobalReg :: DynFlags -> GlobalReg -> CmmAGraph-callerRestoreGlobalReg dflags reg+callerRestoreGlobalReg :: Platform -> GlobalReg -> CmmAGraph+callerRestoreGlobalReg platform reg = mkAssign (CmmGlobal reg)- (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType (targetPlatform dflags) reg))+ (CmmLoad (get_GlobalReg_addr platform reg) (globalRegType platform reg)) -------------------------------------------------------------------------
compiler/GHC/SysTools.hs view
@@ -47,7 +47,7 @@ import GHC.Utils.Error import GHC.Platform import GHC.Driver.Session-import GHC.Driver.Ways+import GHC.Platform.Ways import Control.Monad.Trans.Except (runExceptT) import System.FilePath@@ -274,7 +274,9 @@ 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
compiler/GHC/SysTools/Info.hs view
@@ -241,7 +241,7 @@ | any ("Apple clang version" `isPrefixOf`) stde = return AppleClang -- Unknown linker.- | otherwise = fail "invalid -v output, or compiler is unsupported"+ | otherwise = fail $ "invalid -v output, or compiler is unsupported: " ++ unlines stde -- Process the executable call info <- catchIO (do
compiler/GHC/SysTools/Tasks.hs view
@@ -307,7 +307,7 @@ args2 = [Option "-static"] ++ args1 ++ args ++ linkargs libtool = pgm_libtool dflags mb_env <- getGccEnv args2- runSomethingFiltered dflags id "Linker" libtool args2 Nothing mb_env+ runSomethingFiltered dflags id "Libtool" libtool args2 Nothing mb_env runAr :: DynFlags -> Maybe FilePath -> [Option] -> IO () runAr dflags cwd args = traceToolCommand dflags "ar" $ do
compiler/GHC/Tc/Deriv.hs view
@@ -2038,9 +2038,12 @@ -> gen_newtype_or_via rhs_ty -- Try a stock deriver- DerivSpecStock { dsm_stock_dit = DerivInstTys{dit_rep_tc = rep_tc}+ DerivSpecStock { dsm_stock_dit = DerivInstTys+ { dit_rep_tc = rep_tc+ , dit_rep_tc_args = rep_tc_args+ } , dsm_stock_gen_fn = gen_fn }- -> do (binds, faminsts, field_names) <- gen_fn loc rep_tc inst_tys+ -> do (binds, faminsts, field_names) <- gen_fn loc rep_tc rep_tc_args inst_tys pure (binds, [], faminsts, field_names) -- Try DeriveAnyClass
compiler/GHC/Tc/Deriv/Functor.hs view
@@ -151,10 +151,10 @@ $(coreplace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(coreplace 'a' 'tc' (x $(replace 'a 'tb y))) -} -gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)+gen_Functor_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff) -- When the argument is phantom, we can use fmap _ = coerce -- See Note [Phantom types with Functor, Foldable, and Traversable]-gen_Functor_binds loc tycon+gen_Functor_binds loc tycon _ | Phantom <- last (tyConRoles tycon) = (unitBag fmap_bind, emptyBag) where@@ -165,10 +165,10 @@ coerce_Expr] fmap_match_ctxt = mkPrefixFunRhs fmap_name -gen_Functor_binds loc tycon+gen_Functor_binds loc tycon tycon_args = (listToBag [fmap_bind, replace_bind], emptyBag) where- data_cons = tyConDataCons tycon+ data_cons = getPossibleDataCons tycon tycon_args fmap_name = L loc fmap_RDR -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]@@ -787,10 +787,10 @@ think it's okay to do it for now. -} -gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)+gen_Foldable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff) -- When the parameter is phantom, we can use foldMap _ _ = mempty -- See Note [Phantom types with Functor, Foldable, and Traversable]-gen_Foldable_binds loc tycon+gen_Foldable_binds loc tycon _ | Phantom <- last (tyConRoles tycon) = (unitBag foldMap_bind, emptyBag) where@@ -801,7 +801,7 @@ mempty_Expr] foldMap_match_ctxt = mkPrefixFunRhs foldMap_name -gen_Foldable_binds loc tycon+gen_Foldable_binds loc tycon tycon_args | null data_cons -- There's no real point producing anything but -- foldMap for a type with no constructors. = (unitBag foldMap_bind, emptyBag)@@ -809,7 +809,7 @@ | otherwise = (listToBag [foldr_bind, foldMap_bind, null_bind], emptyBag) where- data_cons = tyConDataCons tycon+ data_cons = getPossibleDataCons tycon tycon_args foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns eqns = map foldr_eqn data_cons@@ -1016,10 +1016,10 @@ See Note [Generated code for DeriveFoldable and DeriveTraversable]. -} -gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)+gen_Traversable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff) -- When the argument is phantom, we can use traverse = pure . coerce -- See Note [Phantom types with Functor, Foldable, and Traversable]-gen_Traversable_binds loc tycon+gen_Traversable_binds loc tycon _ | Phantom <- last (tyConRoles tycon) = (unitBag traverse_bind, emptyBag) where@@ -1031,10 +1031,10 @@ (nlHsApps pure_RDR [nlHsApp coerce_Expr z_Expr])] traverse_match_ctxt = mkPrefixFunRhs traverse_name -gen_Traversable_binds loc tycon+gen_Traversable_binds loc tycon tycon_args = (unitBag traverse_bind, emptyBag) where- data_cons = tyConDataCons tycon+ data_cons = getPossibleDataCons tycon tycon_args traverse_name = L loc traverse_RDR
compiler/GHC/Tc/Deriv/Generate.hs view
@@ -33,7 +33,9 @@ mkCoerceClassMethEqn, genAuxBinds, ordOpTbl, boxConTbl, litConTbl,- mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr+ mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr,++ getPossibleDataCons, tyConInstArgTys ) where #include "GhclibHsVersions.h"@@ -212,14 +214,14 @@ produced don't get through the typechecker. -} -gen_Eq_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)-gen_Eq_binds loc tycon = do+gen_Eq_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)+gen_Eq_binds loc tycon tycon_args = do -- See Note [Auxiliary binders] con2tag_RDR <- new_con2tag_rdr_name loc tycon return (method_binds con2tag_RDR, aux_binds con2tag_RDR) where- all_cons = tyConDataCons tycon+ all_cons = getPossibleDataCons tycon tycon_args (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons -- If there are ten or more (arbitrary number) nullary constructors,@@ -396,8 +398,8 @@ gtResult OrdGT = true_Expr -------------gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)-gen_Ord_binds loc tycon = do+gen_Ord_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)+gen_Ord_binds loc tycon tycon_args = do -- See Note [Auxiliary binders] con2tag_RDR <- new_con2tag_rdr_name loc tycon @@ -432,7 +434,7 @@ -- We want *zero-based* tags, because that's what -- con2Tag returns (generated by untag_Expr)! - tycon_data_cons = tyConDataCons tycon+ tycon_data_cons = getPossibleDataCons tycon tycon_args single_con_type = isSingleton tycon_data_cons (first_con : _) = tycon_data_cons (last_con : _) = reverse tycon_data_cons@@ -646,8 +648,8 @@ For @enumFromTo@ and @enumFromThenTo@, we use the default methods. -} -gen_Enum_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)-gen_Enum_binds loc tycon = do+gen_Enum_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)+gen_Enum_binds loc tycon _ = do -- See Note [Auxiliary binders] con2tag_RDR <- new_con2tag_rdr_name loc tycon tag2con_RDR <- new_tag2con_rdr_name loc tycon@@ -738,8 +740,8 @@ ************************************************************************ -} -gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)-gen_Bounded_binds loc tycon+gen_Bounded_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)+gen_Bounded_binds loc tycon _ | isEnumerationTyCon tycon = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag) | otherwise@@ -825,9 +827,9 @@ (p.~147). -} -gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)+gen_Ix_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff) -gen_Ix_binds loc tycon = do+gen_Ix_binds loc tycon _ = do -- See Note [Auxiliary binders] con2tag_RDR <- new_con2tag_rdr_name loc tycon tag2con_RDR <- new_tag2con_rdr_name loc tycon@@ -1028,10 +1030,10 @@ we want to be able to parse (Left 3) just fine. -} -gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon+gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff) -gen_Read_binds get_fixity loc tycon+gen_Read_binds get_fixity loc tycon _ = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag) where -----------------------------------------------------------------------@@ -1212,13 +1214,13 @@ -- the most tightly-binding operator -} -gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon+gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff) -gen_Show_binds get_fixity loc tycon+gen_Show_binds get_fixity loc tycon tycon_args = (unitBag shows_prec, emptyBag) where- data_cons = tyConDataCons tycon+ data_cons = getPossibleDataCons tycon tycon_args shows_prec = mkFunBindEC 2 loc showsPrec_RDR id (map pats_etc data_cons) comma_space = nlHsVar showCommaSpace_RDR @@ -1385,9 +1387,10 @@ gen_Data_binds :: SrcSpan -> TyCon -- For data families, this is the -- *representation* TyCon+ -> [Type] -> TcM (LHsBinds GhcPs, -- The method bindings BagDerivStuff) -- Auxiliary bindings-gen_Data_binds loc rep_tc+gen_Data_binds loc rep_tc _ = do { -- See Note [Auxiliary binders] dataT_RDR <- new_dataT_rdr_name loc rep_tc ; dataC_RDRs <- traverse (new_dataC_rdr_name loc) data_cons@@ -1616,17 +1619,17 @@ -} -gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)-gen_Lift_binds loc tycon = (listToBag [lift_bind, liftTyped_bind], emptyBag)+gen_Lift_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)+gen_Lift_binds loc tycon tycon_args = (listToBag [lift_bind, liftTyped_bind], emptyBag) where lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr) (map (pats_etc mk_exp) data_cons)- liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp pure_Expr)+ liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp unsafeCodeCoerce_Expr . nlHsApp pure_Expr) (map (pats_etc mk_texp) data_cons) mk_exp = ExpBr noExtField mk_texp = TExpBr noExtField- data_cons = tyConDataCons tycon+ data_cons = getPossibleDataCons tycon tycon_args pats_etc mk_bracket data_con = ([con_pat], lift_Expr)@@ -2461,17 +2464,18 @@ cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ] a_Expr, b_Expr, c_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr,- true_Expr, pure_Expr :: LHsExpr GhcPs-a_Expr = nlHsVar a_RDR-b_Expr = nlHsVar b_RDR-c_Expr = nlHsVar c_RDR-z_Expr = nlHsVar z_RDR-ltTag_Expr = nlHsVar ltTag_RDR-eqTag_Expr = nlHsVar eqTag_RDR-gtTag_Expr = nlHsVar gtTag_RDR-false_Expr = nlHsVar false_RDR-true_Expr = nlHsVar true_RDR-pure_Expr = nlHsVar pure_RDR+ true_Expr, pure_Expr, unsafeCodeCoerce_Expr :: LHsExpr GhcPs+a_Expr = nlHsVar a_RDR+b_Expr = nlHsVar b_RDR+c_Expr = nlHsVar c_RDR+z_Expr = nlHsVar z_RDR+ltTag_Expr = nlHsVar ltTag_RDR+eqTag_Expr = nlHsVar eqTag_RDR+gtTag_Expr = nlHsVar gtTag_RDR+false_Expr = nlHsVar false_RDR+true_Expr = nlHsVar true_RDR+pure_Expr = nlHsVar pure_RDR+unsafeCodeCoerce_Expr = nlHsVar unsafeCodeCoerce_RDR a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat GhcPs a_Pat = nlVarPat a_RDR@@ -2514,7 +2518,40 @@ uniq <- newUnique pure $ Exact $ mkSystemNameAt uniq (occ_fun (nameOccName parent)) loc +-- | @getPossibleDataCons tycon tycon_args@ returns the constructors of @tycon@+-- whose return types match when checked against @tycon_args@.+--+-- See Note [Filter out impossible GADT data constructors]+getPossibleDataCons :: TyCon -> [Type] -> [DataCon]+getPossibleDataCons tycon tycon_args = filter isPossible $ tyConDataCons tycon+ where+ isPossible = not . dataConCannotMatch (tyConInstArgTys tycon tycon_args) +-- | Given a type constructor @tycon@ of arity /n/ and a list of argument types+-- @tycon_args@ of length /m/,+--+-- @+-- tyConInstArgTys tycon tycon_args+-- @+--+-- returns+--+-- @+-- [tycon_arg_{1}, tycon_arg_{2}, ..., tycon_arg_{m}, extra_arg_{m+1}, ..., extra_arg_{n}]+-- @+--+-- where @extra_args@ are distinct type variables.+--+-- Examples:+--+-- * Given @tycon: Foo a b@ and @tycon_args: [Int, Bool]@, return @[Int, Bool]@.+--+-- * Given @tycon: Foo a b@ and @tycon_args: [Int]@, return @[Int, b]@.+tyConInstArgTys :: TyCon -> [Type] -> [Type]+tyConInstArgTys tycon tycon_args = chkAppend tycon_args $ map mkTyVarTy tycon_args_suffix+ where+ tycon_args_suffix = drop (length tycon_args) $ tyConTyVars tycon+ {- Note [Auxiliary binders] ~~~~~~~~~~~~~~~~~~~~~~~~@@ -2732,4 +2769,56 @@ (This is the case described in "Wrinkle: Reducing code duplication".) In situation (1), we can at least fall back on GHC's simplifier to pick up genAuxBinds' slack.++Note [Filter out impossible GADT data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Some stock-derivable classes will filter out impossible GADT data constructors,+to rule out problematic constructors when deriving instances. e.g.++```+data Foo a where+ X :: Foo Int+ Y :: (Bool -> Bool) -> Foo Bool+```++when deriving an instance on `Foo Int`, `Y` should be treated as if it didn't+exist in the first place. For instance, if we write++```+deriving instance Eq (Foo Int)+```++it should generate:++```+instance Eq (Foo Int) where+ X == X = True+```++Classes that filter constructors:++* Eq+* Ord+* Show+* Lift+* Functor+* Foldable+* Traversable++Classes that do not filter constructors:++* Enum: doesn't make sense for GADTs in the first place+* Bounded: only makes sense for GADTs with a single constructor+* Ix: only makes sense for GADTs with a single constructor+* Read: `Read a` returns `a` instead of consumes `a`, so filtering data+ constructors would make this function _more_ partial instead of less+* Data: derived implementations of gunfold rely on a constructor-indexing+ scheme that wouldn't work if certain constructors were filtered out+* Generic/Generic1: doesn't make sense for GADTs++Classes that do not currently filter constructors may do so in the future, if+there is a valid use-case and we have requirements for how they should work.++See #16341 and the T16341.hs test case. -}
compiler/GHC/Tc/Deriv/Infer.hs view
@@ -260,9 +260,7 @@ -- substitute each type variable with its counterpart in the derived -- instance. rep_tc_args lists each of these counterpart types in -- the same order as the type variables.- all_rep_tc_args- = rep_tc_args ++ map mkTyVarTy- (drop (length rep_tc_args) rep_tc_tvs)+ all_rep_tc_args = tyConInstArgTys rep_tc rep_tc_args -- Stupid constraints stupid_constraints
compiler/GHC/Tc/Deriv/Utils.hs view
@@ -218,8 +218,9 @@ -- instance, including what type constructor the last argument is -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@. , dsm_stock_gen_fn ::- SrcSpan -> TyCon- -> [Type]+ SrcSpan -> TyCon -- dit_rep_tc+ -> [Type] -- dit_rep_tc_args+ -> [Type] -- inst_tys -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]) -- ^ This function returns three things: --@@ -424,7 +425,7 @@ -- See @Note [Deriving strategies]@ in "GHC.Tc.Deriv". data OriginativeDerivStatus = CanDeriveStock -- Stock class, can derive- (SrcSpan -> TyCon -> [Type]+ (SrcSpan -> TyCon -> [Type] -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])) | StockClassError SDoc -- Stock class, but can't do it | CanDeriveAnyClass -- See Note [Deriving any class]@@ -563,6 +564,7 @@ :: Class -> Maybe (SrcSpan -> TyCon -> [Type]+ -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])) hasStockDeriving clas = assocMaybe gen_list (getUnique clas)@@ -571,6 +573,7 @@ :: [(Unique, SrcSpan -> TyCon -> [Type]+ -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))] gen_list = [ (eqClassKey, simpleM gen_Eq_binds) , (ordClassKey, simpleM gen_Ord_binds)@@ -587,25 +590,25 @@ , (genClassKey, generic (gen_Generic_binds Gen0)) , (gen1ClassKey, generic (gen_Generic_binds Gen1)) ] - simple gen_fn loc tc _- = let (binds, deriv_stuff) = gen_fn loc tc+ simple gen_fn loc tc tc_args _+ = let (binds, deriv_stuff) = gen_fn loc tc tc_args in return (binds, deriv_stuff, []) -- Like `simple`, but monadic. The only monadic thing that these functions -- do is allocate new Uniques, which are used for generating the names of -- auxiliary bindings. -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate.- simpleM gen_fn loc tc _- = do { (binds, deriv_stuff) <- gen_fn loc tc+ simpleM gen_fn loc tc tc_args _+ = do { (binds, deriv_stuff) <- gen_fn loc tc tc_args ; return (binds, deriv_stuff, []) } - read_or_show gen_fn loc tc _+ read_or_show gen_fn loc tc tc_args _ = do { fix_env <- getDataConFixityFun tc- ; let (binds, deriv_stuff) = gen_fn fix_env loc 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) } - generic gen_fn _ tc inst_tys+ generic gen_fn _ tc _ inst_tys = do { (binds, faminst) <- gen_fn tc inst_tys ; let field_names = all_field_names tc ; return (binds, unitBag (DerivFamInst faminst), field_names) }
compiler/GHC/Tc/Gen/Expr.hs view
@@ -123,12 +123,20 @@ ; tcPolyExprNC expr res_ty } tcPolyExprNC (L loc expr) res_ty- = setSrcSpan loc $+ = set_loc_and_ctxt loc expr $ do { traceTc "tcPolyExprNC" (ppr res_ty) ; (wrap, expr') <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty -> tcExpr expr res_ty ; return $ L loc (mkHsWrap wrap expr') } + where -- See Note [Rebindable syntax and HsExpansion), which describes+ -- the logic behind this location/context tweaking.+ set_loc_and_ctxt l e m = do+ inGenCode <- inGeneratedCode+ if inGenCode && not (isGeneratedSrcSpan l)+ then setSrcSpan l $ addExprCtxt (L l e) m+ else setSrcSpan l m+ --------------- tcInferSigma :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType) -- Used by tcRnExpr to implement GHCi :type@@ -188,7 +196,7 @@ -> TcM (LHsExpr GhcTc) tcLExpr expr res_ty- = addExprCtxt expr (tcLExprNC expr res_ty)+ = setSrcSpan (getLoc expr) $ addExprCtxt expr (tcLExprNC expr res_ty) tcLExprNC (L loc expr) res_ty = setSrcSpan loc $@@ -365,7 +373,7 @@ matchActualFunTysRho doc orig1 (Just (unLoc arg1)) 1 arg1_ty ; mult_wrap <- tcSubMult AppOrigin Many (scaledMult arg2_sigma)- -- See Note [tcSubMult's wrapper] in TcUnify.+ -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. -- -- When ($) becomes multiplicity-polymorphic, then the above check will -- need to go. But in the meantime, it would produce ill-typed@@ -589,35 +597,15 @@ match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody } -tcExpr (HsIf x NoSyntaxExprRn pred b1 b2) res_ty -- Ordinary 'if'+tcExpr (HsIf x pred b1 b2) res_ty = do { pred' <- tcLExpr pred (mkCheckExpType boolTy)- ; res_ty <- tauifyExpType res_ty- -- Just like Note [Case branches must never infer a non-tau type]- -- in GHC.Tc.Gen.Match (See #10619)- ; (u1,b1') <- tcCollectingUsage $ tcLExpr b1 res_ty ; (u2,b2') <- tcCollectingUsage $ tcLExpr b2 res_ty ; tcEmitBindingUsage (supUE u1 u2)- ; return (HsIf x NoSyntaxExprTc pred' b1' b2') }--tcExpr (HsIf x fun@(SyntaxExprRn {}) pred b1 b2) res_ty- = do { ((pred', b1', b2'), fun')- <- tcSyntaxOp IfOrigin fun [SynAny, SynAny, SynAny] res_ty $- \ [pred_ty, b1_ty, b2_ty] [pred_mult, b1_mult, b2_mult] ->- do { pred' <- tcScalingUsage pred_mult $ tcCheckPolyExpr pred pred_ty- ; b1' <- tcScalingUsage b1_mult $ tcCheckPolyExpr b1 b1_ty- ; b2' <- tcScalingUsage b2_mult $ tcCheckPolyExpr b2 b2_ty- ; return (pred', b1', b2') }- ; return (HsIf x fun' pred' b1' b2') }+ ; return (HsIf x pred' b1' b2') } tcExpr (HsMultiIf _ alts) res_ty- = do { res_ty <- if isSingleton alts- then return res_ty- else tauifyExpType res_ty- -- Just like GHC.Tc.Gen.Match- -- Note [Case branches must never infer a non-tau type]-- ; alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts+ = do { alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts ; res_ty <- readExpType res_ty ; return (HsMultiIf res_ty alts') } where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }@@ -1063,6 +1051,19 @@ {- ************************************************************************ * *+ Rebindable syntax+* *+************************************************************************+-}++-- See Note [Rebindable syntax and HsExpansion].+tcExpr (XExpr (HsExpanded a b)) t+ = fmap (XExpr . ExpansionExpr . HsExpanded a) $+ setSrcSpan generatedSrcSpan (tcExpr b t)++{-+************************************************************************+* * Catch-all * * ************************************************************************@@ -1081,7 +1082,6 @@ tcExprPrag :: HsPragE GhcRn -> HsPragE GhcTc tcExprPrag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann-tcExprPrag (HsPragCore x1 src lbl) = HsPragCore x1 src lbl tcExprPrag (HsPragTick x1 src info srcInfo) = HsPragTick x1 src info srcInfo
compiler/GHC/Tc/Gen/Foreign.hs view
@@ -6,6 +6,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-} -- | Typechecking @foreign@ declarations --@@ -57,6 +61,7 @@ import GHC.Tc.Utils.TcType import GHC.Builtin.Names import GHC.Driver.Session+import GHC.Driver.Backend import GHC.Utils.Outputable as Outputable import GHC.Platform import GHC.Types.SrcLoc@@ -67,13 +72,13 @@ import Control.Monad -- Defines a binding-isForeignImport :: LForeignDecl name -> Bool-isForeignImport (L _ (ForeignImport {})) = True+isForeignImport :: forall name. UnXRec name => LForeignDecl name -> Bool+isForeignImport (unXRec @name -> ForeignImport {}) = True isForeignImport _ = False -- Exports a binding-isForeignExport :: LForeignDecl name -> Bool-isForeignExport (L _ (ForeignExport {})) = True+isForeignExport :: forall name. UnXRec name => LForeignDecl name -> Bool+isForeignExport (unXRec @name -> ForeignExport {}) = True isForeignExport _ = False {-@@ -474,31 +479,31 @@ checkSafe = True noCheckSafe = False --- Checking a supported backend is in use--checkCOrAsmOrLlvm :: HscTarget -> Validity-checkCOrAsmOrLlvm HscC = IsValid-checkCOrAsmOrLlvm HscAsm = IsValid-checkCOrAsmOrLlvm HscLlvm = IsValid+-- | Checking a supported backend is in use+checkCOrAsmOrLlvm :: Backend -> Validity+checkCOrAsmOrLlvm ViaC = IsValid+checkCOrAsmOrLlvm NCG = IsValid+checkCOrAsmOrLlvm LLVM = IsValid checkCOrAsmOrLlvm _ = NotValid (text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)") -checkCOrAsmOrLlvmOrInterp :: HscTarget -> Validity-checkCOrAsmOrLlvmOrInterp HscC = IsValid-checkCOrAsmOrLlvmOrInterp HscAsm = IsValid-checkCOrAsmOrLlvmOrInterp HscLlvm = IsValid-checkCOrAsmOrLlvmOrInterp HscInterpreted = IsValid+-- | Checking a supported backend is in use+checkCOrAsmOrLlvmOrInterp :: Backend -> Validity+checkCOrAsmOrLlvmOrInterp ViaC = IsValid+checkCOrAsmOrLlvmOrInterp NCG = IsValid+checkCOrAsmOrLlvmOrInterp LLVM = IsValid+checkCOrAsmOrLlvmOrInterp Interpreter = IsValid checkCOrAsmOrLlvmOrInterp _ = NotValid (text "requires interpreted, unregisterised, llvm or native code generation") -checkCg :: (HscTarget -> Validity) -> TcM ()+checkCg :: (Backend -> Validity) -> TcM () checkCg check = do dflags <- getDynFlags- let target = hscTarget dflags- case target of- HscNothing -> return ()+ let bcknd = backend dflags+ case bcknd of+ NoBackend -> return () _ ->- case check target of+ case check bcknd of IsValid -> return () NotValid err -> addErrTc (text "Illegal foreign declaration:" <+> err)
compiler/GHC/Tc/Gen/HsType.hs view
@@ -862,11 +862,13 @@ -- See Note [Typechecking NHsCoreTys] tc_infer_hs_type _ (XHsType (NHsCoreTy ty)) = do env <- getLclEnv- let subst_prs = [ (nm, tv)+ -- Raw uniques since we go from NameEnv to TvSubstEnv.+ let subst_prs :: [(Unique, TcTyVar)]+ subst_prs = [ (getUnique nm, tv) | ATyVar nm tv <- nameEnvElts (tcl_env env) ] subst = mkTvSubst (mkInScopeSet $ mkVarSet $ map snd subst_prs)- (listToUFM $ map (liftSnd mkTyVarTy) subst_prs)+ (listToUFM_Directly $ map (liftSnd mkTyVarTy) subst_prs) ty' = substTy subst ty return (ty', tcTypeKind ty')
compiler/GHC/Tc/Gen/Match.hs view
@@ -164,80 +164,47 @@ match_ctxt = MC { mc_what = PatBindRhs, mc_body = tcBody } -{--************************************************************************+{- ********************************************************************* * *-\subsection{tcMatch}+ tcMatch * *-************************************************************************--Note [Case branches must never infer a non-tau type]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-- case ... of- ... -> \(x :: forall a. a -> a) -> x- ... -> \y -> y--Should that type-check? The problem is that, if we check the second branch-first, then we'll get a type (b -> b) for the branches, which won't unify-with the polytype in the first branch. If we check the first branch first,-then everything is OK. This order-dependency is terrible. So we want only-proper tau-types in branches (unless a sigma-type is pushed down).-This is what expTypeToType ensures: it replaces an Infer with a fresh-tau-type.--An even trickier case looks like-- f x True = x undefined- f x False = x ()--Here, we see that the arguments must also be non-Infer. Thus, we must-use expTypeToType on the output of matchExpectedFunTys, not the input.--But we make a special case for a one-branch case. This is so that-- f = \(x :: forall a. a -> a) -> x--still gets assigned a polytype.--}+********************************************************************* -} --- | When the MatchGroup has multiple RHSs, convert an Infer ExpType in the--- expected type into TauTvs.--- See Note [Case branches must never infer a non-tau type]-tauifyMultipleMatches :: [LMatch id body]- -> [Scaled ExpType] -> TcM [Scaled ExpType]-tauifyMultipleMatches group exp_tys- | isSingletonMatchGroup group = return exp_tys- | otherwise = mapM (\(Scaled m t) ->- fmap (Scaled m) (tauifyExpType t)) exp_tys- -- NB: In the empty-match case, this ensures we fill in the ExpType+data TcMatchCtxt body -- c.f. TcStmtCtxt, also in this module+ = MC { mc_what :: HsMatchContext GhcRn, -- What kind of thing this is+ mc_body :: Located (body GhcRn) -- Type checker for a body of+ -- an alternative+ -> ExpRhoType+ -> TcM (Located (body GhcTc)) } -- | Type-check a MatchGroup. tcMatches :: (Outputable (body GhcRn)) => TcMatchCtxt body -> [Scaled ExpSigmaType] -- Expected pattern types- -> ExpRhoType -- Expected result-type of the Match.+ -> ExpRhoType -- Expected result-type of the Match. -> MatchGroup GhcRn (Located (body GhcRn)) -> TcM (MatchGroup GhcTc (Located (body GhcTc))) -data TcMatchCtxt body -- c.f. TcStmtCtxt, also in this module- = MC { mc_what :: HsMatchContext GhcRn, -- What kind of thing this is- mc_body :: Located (body GhcRn) -- Type checker for a body of- -- an alternative- -> ExpRhoType- -> TcM (Located (body GhcTc)) } tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches , mg_origin = origin })- = do { (Scaled _ rhs_ty):pat_tys <- tauifyMultipleMatches matches ((Scaled One rhs_ty):pat_tys) -- return type has implicitly multiplicity 1, it doesn't matter all that much in this case since it isn't used and is eliminated immediately.- -- See Note [Case branches must never infer a non-tau type]+ | null matches -- Deal with case e of {}+ -- Since there are no branches, no one else will fill in rhs_ty+ -- when in inference mode, so we must do it ourselves,+ -- here, using expTypeToType+ = do { tcEmitBindingUsage bottomUE+ ; pat_tys <- mapM scaledExpTypeToType pat_tys+ ; rhs_ty <- expTypeToType rhs_ty+ ; return (MG { mg_alts = L l []+ , mg_ext = MatchGroupTc pat_tys rhs_ty+ , mg_origin = origin }) } - ; umatches <- mapM (tcCollectingUsage . tcMatch ctxt pat_tys rhs_ty) matches+ | otherwise+ = do { umatches <- mapM (tcCollectingUsage . tcMatch ctxt pat_tys rhs_ty) matches ; let (usages,matches') = unzip umatches ; tcEmitBindingUsage $ supUEs usages- ; pat_tys <- mapM (\(Scaled m t) -> fmap (Scaled m) (readExpType t)) pat_tys+ ; pat_tys <- mapM readScaledExpType pat_tys ; rhs_ty <- readExpType rhs_ty- ; return (MG { mg_alts = L l matches'- , mg_ext = MatchGroupTc pat_tys rhs_ty+ ; return (MG { mg_alts = L l matches'+ , mg_ext = MatchGroupTc pat_tys rhs_ty , mg_origin = origin }) } -------------
compiler/GHC/Tc/Gen/Pat.hs view
@@ -220,8 +220,9 @@ = do { (co, bndr_ty) <- case scaledThing exp_pat_ty of Check pat_ty -> promoteTcType bind_lvl pat_ty Infer infer_res -> ASSERT( bind_lvl == ir_lvl infer_res )- -- If we were under a constructor that bumped- -- the level, we'd be in checking mode+ -- If we were under a constructor that bumped the+ -- level, we'd be in checking mode (see tcConArg)+ -- hence this assertion do { bndr_ty <- inferResultToType infer_res ; return (mkTcNomReflCo bndr_ty, bndr_ty) } ; let bndr_mult = scaledMult exp_pat_ty@@ -342,7 +343,7 @@ (zipEqual "tc_lpats" pats tys) ----------------------- See Note [tcSubMult's wrapper] in TcUnify.+-- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. checkManyPattern :: Scaled a -> TcM HsWrapper checkManyPattern pat_ty = tcSubMult NonLinearPatternOrigin Many (scaledMult pat_ty) @@ -357,7 +358,7 @@ { (wrap, id) <- tcPatBndr penv name pat_ty ; (res, mult_wrap) <- tcCheckUsage name (scaledMult pat_ty) $ tcExtendIdEnv1 name id thing_inside- -- See Note [tcSubMult's wrapper] in TcUnify.+ -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. ; pat_ty <- readExpType (scaledThing pat_ty) ; return (mkHsWrapPat (wrap <.> mult_wrap) (VarPat x (L l id)) pat_ty, res) } @@ -371,7 +372,7 @@ LazyPat x pat -> do { mult_wrap <- checkManyPattern pat_ty- -- See Note [tcSubMult's wrapper] in TcUnify.+ -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. ; (pat', (res, pat_ct)) <- tc_lpat pat_ty (makeLazy penv) pat $ captureConstraints thing_inside@@ -389,14 +390,14 @@ WildPat _ -> do { mult_wrap <- checkManyPattern pat_ty- -- See Note [tcSubMult's wrapper] in TcUnify.+ -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. ; res <- thing_inside ; pat_ty <- expTypeToType (scaledThing pat_ty) ; return (mkHsWrapPat mult_wrap (WildPat pat_ty) pat_ty, res) } AsPat x (L nm_loc name) pat -> do { mult_wrap <- checkManyPattern pat_ty- -- See Note [tcSubMult's wrapper] in TcUnify.+ -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. ; (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty) ; (pat', res) <- tcExtendIdEnv1 name bndr_id $ tc_lpat (pat_ty `scaledSet`(mkCheckExpType $ idType bndr_id))@@ -413,7 +414,7 @@ ViewPat _ expr pat -> do { mult_wrap <- checkManyPattern pat_ty- -- See Note [tcSubMult's wrapper] in TcUnify.+ -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. -- -- It should be possible to have view patterns at linear (or otherwise -- non-Many) multiplicity. But it is not clear at the moment what@@ -585,7 +586,7 @@ -- When there is no negation, neg_lit_ty and lit_ty are the same NPat _ (L l over_lit) mb_neg eq -> do { mult_wrap <- checkManyPattern pat_ty- -- See Note [tcSubMult's wrapper] in TcUnify.+ -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. -- -- It may be possible to refine linear pattern so that they work in -- linear environments. But it is not clear how useful this is.@@ -629,11 +630,6 @@ lit1_ty and lit2_ty could conceivably be different. var_ty is the type inferred for x, the variable in the pattern. -If the pushed-down pattern type isn't a tau-type, the two pat_ty's above-could conceivably be different specializations. But this is very much-like the situation in Note [Case branches must be taus] in GHC.Tc.Gen.Match.-So we tauify the pat_ty before proceeding.- Note that we need to type-check the literal twice, because it is used twice, and may be used at different types. The second HsOverLit stored in the AST is used for the subtraction operation.@@ -643,16 +639,16 @@ NPlusKPat _ (L nm_loc name) (L loc lit) _ ge minus -> do { mult_wrap <- checkManyPattern pat_ty- -- See Note [tcSubMult's wrapper] in TcUnify.- ; pat_ty <- expTypeToType (scaledThing pat_ty)- ; let orig = LiteralOrigin lit+ -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.+ ; let pat_exp_ty = scaledThing pat_ty+ orig = LiteralOrigin lit ; (lit1', ge')- <- tcSyntaxOp orig ge [synKnownType pat_ty, SynRho]+ <- tcSyntaxOp orig ge [SynType pat_exp_ty, SynRho] (mkCheckExpType boolTy) $ \ [lit1_ty] _ -> newOverloadedLit lit (mkCheckExpType lit1_ty) ; ((lit2', minus_wrap, bndr_id), minus')- <- tcSyntaxOpGen orig minus [synKnownType pat_ty, SynRho] SynAny $+ <- tcSyntaxOpGen orig minus [SynType pat_exp_ty, SynRho] SynAny $ \ [lit2_ty, var_ty] _ -> do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty) ; (wrap, bndr_id) <- setSrcSpan nm_loc $@@ -662,6 +658,7 @@ -- minus_wrap is applicable to minus' ; return (lit2', wrap, bndr_id) } + ; pat_ty <- readExpType pat_exp_ty -- The Report says that n+k patterns must be in Integral -- but it's silly to insist on this in the RebindableSyntax case ; unlessM (xoptM LangExt.RebindableSyntax) $@@ -984,7 +981,7 @@ req_theta' = substTheta tenv req_theta ; mult_wrap <- checkManyPattern pat_ty- -- See Note [tcSubMult's wrapper] in TcUnify.+ -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. ; wrap <- tc_sub_type penv (scaledThing pat_ty) ty' ; traceTc "tcPatSynPat" (ppr pat_syn $$
compiler/GHC/Tc/Gen/Sig.hs view
@@ -36,13 +36,14 @@ import GHC.Tc.Utils.TcMType import GHC.Tc.Validity ( checkValidType ) import GHC.Tc.Utils.Unify( tcSkolemise, unifyType )-import GHC.Tc.Utils.Instantiate( topInstantiate )+import GHC.Tc.Utils.Instantiate( topInstantiate, tcInstTypeBndrs ) import GHC.Tc.Utils.Env( tcLookupId ) import GHC.Tc.Types.Evidence( HsWrapper, (<.>) ) import GHC.Core.Type ( mkTyVarBinders ) import GHC.Core.Multiplicity import GHC.Driver.Session+import GHC.Driver.Backend import GHC.Types.Var ( TyVar, Specificity(..), tyVarKind, binderVars ) import GHC.Types.Id ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId ) import GHC.Builtin.Names( mkUnboundName )@@ -488,7 +489,7 @@ -- Instantiate a type signature; only used with plan InferGen tcInstSig sig@(CompleteSig { sig_bndr = poly_id, sig_loc = loc }) = setSrcSpan loc $ -- Set the binding site of the tyvars- do { (tv_prs, theta, tau) <- tcInstTypeBndrs newMetaTyVarTyVars poly_id+ do { (tv_prs, theta, tau) <- tcInstTypeBndrs poly_id -- See Note [Pattern bindings and complete signatures] ; return (TISI { sig_inst_sig = sig@@ -817,10 +818,10 @@ -- we don't want complaints about lack of INLINABLE pragmas not_specialising dflags | not (gopt Opt_Specialise dflags) = True- | otherwise = case hscTarget dflags of- HscNothing -> True- HscInterpreted -> True- _other -> False+ | otherwise = case backend dflags of+ NoBackend -> True+ Interpreter -> True+ _other -> False tcImpSpec :: (Name, Sig GhcRn) -> TcM [TcSpecPrag] tcImpSpec (name, prag)
compiler/GHC/Tc/Gen/Splice.hs view
@@ -197,7 +197,7 @@ ; let rep = getRuntimeRep expr_ty ; meta_ty <- tcTExpTy m_var expr_ty ; ps' <- readMutVar ps_ref- ; texpco <- tcLookupId unsafeTExpCoerceName+ ; texpco <- tcLookupId unsafeCodeCoerceName ; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr") rn_expr (unLoc (mkHsApp (mkLHsWrap (applyQuoteWrapper wrapper)@@ -303,9 +303,9 @@ tcTExpTy :: TcType -> TcType -> TcM TcType tcTExpTy m_ty exp_ty = do { unless (isTauTy exp_ty) $ addErr (err_msg exp_ty)- ; texp <- tcLookupTyCon tExpTyConName+ ; codeCon <- tcLookupTyCon codeTyConName ; let rep = getRuntimeRep exp_ty- ; return (mkAppTy m_ty (mkTyConApp texp [rep, exp_ty])) }+ ; return (mkTyConApp codeCon [rep, m_ty, exp_ty]) } where err_msg ty = vcat [ text "Illegal polytype:" <+> ppr ty@@ -620,10 +620,10 @@ ; expr' <- setStage pop_stage $ setConstraintVar lie_var $ tcCheckMonoExpr expr meta_exp_ty- ; untypeq <- tcLookupId unTypeQName+ ; untype_code <- tcLookupId unTypeCodeName ; let expr'' = mkHsApp (mkLHsWrap (applyQuoteWrapper q)- (nlHsTyApp untypeq [rep, res_ty])) expr'+ (nlHsTyApp untype_code [rep, res_ty])) expr' ; ps <- readMutVar ps_var ; writeMutVar ps_var (PendingTcSplice splice_name expr'' : ps)
compiler/GHC/Tc/Instance/Class.hs view
@@ -16,6 +16,7 @@ import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType+import GHC.Tc.Utils.Instantiate( tcInstType ) import GHC.Tc.Instance.Typeable import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Evidence@@ -66,8 +67,8 @@ } isNotAssociated :: AssocInstInfo -> Bool-isNotAssociated NotAssociated = True-isNotAssociated (InClsInst {}) = False+isNotAssociated (NotAssociated {}) = True+isNotAssociated (InClsInst {}) = False {- *******************************************************************
compiler/GHC/Tc/Instance/Family.hs view
@@ -21,6 +21,7 @@ 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@@ -35,7 +36,6 @@ import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs import GHC.Core.TyCo.Ppr ( pprWithExplicitKindsWhen )-import GHC.Tc.Utils.TcMType import GHC.Types.Name import GHC.Utils.Panic import GHC.Types.Var.Set
compiler/GHC/Tc/Module.hs view
@@ -206,7 +206,7 @@ tcRnModuleTcRnM hsc_env mod_sum (HsParsedModule { hpm_module =- (L loc (HsModule maybe_mod export_ies+ (L loc (HsModule _ maybe_mod export_ies import_decls local_decls mod_deprec maybe_doc_hdr)), hpm_src_files = src_files@@ -301,7 +301,7 @@ -- Do this /after/ typeinference, so that when reporting -- a function with no type signature we can give the -- inferred type- reportUnusedNames tcg_env+ reportUnusedNames tcg_env hsc_src ; -- add extra source files to tcg_dependent_files addDependentFiles src_files ; tcg_env <- runTypecheckerPlugin mod_sum hsc_env tcg_env@@ -2973,8 +2973,8 @@ = ppr_things "DATA CONSTRUCTORS" ppr_dc wanted_dcs -- The filter gets rid of class data constructors where- ppr_dc dc = sdocWithDynFlags (\dflags ->- ppr dc <+> dcolon <+> ppr (dataConDisplayType dflags dc))+ ppr_dc dc = sdocOption sdocLinearTypes (\show_linear_types ->+ ppr dc <+> dcolon <+> ppr (dataConDisplayType show_linear_types dc)) all_dcs = typeEnvDataCons type_env wanted_dcs | debug = all_dcs | otherwise = filterOut is_cls_dc all_dcs
compiler/GHC/Tc/Solver/Flatten.hs view
@@ -954,8 +954,11 @@ Note [flatten_exact_fam_app_fully performance] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--The refactor of GRefl seems to cause performance trouble for T9872x: the allocation of flatten_exact_fam_app_fully_performance increased. See note [Generalized reflexive coercion] in GHC.Core.TyCo.Rep for more information about GRefl and #15192 for the current state.+The refactor of GRefl seems to cause performance trouble for T9872x:+the allocation of flatten_exact_fam_app_fully_performance+increased. See note [Generalized reflexive coercion] in+GHC.Core.TyCo.Rep for more information about GRefl and #15192 for the+current state. The explicit pattern match in homogenise_result helps with T9872a, b, c.
compiler/GHC/Tc/Solver/Monad.hs view
@@ -2420,7 +2420,7 @@ -} -type TcAppMap a = UniqDFM (ListMap LooseTypeMap a)+type TcAppMap a = UniqDFM Unique (ListMap LooseTypeMap a) -- Indexed by tycon then the arg types, using "loose" matching, where -- we don't require kind equality. This allows, for example, (a |> co) -- to match (a).@@ -2539,7 +2539,7 @@ findDictsByClass :: DictMap a -> Class -> Bag a findDictsByClass m cls- | Just tm <- lookupUDFM m cls = foldTM consBag tm emptyBag+ | Just tm <- lookupUDFM_Directly m (getUnique cls) = foldTM consBag tm emptyBag | otherwise = emptyBag delDict :: DictMap a -> Class -> [Type] -> DictMap a@@ -2550,7 +2550,7 @@ addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct addDictsByClass m cls items- = addToUDFM m cls (foldr add emptyTM items)+ = addToUDFM_Directly m (getUnique cls) (foldr add emptyTM items) where add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm add ct _ = pprPanic "addDictsByClass" (ppr ct)@@ -2600,8 +2600,8 @@ -- We use this to check for derived interactions with built-in type-function -- constructors. findFunEqsByTyCon m tc- | Just tm <- lookupUDFM m tc = foldTM (:) tm []- | otherwise = []+ | Just tm <- lookupUDFM m (getUnique tc) = foldTM (:) tm []+ | otherwise = [] foldFunEqs :: (a -> b -> b) -> FunEqMap a -> b -> b foldFunEqs = foldTcAppMap@@ -2632,17 +2632,17 @@ delFunEq m tc tys = delTcApp m (getUnique tc) tys -------------------------------type ExactFunEqMap a = UniqFM (ListMap TypeMap a)+type ExactFunEqMap a = UniqFM TyCon (ListMap TypeMap a) emptyExactFunEqs :: ExactFunEqMap a emptyExactFunEqs = emptyUFM findExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> Maybe a-findExactFunEq m tc tys = do { tys_map <- lookupUFM m (getUnique tc)+findExactFunEq m tc tys = do { tys_map <- lookupUFM m tc ; lookupTM tys tys_map } insertExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> a -> ExactFunEqMap a-insertExactFunEq m tc tys val = alterUFM alter_tm m (getUnique tc)+insertExactFunEq m tc tys val = alterUFM alter_tm m tc where alter_tm mb_tm = Just (insertTM tys val (mb_tm `orElse` emptyTM)) {-
compiler/GHC/Tc/TyCl.hs view
@@ -2833,8 +2833,17 @@ , text "feqn_pats =" <+> ppr hs_pats ]) -- this check reports an arity error instead of a kind error; easier for user ; let vis_pats = numVisibleArgs hs_pats++ -- First, check if we're dealing with a closed type family equation, and+ -- if so, ensure that each equation's type constructor is for the right+ -- type family. E.g. barf on+ -- type family F a where { G Int = Bool }+ ; checkTc (tc_fam_tc_name == eqn_tc_name) $+ wrongTyFamName tc_fam_tc_name eqn_tc_name+ ; checkTc (vis_pats == vis_arity) $ wrongNumberOfParmsErr vis_arity+ ; discardResult $ bindImplicitTKBndrs_Q_Tv imp_vars $ bindExplicitTKBndrs_Q_Tv AnyKind (mb_expl_bndrs `orElse` []) $@@ -2848,7 +2857,7 @@ } where vis_arity = length (tyConVisibleTyVars tc_fam_tc)-+ tc_fam_tc_name = getName tc_fam_tc -------------------------- tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn@@ -2858,22 +2867,22 @@ tcTyFamInstEqn fam_tc mb_clsinfo (L loc (HsIB { hsib_ext = imp_vars- , hsib_body = FamEqn { feqn_tycon = L _ eqn_tc_name- , feqn_bndrs = mb_expl_bndrs+ , hsib_body = FamEqn { feqn_bndrs = mb_expl_bndrs , feqn_pats = hs_pats , feqn_rhs = hs_rhs_ty }}))- = ASSERT( getName fam_tc == eqn_tc_name )- setSrcSpan loc $+ = setSrcSpan loc $ do { traceTc "tcTyFamInstEqn" $ vcat [ ppr fam_tc <+> ppr hs_pats , text "fam tc bndrs" <+> pprTyVars (tyConTyVars fam_tc) , case mb_clsinfo of- NotAssociated -> empty+ NotAssociated {} -> empty InClsInst { ai_class = cls } -> text "class" <+> ppr cls <+> pprTyVars (classTyVars cls) ] -- First, check the arity of visible arguments -- If we wait until validity checking, we'll get kind errors -- below when an arity error will be much easier to understand.+ -- Note that for closed type families, kcTyFamInstEqn has already+ -- checked the arity previously. ; let vis_arity = length (tyConVisibleTyVars fam_tc) vis_pats = numVisibleArgs hs_pats ; checkTc (vis_pats == vis_arity) $@@ -4127,7 +4136,8 @@ = hang herald 2 (text "on the" <+> speakNth n <+> text "argument of" <+> quotes (ppr con)) - data_con_display_type = dataConDisplayType dflags con+ show_linear_types = xopt LangExt.LinearTypes dflags+ data_con_display_type = dataConDisplayType show_linear_types con ------------------------------- checkNewDataCon :: DataCon -> TcM ()@@ -4143,10 +4153,10 @@ [ text "A newtype cannot have an unlifted argument type" , text "Perhaps you intended to use UnliftedNewtypes" ]- ; dflags <- getDynFlags+ ; show_linear_types <- xopt LangExt.LinearTypes <$> getDynFlags ; let check_con what msg =- checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConDisplayType dflags con))+ checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con)) ; checkTc (ok_mult (scaledMult arg_ty1)) $ text "A newtype constructor must be linear"@@ -4834,10 +4844,10 @@ badExistential :: DataCon -> SDoc badExistential con- = sdocWithDynFlags (\dflags ->+ = sdocOption sdocLinearTypes (\show_linear_types -> hang (text "Data constructor" <+> quotes (ppr con) <+> text "has existential type variables, a context, or a specialised result type")- 2 (vcat [ ppr con <+> dcolon <+> ppr (dataConDisplayType dflags con)+ 2 (vcat [ ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con) , parens $ text "Enable ExistentialQuantification or GADTs to allow this" ])) badStupidTheta :: Name -> SDoc@@ -4918,6 +4928,12 @@ incoherentRoles = (text "Roles other than" <+> quotes (text "nominal") <+> text "for class parameters can lead to incoherence.") $$ (text "Use IncoherentInstances to allow this; bad role found")++wrongTyFamName :: Name -> Name -> SDoc+wrongTyFamName fam_tc_name eqn_tc_name+ = hang (text "Mismatched type name in type family instance.")+ 2 (vcat [ text "Expected:" <+> ppr fam_tc_name+ , text " Actual:" <+> ppr eqn_tc_name ]) addTyConCtxt :: TyCon -> TcM a -> TcM a addTyConCtxt tc = addTyConFlavCtxt name flav
compiler/GHC/Tc/TyCl/Build.hs view
@@ -21,8 +21,7 @@ import GHC.Iface.Env import GHC.Core.FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom )-import GHC.Builtin.Types( isCTupleTyConName )-import GHC.Builtin.Types.Prim ( voidPrimTy )+import GHC.Builtin.Types( isCTupleTyConName, unboxedUnitTy ) import GHC.Core.DataCon import GHC.Core.PatSyn import GHC.Types.Var@@ -209,11 +208,11 @@ subst = zipTvSubst (univ_tvs1 ++ ex_tvs1) (mkTyVarTys (binderVars (univ_tvs ++ ex_tvs))) - -- For a nullary pattern synonym we add a single void argument to the+ -- For a nullary pattern synonym we add a single (# #) argument to the -- matcher to preserve laziness in the case of unlifted types. -- See #12746 compareArgTys :: [Type] -> [Type] -> Bool- compareArgTys [] [x] = x `eqType` voidPrimTy+ compareArgTys [] [x] = x `eqType` unboxedUnitTy compareArgTys arg_tys matcher_arg_tys = arg_tys `eqTypes` matcher_arg_tys
compiler/GHC/Tc/TyCl/Class.hs view
@@ -31,11 +31,12 @@ import GHC.Prelude import GHC.Hs-import GHC.Tc.Utils.Env import GHC.Tc.Gen.Sig import GHC.Tc.Types.Evidence ( idHsWrapper ) import GHC.Tc.Gen.Bind+import GHC.Tc.Utils.Env import GHC.Tc.Utils.Unify+import GHC.Tc.Utils.Instantiate( tcSuperSkolTyVars ) import GHC.Tc.Gen.HsType import GHC.Tc.Utils.TcMType import GHC.Core.Type ( piResultTys )
compiler/GHC/Tc/TyCl/PatSyn.hs view
@@ -698,12 +698,12 @@ res_ty = mkTyVarTy res_tv is_unlifted = null args && null prov_dicts (cont_args, cont_arg_tys)- | is_unlifted = ([nlHsVar voidPrimId], [voidPrimTy])+ | is_unlifted = ([nlHsVar voidPrimId], [unboxedUnitTy]) | otherwise = (args, arg_tys) cont_ty = mkInfSigmaTy ex_tvs prov_theta $ mkVisFunTysMany cont_arg_tys res_ty - fail_ty = mkVisFunTyMany voidPrimTy res_ty+ fail_ty = mkVisFunTyMany unboxedUnitTy res_ty ; matcher_name <- newImplicitBinder name mkMatcherOcc ; scrutinee <- newSysLocalId (fsLit "scrut") Many pat_ty@@ -905,7 +905,7 @@ add_void :: Bool -> Type -> Type add_void need_dummy_arg ty- | need_dummy_arg = mkVisFunTyMany voidPrimTy ty+ | need_dummy_arg = mkVisFunTyMany unboxedUnitTy ty | otherwise = ty tcPatToExpr :: Name -> [Located Name] -> LPat GhcRn
compiler/GHC/Tc/Utils/Env.hs view
@@ -628,7 +628,8 @@ -- | @tcCheckUsage name mult thing_inside@ runs @thing_inside@, checks that the -- usage of @name@ is a submultiplicity of @mult@, and removes @name@ from the--- usage environment. See also Note [tcSubMult's wrapper] in TcUnify.+-- usage environment. See also Note [Wrapper returned from tcSubMult] in+-- GHC.Tc.Utils.Unify, which applies to the wrapper returned from this function. tcCheckUsage :: Name -> Mult -> TcM a -> TcM (a, HsWrapper) tcCheckUsage name id_mult thing_inside = do { (local_usage, result) <- tcCollectingUsage thing_inside
compiler/GHC/Tc/Utils/Instantiate.hs view
@@ -16,6 +16,12 @@ instCall, instDFunType, instStupidTheta, instTyVarsWith, newWanted, newWanteds, + tcInstType, tcInstTypeBndrs,+ tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarsAt,+ tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX,++ freshenTyVarBndrs, freshenCoVarBndrsX,+ tcInstInvisibleTyBindersN, tcInstInvisibleTyBinders, tcInstInvisibleTyBinder, newOverloadedLit, mkOverLit,@@ -63,7 +69,7 @@ import GHC.Core( Expr(..) ) -- For the Coercion constructor import GHC.Types.Id import GHC.Types.Name-import GHC.Types.Var ( EvVar, tyVarName, VarBndr(..) )+import GHC.Types.Var import GHC.Core.DataCon import GHC.Types.Var.Env import GHC.Builtin.Names@@ -74,7 +80,7 @@ import GHC.Types.Basic ( TypeOrKind(..) ) import qualified GHC.LanguageExtensions as LangExt -import Data.List ( sortBy )+import Data.List ( sortBy, mapAccumL ) import Control.Monad( unless ) import Data.Function ( on ) @@ -451,15 +457,192 @@ mkTyConApp (promoteDataCon eqDataCon) [k, ty1, ty2, mkCoercionTy co] where k = tcTypeKind ty1 -{--************************************************************************+{- ********************************************************************* * *- Literals+ SkolemTvs (immutable) * *-************************************************************************+********************************************************************* -} +tcInstType :: ([TyVar] -> TcM (TCvSubst, [TcTyVar]))+ -- ^ How to instantiate the type variables+ -> Id -- ^ Type to instantiate+ -> TcM ([(Name, TcTyVar)], TcThetaType, TcType) -- ^ Result+ -- (type vars, preds (incl equalities), rho)+tcInstType inst_tyvars id+ | null tyvars -- There may be overloading despite no type variables;+ -- (?x :: Int) => Int -> Int+ = return ([], theta, tau)+ | otherwise+ = do { (subst, tyvars') <- inst_tyvars tyvars+ ; let tv_prs = map tyVarName tyvars `zip` tyvars'+ subst' = extendTCvInScopeSet subst (tyCoVarsOfType rho)+ ; return (tv_prs, substTheta subst' theta, substTy subst' tau) }+ where+ (tyvars, rho) = tcSplitForAllTys (idType id)+ (theta, tau) = tcSplitPhiTy rho++tcInstTypeBndrs :: Id -> TcM ([(Name, InvisTVBinder)], TcThetaType, TcType)+ -- (type vars, preds (incl equalities), rho)+-- Instantiate the binders of a type signature with TyVarTvs+tcInstTypeBndrs id+ | null tyvars -- There may be overloading despite no type variables;+ -- (?x :: Int) => Int -> Int+ = return ([], theta, tau)+ | otherwise+ = do { (subst, tyvars') <- mapAccumLM inst_invis_bndr emptyTCvSubst tyvars+ ; let tv_prs = map (tyVarName . binderVar) tyvars `zip` tyvars'+ subst' = extendTCvInScopeSet subst (tyCoVarsOfType rho)+ ; return (tv_prs, substTheta subst' theta, substTy subst' tau) }+ where+ (tyvars, rho) = splitForAllTysInvis (idType id)+ (theta, tau) = tcSplitPhiTy rho++ inst_invis_bndr :: TCvSubst -> InvisTVBinder+ -> TcM (TCvSubst, InvisTVBinder)+ inst_invis_bndr subst (Bndr tv spec)+ = do { (subst', tv') <- newMetaTyVarTyVarX subst tv+ ; return (subst', Bndr tv' spec) }++tcSkolDFunType :: DFunId -> TcM ([TcTyVar], TcThetaType, TcType)+-- Instantiate a type signature with skolem constants.+-- We could give them fresh names, but no need to do so+tcSkolDFunType dfun+ = do { (tv_prs, theta, tau) <- tcInstType tcInstSuperSkolTyVars dfun+ ; return (map snd tv_prs, theta, tau) }++tcSuperSkolTyVars :: [TyVar] -> (TCvSubst, [TcTyVar])+-- Make skolem constants, but do *not* give them new names, as above+-- Moreover, make them "super skolems"; see comments with superSkolemTv+-- see Note [Kind substitution when instantiating]+-- Precondition: tyvars should be ordered by scoping+tcSuperSkolTyVars = mapAccumL tcSuperSkolTyVar emptyTCvSubst++tcSuperSkolTyVar :: TCvSubst -> TyVar -> (TCvSubst, TcTyVar)+tcSuperSkolTyVar subst tv+ = (extendTvSubstWithClone subst tv new_tv, new_tv)+ where+ kind = substTyUnchecked subst (tyVarKind tv)+ new_tv = mkTcTyVar (tyVarName tv) kind superSkolemTv++-- | Given a list of @['TyVar']@, skolemize the type variables,+-- returning a substitution mapping the original tyvars to the+-- skolems, and the list of newly bound skolems.+tcInstSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])+-- See Note [Skolemising type variables]+tcInstSkolTyVars = tcInstSkolTyVarsX emptyTCvSubst++tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])+-- See Note [Skolemising type variables]+tcInstSkolTyVarsX = tcInstSkolTyVarsPushLevel False++tcInstSuperSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])+-- See Note [Skolemising type variables]+tcInstSuperSkolTyVars = tcInstSuperSkolTyVarsX emptyTCvSubst++tcInstSuperSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])+-- See Note [Skolemising type variables]+tcInstSuperSkolTyVarsX subst = tcInstSkolTyVarsPushLevel True subst++tcInstSkolTyVarsPushLevel :: Bool -> TCvSubst -> [TyVar]+ -> TcM (TCvSubst, [TcTyVar])+-- Skolemise one level deeper, hence pushTcLevel+-- See Note [Skolemising type variables]+tcInstSkolTyVarsPushLevel overlappable subst tvs+ = do { tc_lvl <- getTcLevel+ ; let pushed_lvl = pushTcLevel tc_lvl+ ; tcInstSkolTyVarsAt pushed_lvl overlappable subst tvs }++tcInstSkolTyVarsAt :: TcLevel -> Bool+ -> TCvSubst -> [TyVar]+ -> TcM (TCvSubst, [TcTyVar])+tcInstSkolTyVarsAt lvl overlappable subst tvs+ = freshenTyCoVarsX new_skol_tv subst tvs+ where+ details = SkolemTv lvl overlappable+ new_skol_tv name kind = mkTcTyVar name kind details++------------------+freshenTyVarBndrs :: [TyVar] -> TcM (TCvSubst, [TyVar])+-- ^ Give fresh uniques to a bunch of TyVars, but they stay+-- as TyVars, rather than becoming TcTyVars+-- Used in 'GHC.Tc.Instance.Family.newFamInst', and 'GHC.Tc.Utils.Instantiate.newClsInst'+freshenTyVarBndrs = freshenTyCoVars mkTyVar++freshenCoVarBndrsX :: TCvSubst -> [CoVar] -> TcM (TCvSubst, [CoVar])+-- ^ Give fresh uniques to a bunch of CoVars+-- Used in "GHC.Tc.Instance.Family.newFamInst"+freshenCoVarBndrsX subst = freshenTyCoVarsX mkCoVar subst++------------------+freshenTyCoVars :: (Name -> Kind -> TyCoVar)+ -> [TyVar] -> TcM (TCvSubst, [TyCoVar])+freshenTyCoVars mk_tcv = freshenTyCoVarsX mk_tcv emptyTCvSubst++freshenTyCoVarsX :: (Name -> Kind -> TyCoVar)+ -> TCvSubst -> [TyCoVar]+ -> TcM (TCvSubst, [TyCoVar])+freshenTyCoVarsX mk_tcv = mapAccumLM (freshenTyCoVarX mk_tcv)++freshenTyCoVarX :: (Name -> Kind -> TyCoVar)+ -> TCvSubst -> TyCoVar -> TcM (TCvSubst, TyCoVar)+-- This a complete freshening operation:+-- the skolems have a fresh unique, and a location from the monad+-- See Note [Skolemising type variables]+freshenTyCoVarX mk_tcv subst tycovar+ = do { loc <- getSrcSpanM+ ; uniq <- newUnique+ ; let old_name = tyVarName tycovar+ new_name = mkInternalName uniq (getOccName old_name) loc+ new_kind = substTyUnchecked subst (tyVarKind tycovar)+ new_tcv = mk_tcv new_name new_kind+ subst1 = extendTCvSubstWithClone subst tycovar new_tcv+ ; return (subst1, new_tcv) }++{- Note [Skolemising type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The tcInstSkolTyVars family of functions instantiate a list of TyVars+to fresh skolem TcTyVars. Important notes:++a) Level allocation. We generally skolemise /before/ calling+ pushLevelAndCaptureConstraints. So we want their level to the level+ of the soon-to-be-created implication, which has a level ONE HIGHER+ than the current level. Hence the pushTcLevel. It feels like a+ slight hack.++b) The [TyVar] should be ordered (kind vars first)+ See Note [Kind substitution when instantiating]++c) It's a complete freshening operation: the skolems have a fresh+ unique, and a location from the monad++d) The resulting skolems are+ non-overlappable for tcInstSkolTyVars,+ but overlappable for tcInstSuperSkolTyVars+ See GHC.Tc.Deriv.Infer Note [Overlap and deriving] for an example+ of where this matters.++Note [Kind substitution when instantiating]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we instantiate a bunch of kind and type variables, first we+expect them to be topologically sorted.+Then we have to instantiate the kind variables, build a substitution+from old variables to the new variables, then instantiate the type+variables substituting the original kind.++Exemple: If we want to instantiate+ [(k1 :: *), (k2 :: *), (a :: k1 -> k2), (b :: k1)]+we want+ [(?k1 :: *), (?k2 :: *), (?a :: ?k1 -> ?k2), (?b :: ?k1)]+instead of the bogus+ [(?k1 :: *), (?k2 :: *), (?a :: k1 -> k2), (?b :: k1)] -} +{- *********************************************************************+* *+ Literals+* *+********************************************************************* -}+ {- In newOverloadedLit we convert directly to an Int or Integer if we know that's what we want. This may save some time, by not@@ -474,8 +657,6 @@ newOverloadedLit lit@(OverLit { ol_val = val, ol_ext = rebindable }) res_ty | not rebindable- -- all built-in overloaded lits are tau-types, so we can just- -- tauify the ExpType = do { res_ty <- expTypeToType res_ty ; dflags <- getDynFlags ; let platform = targetPlatform dflags
compiler/GHC/Tc/Utils/Monad.hs view
@@ -59,7 +59,7 @@ addDependentFiles, -- * Error management- getSrcSpanM, setSrcSpan, addLocM,+ getSrcSpanM, setSrcSpan, addLocM, inGeneratedCode, wrapLocM, wrapLocFstM, wrapLocSndM,wrapLocM_, getErrsVar, setErrsVar, addErr,@@ -82,7 +82,7 @@ -- * Context management for the type checker getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt,- addLandmarkErrCtxtM, updCtxt, popErrCtxt, getCtLocM, setCtLocM,+ addLandmarkErrCtxtM, popErrCtxt, getCtLocM, setCtLocM, -- * Error message generation (type checker) addErrTc,@@ -341,7 +341,9 @@ ; usage_var <- newIORef zeroUE ; let lcl_env = TcLclEnv { tcl_errs = errs_var,- tcl_loc = loc, -- Should be over-ridden very soon!+ tcl_loc = loc,+ -- tcl_loc should be over-ridden very soon!+ tcl_in_gen_code = False, tcl_ctxt = [], tcl_rdr = emptyLocalRdrEnv, tcl_th_ctxt = topStage,@@ -866,11 +868,19 @@ -- Avoid clash with Name.getSrcLoc getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Nothing) } +-- See Note [Rebindable syntax and HsExpansion].+inGeneratedCode :: TcRn Bool+inGeneratedCode = tcl_in_gen_code <$> getLclEnv+ setSrcSpan :: SrcSpan -> TcRn a -> TcRn a-setSrcSpan (RealSrcSpan real_loc _) thing_inside- = updLclEnv (\env -> env { tcl_loc = real_loc }) thing_inside--- Don't overwrite useful info with useless:-setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside+setSrcSpan (RealSrcSpan loc _) thing_inside =+ updLclEnv (\env -> env { tcl_loc = loc, tcl_in_gen_code = False })+ thing_inside+setSrcSpan loc@(UnhelpfulSpan _) thing_inside+ -- See Note [Rebindable syntax and HsExpansion].+ | isGeneratedSrcSpan loc =+ updLclEnv (\env -> env { tcl_in_gen_code = True }) thing_inside+ | otherwise = thing_inside addLocM :: (a -> TcM b) -> Located a -> TcM b addLocM fn (L loc a) = setSrcSpan loc $ fn a@@ -1037,40 +1047,71 @@ ************************************************************************ -} +{- Note [Inlining addErrCtxt]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+You will notice a bunch of INLINE pragamas on addErrCtxt and friends.+The reason is to promote better eta-expansion in client modules.+Consider+ \e s. addErrCtxt c (tc_foo x) e s+It looks as if tc_foo is applied to only two arguments, but if we+inline addErrCtxt it'll turn into something more like+ \e s. tc_foo x (munge c e) s+This is much better because Called Arity analysis can see that tc_foo+is applied to four arguments. See #18379 for a concrete example.++This reliance on delicate inlining and Called Arity is not good.+See #18202 for a more general approach. But meanwhile, these+ininings seem unobjectional, and they solve the immediate+problem. -}+ getErrCtxt :: TcM [ErrCtxt] getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) } setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a+{-# INLINE setErrCtxt #-} -- Note [Inlining addErrCtxt] setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt }) -- | Add a fixed message to the error context. This message should not -- do any tidying. addErrCtxt :: MsgDoc -> TcM a -> TcM a+{-# INLINE addErrCtxt #-} -- Note [Inlining addErrCtxt] addErrCtxt msg = addErrCtxtM (\env -> return (env, msg)) -- | Add a message to the error context. This message may do tidying. addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a-addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts)+{-# INLINE addErrCtxtM #-} -- Note [Inlining addErrCtxt]+addErrCtxtM ctxt m = updCtxt (push_ctxt (False, ctxt)) m -- | Add a fixed landmark message to the error context. A landmark -- message is always sure to be reported, even if there is a lot of -- context. It also doesn't count toward the maximum number of contexts -- reported. addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a+{-# INLINE addLandmarkErrCtxt #-} -- Note [Inlining addErrCtxt] addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg)) -- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations -- and tidying. addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a-addLandmarkErrCtxtM ctxt = updCtxt (\ctxts -> (True, ctxt) : ctxts)+{-# INLINE addLandmarkErrCtxtM #-} -- Note [Inlining addErrCtxt]+addLandmarkErrCtxtM ctxt m = updCtxt (push_ctxt (True, ctxt)) m +push_ctxt :: (Bool, TidyEnv -> TcM (TidyEnv, MsgDoc))+ -> Bool -> [ErrCtxt] -> [ErrCtxt]+push_ctxt ctxt in_gen ctxts+ | in_gen = ctxts+ | otherwise = ctxt : ctxts++updCtxt :: (Bool -> [ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a+{-# INLINE updCtxt #-} -- Note [Inlining addErrCtxt] -- Helper function for the above-updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a-updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->- env { tcl_ctxt = upd ctxt })+-- The Bool is true if we are in generated code+updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt+ , tcl_in_gen_code = in_gen }) ->+ env { tcl_ctxt = upd in_gen ctxt }) popErrCtxt :: TcM a -> TcM a-popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })+popErrCtxt = updCtxt (\ _ msgs -> case msgs of { [] -> []; (_ : ms) -> ms }) getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc getCtLocM origin t_or_k
compiler/GHC/Tc/Utils/TcMType.hs view
@@ -32,15 +32,6 @@ isFilledMetaTyVar_maybe, isFilledMetaTyVar, isUnfilledMetaTyVar, --------------------------------- -- Expected types- ExpType(..), ExpSigmaType, ExpRhoType,- mkCheckExpType,- newInferExpType,- readExpType, readExpType_maybe,- expTypeToType, checkingExpType_maybe, checkingExpType,- tauifyExpType, inferResultToType,-- -------------------------------- -- Creating new evidence variables newEvVar, newEvVars, newDict, newWanted, newWanteds, cloneWanted, cloneWC,@@ -58,14 +49,18 @@ -------------------------------- -- Instantiation newMetaTyVars, newMetaTyVarX, newMetaTyVarsX,- newMetaTyVarTyVars, newMetaTyVarTyVarX,+ newMetaTyVarTyVarX, newTyVarTyVar, cloneTyVarTyVar, newPatSigTyVar, newSkolemTyVar, newWildCardX,- tcInstType, tcInstTypeBndrs,- tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarsAt,- tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX, - freshenTyVarBndrs, freshenCoVarBndrsX,+ --------------------------------+ -- Expected types+ ExpType(..), ExpSigmaType, ExpRhoType,+ mkCheckExpType, newInferExpType, tcInfer,+ readExpType, readExpType_maybe, readScaledExpType,+ expTypeToType, scaledExpTypeToType,+ checkingExpType_maybe, checkingExpType,+ inferResultToType, fillInferResult, promoteTcType, -------------------------------- -- Zonking and tidying@@ -99,6 +94,8 @@ -- friends: import GHC.Prelude +import {-# SOURCE #-} GHC.Tc.Utils.Unify( unifyType {- , unifyKind -} )+ import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr import GHC.Tc.Utils.TcType@@ -133,7 +130,6 @@ import Control.Monad import GHC.Data.Maybe-import Data.List ( mapAccumL ) import Control.Arrow ( second ) import qualified Data.Semigroup as Semi @@ -387,16 +383,14 @@ | otherwise = False -{--************************************************************************+{- ********************************************************************** *- Expected types+ ExpType functions *-************************************************************************--Note [ExpType]-~~~~~~~~~~~~~~+********************************************************************** -} +{- Note [ExpType]+~~~~~~~~~~~~~~~~~ An ExpType is used as the "expected type" when type-checking an expression. An ExpType can hold a "hole" that can be filled in by the type-checker. This allows us to have one tcExpr that works in both checking mode and@@ -426,14 +420,12 @@ This is a classic untouchable-variable / ambiguous GADT return type scenario. But, with ExpTypes, we'll be inferring the type of the RHS.-And, because there is only one branch of the case, we won't trigger-Note [Case branches must never infer a non-tau type] of GHC.Tc.Gen.Match. We thus must track a TcLevel in an Inferring ExpType. If we try to-fill the ExpType and find that the TcLevels don't work out, we-fill the ExpType with a tau-tv at the low TcLevel, hopefully to-be worked out later by some means. This is triggered in-test gadt/gadt-escape1.+fill the ExpType and find that the TcLevels don't work out, we fill+the ExpType with a tau-tv at the low TcLevel, hopefully to be worked+out later by some means -- see fillInferResult, and Note [fillInferResult] +This behaviour triggered in test gadt/gadt-escape1. -} -- actual data definition is in GHC.Tc.Utils.TcType@@ -453,6 +445,12 @@ readExpType_maybe (Check ty) = return (Just ty) readExpType_maybe (Infer (IR { ir_ref = ref})) = readMutVar ref +-- | Same as readExpType, but for Scaled ExpTypes+readScaledExpType :: Scaled ExpType -> TcM (Scaled Type)+readScaledExpType (Scaled m exp_ty)+ = do { ty <- readExpType exp_ty+ ; return (Scaled m ty) }+ -- | Extract a type out of an ExpType. Otherwise, panics. readExpType :: ExpType -> TcM TcType readExpType exp_ty@@ -472,12 +470,10 @@ checkingExpType _ (Check ty) = ty checkingExpType err et = pprPanic "checkingExpType" (text err $$ ppr et) -tauifyExpType :: ExpType -> TcM ExpType--- ^ Turn a (Infer hole) type into a (Check alpha),--- where alpha is a fresh unification variable-tauifyExpType (Check ty) = return (Check ty) -- No-op for (Check ty)-tauifyExpType (Infer inf_res) = do { ty <- inferResultToType inf_res- ; return (Check ty) }+scaledExpTypeToType :: Scaled ExpType -> TcM (Scaled TcType)+scaledExpTypeToType (Scaled m exp_ty)+ = do { ty <- expTypeToType exp_ty+ ; return (Scaled m ty) } -- | Extracts the expected type if there is one, or generates a new -- TauTv if there isn't.@@ -488,209 +484,279 @@ inferResultToType :: InferResult -> TcM Type inferResultToType (IR { ir_uniq = u, ir_lvl = tc_lvl , ir_ref = ref })- = do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy- ; tau <- newMetaTyVarTyAtLevel tc_lvl (tYPE rr)- -- See Note [TcLevel of ExpType]- ; writeMutVar ref (Just tau)+ = do { mb_inferred_ty <- readTcRef ref+ ; tau <- case mb_inferred_ty of+ Just ty -> do { ensureMonoType ty+ -- See Note [inferResultToType]+ ; return ty }+ Nothing -> do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy+ ; tau <- newMetaTyVarTyAtLevel tc_lvl (tYPE rr)+ -- See Note [TcLevel of ExpType]+ ; writeMutVar ref (Just tau)+ ; return tau } ; traceTc "Forcing ExpType to be monomorphic:" (ppr u <+> text ":=" <+> ppr tau) ; return tau } +{- Note [inferResultToType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+expTypeToType and inferResultType convert an InferResult to a monotype.+It must be a monotype because if the InferResult isn't already filled in,+we fill it in with a unification variable (hence monotype). So to preserve+order-independence we check for mono-type-ness even if it *is* filled in+already. -{- *********************************************************************-* *- SkolemTvs (immutable)-* *-********************************************************************* -}+See also Note [TcLevel of ExpType] above, and+Note [fillInferResult].+-} -tc_inst_internal :: ([VarBndr TyVar flag] -> TcM (TCvSubst, [VarBndr TcTyVar flag]))- -- ^ How to instantiate the type variables- -> [VarBndr TyVar flag] -- ^ Type variable to instantiate- -> Type -- ^ rho- -> TcM ([(Name, VarBndr TcTyVar flag)], TcThetaType, TcType) -- ^ Result- -- (type vars, preds (incl equalities), rho)-tc_inst_internal _inst_tyvars [] rho =- let -- There may be overloading despite no type variables;- -- (?x :: Int) => Int -> Int- (theta, tau) = tcSplitPhiTy rho- in- return ([], theta, tau)-tc_inst_internal inst_tyvars tyvars rho =- do { (subst, tyvars') <- inst_tyvars tyvars- ; let (theta, tau) = tcSplitPhiTy (substTyAddInScope subst rho)- tv_prs = map (tyVarName . binderVar) tyvars `zip` tyvars'- ; return (tv_prs, theta, tau) }+-- | Infer a type using a fresh ExpType+-- See also Note [ExpType] in "GHC.Tc.Utils.TcMType"+tcInfer :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)+tcInfer tc_check+ = do { res_ty <- newInferExpType+ ; result <- tc_check res_ty+ ; res_ty <- readExpType res_ty+ ; return (result, res_ty) } -tcInstType :: ([TyVar] -> TcM (TCvSubst, [TcTyVar]))- -- ^ How to instantiate the type variables- -> Id -- ^ Type to instantiate- -> TcM ([(Name, TcTyVar)], TcThetaType, TcType) -- ^ Result- -- (type vars, preds (incl equalities), rho)-tcInstType inst_tyvars id =- do { let (tyvars, rho) = splitForAllTys (idType id)- tyvars' = mkTyVarBinders () tyvars- ; (tv_prs, preds, rho) <- tc_inst_internal inst_tyvar_bndrs tyvars' rho- ; let tv_prs' = map (\(name, bndr) -> (name, binderVar bndr)) tv_prs- ; return (tv_prs', preds, rho) }- where- inst_tyvar_bndrs :: [VarBndr TyVar ()] -> TcM (TCvSubst, [VarBndr TcTyVar ()])- inst_tyvar_bndrs bndrs = do { (subst, tvs) <- inst_tyvars $ binderVars bndrs- ; let tvbnds = map (\tv -> Bndr tv ()) tvs- ; return (subst, tvbnds) }+fillInferResult :: TcType -> InferResult -> TcM TcCoercionN+-- If co = fillInferResult t1 t2+-- => co :: t1 ~ t2+-- See Note [fillInferResult]+fillInferResult act_res_ty (IR { ir_uniq = u, ir_lvl = res_lvl+ , ir_ref = ref })+ = do { mb_exp_res_ty <- readTcRef ref+ ; case mb_exp_res_ty of+ Just exp_res_ty+ -> do { traceTc "Joining inferred ExpType" $+ ppr u <> colon <+> ppr act_res_ty <+> char '~' <+> ppr exp_res_ty+ ; cur_lvl <- getTcLevel+ ; unless (cur_lvl `sameDepthAs` res_lvl) $+ ensureMonoType act_res_ty+ ; unifyType Nothing act_res_ty exp_res_ty }+ Nothing+ -> do { traceTc "Filling inferred ExpType" $+ ppr u <+> text ":=" <+> ppr act_res_ty+ ; (prom_co, act_res_ty) <- promoteTcType res_lvl act_res_ty+ ; writeTcRef ref (Just act_res_ty)+ ; return prom_co }+ } -tcInstTypeBndrs :: ([VarBndr TyVar Specificity] -> TcM (TCvSubst, [VarBndr TcTyVar Specificity]))- -- ^ How to instantiate the type variables- -> Id -- ^ Type to instantiate- -> TcM ([(Name, VarBndr TcTyVar Specificity)], TcThetaType, TcType) -- ^ Result- -- (type vars, preds (incl equalities), rho)-tcInstTypeBndrs inst_tyvars id =- let (tyvars, rho) = splitForAllTysInvis (idType id)- in tc_inst_internal inst_tyvars tyvars rho -tcSkolDFunType :: DFunId -> TcM ([TcTyVar], TcThetaType, TcType)--- Instantiate a type signature with skolem constants.--- We could give them fresh names, but no need to do so-tcSkolDFunType dfun- = do { (tv_prs, theta, tau) <- tcInstType tcInstSuperSkolTyVars dfun- ; return (map snd tv_prs, theta, tau) }+{- Note [fillInferResult]+~~~~~~~~~~~~~~~~~~~~~~~~~+When inferring, we use fillInferResult to "fill in" the hole in InferResult+ data InferResult = IR { ir_uniq :: Unique+ , ir_lvl :: TcLevel+ , ir_ref :: IORef (Maybe TcType) } -tcSuperSkolTyVars :: [TyVar] -> (TCvSubst, [TcTyVar])--- Make skolem constants, but do *not* give them new names, as above--- Moreover, make them "super skolems"; see comments with superSkolemTv--- see Note [Kind substitution when instantiating]--- Precondition: tyvars should be ordered by scoping-tcSuperSkolTyVars = mapAccumL tcSuperSkolTyVar emptyTCvSubst+There are two things to worry about: -tcSuperSkolTyVar :: TCvSubst -> TyVar -> (TCvSubst, TcTyVar)-tcSuperSkolTyVar subst tv- = (extendTvSubstWithClone subst tv new_tv, new_tv)- where- kind = substTyUnchecked subst (tyVarKind tv)- new_tv = mkTcTyVar (tyVarName tv) kind superSkolemTv+1. What if it is under a GADT or existential pattern match?+ - GADTs: a unification variable (and Infer's hole is similar) is untouchable+ - Existentials: be careful about skolem-escape --- | Given a list of @['TyVar']@, skolemize the type variables,--- returning a substitution mapping the original tyvars to the--- skolems, and the list of newly bound skolems.-tcInstSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])--- See Note [Skolemising type variables]-tcInstSkolTyVars = tcInstSkolTyVarsX emptyTCvSubst+2. What if it is filled in more than once? E.g. multiple branches of a case+ case e of+ T1 -> e1+ T2 -> e2 -tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])--- See Note [Skolemising type variables]-tcInstSkolTyVarsX = tcInstSkolTyVarsPushLevel False+Our typing rules are: -tcInstSuperSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])--- See Note [Skolemising type variables]-tcInstSuperSkolTyVars = tcInstSuperSkolTyVarsX emptyTCvSubst+* The RHS of a existential or GADT alternative must always be a+ monotype, regardless of the number of alternatives. -tcInstSuperSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])--- See Note [Skolemising type variables]-tcInstSuperSkolTyVarsX subst = tcInstSkolTyVarsPushLevel True subst+* Multiple non-existential/GADT branches can have (the same)+ higher rank type (#18412). E.g. this is OK:+ case e of+ True -> hr+ False -> hr+ where hr:: (forall a. a->a) -> Int+ c.f. Section 7.1 of "Practical type inference for arbitrary-rank types"+ We use choice (2) in that Section.+ (GHC 8.10 and earlier used choice (1).) -tcInstSkolTyVarsPushLevel :: Bool -> TCvSubst -> [TyVar]- -> TcM (TCvSubst, [TcTyVar])--- Skolemise one level deeper, hence pushTcLevel--- See Note [Skolemising type variables]-tcInstSkolTyVarsPushLevel overlappable subst tvs- = do { tc_lvl <- getTcLevel- ; let pushed_lvl = pushTcLevel tc_lvl- ; tcInstSkolTyVarsAt pushed_lvl overlappable subst tvs }+ But note that+ case e of+ True -> hr+ False -> \x -> hr x+ will fail, because we still /infer/ both branches, so the \x will get+ a (monotype) unification variable, which will fail to unify with+ (forall a. a->a) -tcInstSkolTyVarsAt :: TcLevel -> Bool- -> TCvSubst -> [TyVar]- -> TcM (TCvSubst, [TcTyVar])-tcInstSkolTyVarsAt lvl overlappable subst tvs- = freshenTyCoVarsX new_skol_tv subst tvs+For (1) we can detect the GADT/existential situation by seeing that+the current TcLevel is greater than that stored in ir_lvl of the Infer+ExpType. We bump the level whenever we go past a GADT/existential match.++Then, before filling the hole use promoteTcType to promote the type+to the outer ir_lvl. promoteTcType does this+ - create a fresh unification variable alpha at level ir_lvl+ - emits an equality alpha[ir_lvl] ~ ty+ - fills the hole with alpha+That forces the type to be a monotype (since unification variables can+only unify with monotypes); and catches skolem-escapes because the+alpha is untouchable until the equality floats out.++For (2), we simply look to see if the hole is filled already.+ - if not, we promote (as above) and fill the hole+ - if it is filled, we simply unify with the type that is+ already there++There is one wrinkle. Suppose we have+ case e of+ T1 -> e1 :: (forall a. a->a) -> Int+ G2 -> e2+where T1 is not GADT or existential, but G2 is a GADT. Then supppose the+T1 alternative fills the hole with (forall a. a->a) -> Int, which is fine.+But now the G2 alternative must not *just* unify with that else we'd risk+allowing through (e2 :: (forall a. a->a) -> Int). If we'd checked G2 first+we'd have filled the hole with a unification variable, which enforces a+monotype.++So if we check G2 second, we still want to emit a constraint that restricts+the RHS to be a monotype. This is done by ensureMonoType, and it works+by simply generating a constraint (alpha ~ ty), where alpha is a fresh+unification variable. We discard the evidence.++-}++{- *********************************************************************+* *+ Promoting types+* *+********************************************************************* -}++ensureMonoType :: TcType -> TcM ()+-- Assuming that the argument type is of kind (TYPE r),+-- ensure that it is a /monotype/+-- If it is not a monotype we can see right away (since unification+-- varibles and type-function applications stand for monotypes), but+-- we emit a Wanted equality just to delay the error message until later+ensureMonoType res_ty+ | isTauTy res_ty -- isTauTy doesn't need zonking or anything+ = return ()+ | otherwise+ = do { mono_ty <- newOpenFlexiTyVarTy+ ; let eq_orig = TypeEqOrigin { uo_actual = res_ty+ , uo_expected = mono_ty+ , uo_thing = Nothing+ , uo_visible = False }++ ; _co <- emitWantedEq eq_orig TypeLevel Nominal res_ty mono_ty+ ; return () }++promoteTcType :: TcLevel -> TcType -> TcM (TcCoercionN, TcType)+-- See Note [Promoting a type]+-- See also Note [fillInferResult]+-- promoteTcType level ty = (co, ty')+-- * Returns ty' whose max level is just 'level'+-- and whose kind is ~# to the kind of 'ty'+-- and whose kind has form TYPE rr+-- * and co :: ty ~ ty'+-- * and emits constraints to justify the coercion+--+-- NB: we expect that 'ty' has already kind (TYPE rr) for+-- some rr::RuntimeRep. It is, after all, the type of a term.+promoteTcType dest_lvl ty+ = do { cur_lvl <- getTcLevel+ ; if (cur_lvl `sameDepthAs` dest_lvl)+ then return (mkTcNomReflCo ty, ty)+ else promote_it } where- details = SkolemTv lvl overlappable- new_skol_tv name kind = mkTcTyVar name kind details+ promote_it :: TcM (TcCoercion, TcType)+ promote_it -- Emit a constraint (alpha :: TYPE rr) ~ ty+ -- where alpha and rr are fresh and from level dest_lvl+ = do { rr <- newMetaTyVarTyAtLevel dest_lvl runtimeRepTy+ ; prom_ty <- newMetaTyVarTyAtLevel dest_lvl (tYPE rr)+ ; let eq_orig = TypeEqOrigin { uo_actual = ty+ , uo_expected = prom_ty+ , uo_thing = Nothing+ , uo_visible = False } --------------------freshenTyVarBndrs :: [TyVar] -> TcM (TCvSubst, [TyVar])--- ^ Give fresh uniques to a bunch of TyVars, but they stay--- as TyVars, rather than becoming TcTyVars--- Used in 'GHC.Tc.Instance.Family.newFamInst', and 'GHC.Tc.Utils.Instantiate.newClsInst'-freshenTyVarBndrs = freshenTyCoVars mkTyVar+ ; co <- emitWantedEq eq_orig TypeLevel Nominal ty prom_ty+ ; return (co, prom_ty) } -freshenCoVarBndrsX :: TCvSubst -> [CoVar] -> TcM (TCvSubst, [CoVar])--- ^ Give fresh uniques to a bunch of CoVars--- Used in "GHC.Tc.Instance.Family.newFamInst"-freshenCoVarBndrsX subst = freshenTyCoVarsX mkCoVar subst+{- Note [Promoting a type]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#12427) --------------------freshenTyCoVars :: (Name -> Kind -> TyCoVar)- -> [TyVar] -> TcM (TCvSubst, [TyCoVar])-freshenTyCoVars mk_tcv = freshenTyCoVarsX mk_tcv emptyTCvSubst+ data T where+ MkT :: (Int -> Int) -> a -> T -freshenTyCoVarsX :: (Name -> Kind -> TyCoVar)- -> TCvSubst -> [TyCoVar]- -> TcM (TCvSubst, [TyCoVar])-freshenTyCoVarsX mk_tcv = mapAccumLM (freshenTyCoVarX mk_tcv)+ h y = case y of MkT v w -> v -freshenTyCoVarX :: (Name -> Kind -> TyCoVar)- -> TCvSubst -> TyCoVar -> TcM (TCvSubst, TyCoVar)--- This a complete freshening operation:--- the skolems have a fresh unique, and a location from the monad--- See Note [Skolemising type variables]-freshenTyCoVarX mk_tcv subst tycovar- = do { loc <- getSrcSpanM- ; uniq <- newUnique- ; let old_name = tyVarName tycovar- new_name = mkInternalName uniq (getOccName old_name) loc- new_kind = substTyUnchecked subst (tyVarKind tycovar)- new_tcv = mk_tcv new_name new_kind- subst1 = extendTCvSubstWithClone subst tycovar new_tcv- ; return (subst1, new_tcv) }+We'll infer the RHS type with an expected type ExpType of+ (IR { ir_lvl = l, ir_ref = ref, ... )+where 'l' is the TcLevel of the RHS of 'h'. Then the MkT pattern+match will increase the level, so we'll end up in tcSubType, trying to+unify the type of v,+ v :: Int -> Int+with the expected type. But this attempt takes place at level (l+1),+rightly so, since v's type could have mentioned existential variables,+(like w's does) and we want to catch that. -{- Note [Skolemising type variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The tcInstSkolTyVars family of functions instantiate a list of TyVars-to fresh skolem TcTyVars. Important notes:+So we+ - create a new meta-var alpha[l+1]+ - fill in the InferRes ref cell 'ref' with alpha+ - emit an equality constraint, thus+ [W] alpha[l+1] ~ (Int -> Int) -a) Level allocation. We generally skolemise /before/ calling- pushLevelAndCaptureConstraints. So we want their level to the level- of the soon-to-be-created implication, which has a level ONE HIGHER- than the current level. Hence the pushTcLevel. It feels like a- slight hack.+That constraint will float outwards, as it should, unless v's+type mentions a skolem-captured variable. -b) The [TyVar] should be ordered (kind vars first)- See Note [Kind substitution when instantiating]+This approach fails if v has a higher rank type; see+Note [Promotion and higher rank types] -c) It's a complete freshening operation: the skolems have a fresh- unique, and a location from the monad -d) The resulting skolems are- non-overlappable for tcInstSkolTyVars,- but overlappable for tcInstSuperSkolTyVars- See GHC.Tc.Deriv.Infer Note [Overlap and deriving] for an example- of where this matters.+Note [Promotion and higher rank types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If v had a higher-rank type, say v :: (forall a. a->a) -> Int,+then we'd emit an equality+ [W] alpha[l+1] ~ ((forall a. a->a) -> Int)+which will sadly fail because we can't unify a unification variable+with a polytype. But there is nothing really wrong with the program+here. -Note [Kind substitution when instantiating]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we instantiate a bunch of kind and type variables, first we-expect them to be topologically sorted.-Then we have to instantiate the kind variables, build a substitution-from old variables to the new variables, then instantiate the type-variables substituting the original kind.+We could just about solve this by "promote the type" of v, to expose+its polymorphic "shape" while still leaving constraints that will+prevent existential escape. But we must be careful! Exposing+the "shape" of the type is precisely what we must NOT do under+a GADT pattern match! So in this case we might promote the type+to+ (forall a. a->a) -> alpha[l+1]+and emit the constraint+ [W] alpha[l+1] ~ Int+Now the promoted type can fill the ref cell, while the emitted+equality can float or not, according to the usual rules. -Exemple: If we want to instantiate- [(k1 :: *), (k2 :: *), (a :: k1 -> k2), (b :: k1)]-we want- [(?k1 :: *), (?k2 :: *), (?a :: ?k1 -> ?k2), (?b :: ?k1)]-instead of the buggous- [(?k1 :: *), (?k2 :: *), (?a :: k1 -> k2), (?b :: k1)]+But that's not quite right! We are exposing the arrow! We could+deal with that too:+ (forall a. mu[l+1] a a) -> alpha[l+1]+with constraints+ [W] alpha[l+1] ~ Int+ [W] mu[l+1] ~ (->)+Here we abstract over the '->' inside the forall, in case that+is subject to an equality constraint from a GADT match. +Note that we kept the outer (->) because that's part of+the polymorphic "shape". And because of impredicativity,+GADT matches can't give equalities that affect polymorphic+shape. -************************************************************************+This reasoning just seems too complicated, so I decided not+to do it. These higher-rank notes are just here to record+the thinking.+-}+++{- ********************************************************************* * * MetaTvs (meta type variables; mutable) * *-************************************************************************--}+********************************************************************* -} -{--Note [TyVarTv]-~~~~~~~~~~~~+{- Note [TyVarTv]+~~~~~~~~~~~~~~~~~ A TyVarTv can unify with type *variables* only, including other TyVarTvs and skolems. Sometimes, they can unify with type variables that the user would@@ -1031,18 +1097,11 @@ newMetaTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) -- Make a new unification variable tyvar whose Name and Kind come from -- an existing TyVar. We substitute kind variables in the kind.-newMetaTyVarX subst tyvar = new_meta_tv_x TauTv subst tyvar--newMetaTyVarTyVars :: [VarBndr TyVar Specificity]- -> TcM (TCvSubst, [VarBndr TcTyVar Specificity])-newMetaTyVarTyVars = mapAccumLM newMetaTyVarTyVarX emptyTCvSubst+newMetaTyVarX = new_meta_tv_x TauTv -newMetaTyVarTyVarX :: TCvSubst -> (VarBndr TyVar Specificity)- -> TcM (TCvSubst, VarBndr TcTyVar Specificity)+newMetaTyVarTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) -- Just like newMetaTyVarX, but make a TyVarTv-newMetaTyVarTyVarX subst (Bndr tv spec) =- do { (subst', tv') <- new_meta_tv_x TyVarTv subst tv- ; return (subst', (Bndr tv' spec)) }+newMetaTyVarTyVarX = new_meta_tv_x TyVarTv newWildCardX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) newWildCardX subst tv
compiler/GHC/Tc/Utils/Unify.hs view
@@ -61,7 +61,6 @@ import GHC.Tc.Utils.Instantiate import GHC.Core.TyCon import GHC.Builtin.Types-import GHC.Builtin.Types.Prim( tYPE ) import GHC.Types.Var as Var import GHC.Types.Var.Set import GHC.Types.Var.Env@@ -571,10 +570,51 @@ -> TcM HsWrapper tcSubTypeNC inst_orig ctxt m_thing ty_actual res_ty = case res_ty of- Infer inf_res -> instantiateAndFillInferResult inst_orig ty_actual inf_res Check ty_expected -> tc_sub_type (unifyType m_thing) inst_orig ctxt ty_actual ty_expected + Infer inf_res -> do { (wrap, rho) <- topInstantiate inst_orig ty_actual+ -- See Note [Instantiation of InferResult]+ ; co <- fillInferResult rho inf_res+ ; return (mkWpCastN co <.> wrap) }++{- Note [Instantiation of InferResult]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We now always instantiate before filling in InferResult, so that+the result is a TcRhoType: see #17173 for discussion.++For example:++1. Consider+ f x = (*)+ We want to instantiate the type of (*) before returning, else we+ will infer the type+ f :: forall {a}. a -> forall b. Num b => b -> b -> b+ This is surely confusing for users.++ And worse, the monomorphism restriction won't work properly. The MR is+ dealt with in simplifyInfer, and simplifyInfer has no way of+ instantiating. This could perhaps be worked around, but it may be+ hard to know even when instantiation should happen.++2. Another reason. Consider+ f :: (?x :: Int) => a -> a+ g y = let ?x = 3::Int in f+ Here want to instantiate f's type so that the ?x::Int constraint+ gets discharged by the enclosing implicit-parameter binding.++3. Suppose one defines plus = (+). If we instantiate lazily, we will+ infer plus :: forall a. Num a => a -> a -> a. However, the monomorphism+ restriction compels us to infer+ plus :: Integer -> Integer -> Integer+ (or similar monotype). Indeed, the only way to know whether to apply+ the monomorphism restriction at all is to instantiate++There is one place where we don't want to instantiate eagerly,+namely in GHC.Tc.Module.tcRnExpr, which implements GHCi's :type+command. See Note [Implementing :type] in GHC.Tc.Module.+-}+ --------------- tcSubTypeSigma :: UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper -- External entry point, but no ExpTypes on either side@@ -722,29 +762,29 @@ ambiguity check, but we don't need one for each level within it, and GHC.Tc.Utils.Unify.alwaysBuildImplication checks the UserTypeCtxt. See Note [When to build an implication]--} +Note [Wrapper returned from tcSubMult]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There is no notion of multiplicity coercion in Core, therefore the wrapper+returned by tcSubMult (and derived functions such as tcCheckUsage and+checkManyPattern) is quite unlike any other wrapper: it checks whether the+coercion produced by the constraint solver is trivial, producing a type error+is it is not. This is implemented via the WpMultCoercion wrapper, as desugared+by GHC.HsToCore.Binds.dsHsWrapper, which does the reflexivity check. --- Note [tcSubMult's wrapper]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~--- There is no notion of multiplicity coercion in Core, therefore the wrapper--- returned by tcSubMult (and derived function such as tcCheckUsage and--- checkManyPattern) is quite unlike any other wrapper: it checks whether the--- coercion produced by the constraint solver is trivial and disappears (it--- produces a type error is the constraint is not trivial). See [Checking--- multiplicity coercions] in TcEvidence.------ This wrapper need to be placed in the term, otherwise checking of the--- eventual coercion won't be triggered during desuraging. But it can be put--- anywhere, since it doesn't affect the desugared code.------ Why do we check this in the desugarer? It's a convenient place, since it's--- right after all the constraints are solved. We need the constraints to be--- solved to check whether they are trivial or not. Plus there are precedent for--- type errors during desuraging (such as the levity polymorphism--- restriction). An alternative would be to have a kind of constraints which can--- only produce trivial evidence, then this check would happen in the constraint--- solver.+This wrapper needs to be placed in the term; otherwise, checking of the+eventual coercion won't be triggered during desugaring. But it can be put+anywhere, since it doesn't affect the desugared code.++Why do we check this in the desugarer? It's a convenient place, since it's+right after all the constraints are solved. We need the constraints to be+solved to check whether they are trivial or not. Plus there is precedent for+type errors during desuraging (such as the levity polymorphism+restriction). An alternative would be to have a kind of constraint which can+only produce trivial evidence, then this check would happen in the constraint+solver.+-}+ tcSubMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper tcSubMult origin w_actual w_expected | Just (w1, w2) <- isMultMul w_actual =@@ -768,216 +808,9 @@ ; coercion <- uType TypeLevel origin w_actual w_expected ; return $ if isReflCo coercion then WpHole else WpMultCoercion coercion } -{- **********************************************************************-%* *- ExpType functions: tcInfer, instantiateAndFillInferResult-%* *-%********************************************************************* -} --- | Infer a type using a fresh ExpType--- See also Note [ExpType] in "GHC.Tc.Utils.TcMType"-tcInfer :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)-tcInfer tc_check- = do { res_ty <- newInferExpType- ; result <- tc_check res_ty- ; res_ty <- readExpType res_ty- ; return (result, res_ty) }--instantiateAndFillInferResult :: CtOrigin -> TcType -> InferResult -> TcM HsWrapper--- If wrap = instantiateAndFillInferResult t1 t2--- => wrap :: t1 ~> t2--- See Note [Instantiation of InferResult]-instantiateAndFillInferResult orig ty inf_res- = do { (wrap, rho) <- topInstantiate orig ty- ; co <- fillInferResult rho inf_res- ; return (mkWpCastN co <.> wrap) }--fillInferResult :: TcType -> InferResult -> TcM TcCoercionN--- If wrap = fillInferResult t1 t2--- => wrap :: t1 ~> t2-fillInferResult orig_ty (IR { ir_uniq = u, ir_lvl = res_lvl- , ir_ref = ref })- = do { (ty_co, ty_to_fill_with) <- promoteTcType res_lvl orig_ty-- ; traceTc "Filling ExpType" $- ppr u <+> text ":=" <+> ppr ty_to_fill_with-- ; when debugIsOn (check_hole ty_to_fill_with)-- ; writeTcRef ref (Just ty_to_fill_with)-- ; return ty_co }- where- check_hole ty -- Debug check only- = do { let ty_lvl = tcTypeLevel ty- ; MASSERT2( not (ty_lvl `strictlyDeeperThan` res_lvl),- ppr u $$ ppr res_lvl $$ ppr ty_lvl $$- ppr ty <+> dcolon <+> ppr (tcTypeKind ty) $$ ppr orig_ty )- ; cts <- readTcRef ref- ; case cts of- Just already_there -> pprPanic "writeExpType"- (vcat [ ppr u- , ppr ty- , ppr already_there ])- Nothing -> return () }--{- Note [Instantiation of InferResult]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We now always instantiate before filling in InferResult, so that-the result is a TcRhoType: see #17173 for discussion.--For example:--1. Consider- f x = (*)- We want to instantiate the type of (*) before returning, else we- will infer the type- f :: forall {a}. a -> forall b. Num b => b -> b -> b- This is surely confusing for users.-- And worse, the monomorphism restriction won't work properly. The MR is- dealt with in simplifyInfer, and simplifyInfer has no way of- instantiating. This could perhaps be worked around, but it may be- hard to know even when instantiation should happen.--2. Another reason. Consider- f :: (?x :: Int) => a -> a- g y = let ?x = 3::Int in f- Here want to instantiate f's type so that the ?x::Int constraint- gets discharged by the enclosing implicit-parameter binding.--3. Suppose one defines plus = (+). If we instantiate lazily, we will- infer plus :: forall a. Num a => a -> a -> a. However, the monomorphism- restriction compels us to infer- plus :: Integer -> Integer -> Integer- (or similar monotype). Indeed, the only way to know whether to apply- the monomorphism restriction at all is to instantiate--There is one place where we don't want to instantiate eagerly,-namely in GHC.Tc.Module.tcRnExpr, which implements GHCi's :type-command. See Note [Implementing :type] in GHC.Tc.Module.---}- {- ********************************************************************* * *- Promoting types-* *-********************************************************************* -}--promoteTcType :: TcLevel -> TcType -> TcM (TcCoercion, TcType)--- See Note [Promoting a type]--- promoteTcType level ty = (co, ty')--- * Returns ty' whose max level is just 'level'--- and whose kind is ~# to the kind of 'ty'--- and whose kind has form TYPE rr--- * and co :: ty ~ ty'--- * and emits constraints to justify the coercion-promoteTcType dest_lvl ty- = do { cur_lvl <- getTcLevel- ; if (cur_lvl `sameDepthAs` dest_lvl)- then dont_promote_it- else promote_it }- where- promote_it :: TcM (TcCoercion, TcType)- promote_it -- Emit a constraint (alpha :: TYPE rr) ~ ty- -- where alpha and rr are fresh and from level dest_lvl- = do { rr <- newMetaTyVarTyAtLevel dest_lvl runtimeRepTy- ; prom_ty <- newMetaTyVarTyAtLevel dest_lvl (tYPE rr)- ; let eq_orig = TypeEqOrigin { uo_actual = ty- , uo_expected = prom_ty- , uo_thing = Nothing- , uo_visible = False }-- ; co <- emitWantedEq eq_orig TypeLevel Nominal ty prom_ty- ; return (co, prom_ty) }-- dont_promote_it :: TcM (TcCoercion, TcType)- dont_promote_it -- Check that ty :: TYPE rr, for some (fresh) rr- = do { res_kind <- newOpenTypeKind- ; let ty_kind = tcTypeKind ty- kind_orig = TypeEqOrigin { uo_actual = ty_kind- , uo_expected = res_kind- , uo_thing = Nothing- , uo_visible = False }- ; ki_co <- uType KindLevel kind_orig (tcTypeKind ty) res_kind- ; let co = mkTcGReflRightCo Nominal ty ki_co- ; return (co, ty `mkCastTy` ki_co) }--{- Note [Promoting a type]-~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider (#12427)-- data T where- MkT :: (Int -> Int) -> a -> T-- h y = case y of MkT v w -> v--We'll infer the RHS type with an expected type ExpType of- (IR { ir_lvl = l, ir_ref = ref, ... )-where 'l' is the TcLevel of the RHS of 'h'. Then the MkT pattern-match will increase the level, so we'll end up in tcSubType, trying to-unify the type of v,- v :: Int -> Int-with the expected type. But this attempt takes place at level (l+1),-rightly so, since v's type could have mentioned existential variables,-(like w's does) and we want to catch that.--So we- - create a new meta-var alpha[l+1]- - fill in the InferRes ref cell 'ref' with alpha- - emit an equality constraint, thus- [W] alpha[l+1] ~ (Int -> Int)--That constraint will float outwards, as it should, unless v's-type mentions a skolem-captured variable.--This approach fails if v has a higher rank type; see-Note [Promotion and higher rank types]---Note [Promotion and higher rank types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If v had a higher-rank type, say v :: (forall a. a->a) -> Int,-then we'd emit an equality- [W] alpha[l+1] ~ ((forall a. a->a) -> Int)-which will sadly fail because we can't unify a unification variable-with a polytype. But there is nothing really wrong with the program-here.--We could just about solve this by "promote the type" of v, to expose-its polymorphic "shape" while still leaving constraints that will-prevent existential escape. But we must be careful! Exposing-the "shape" of the type is precisely what we must NOT do under-a GADT pattern match! So in this case we might promote the type-to- (forall a. a->a) -> alpha[l+1]-and emit the constraint- [W] alpha[l+1] ~ Int-Now the promoted type can fill the ref cell, while the emitted-equality can float or not, according to the usual rules.--But that's not quite right! We are exposing the arrow! We could-deal with that too:- (forall a. mu[l+1] a a) -> alpha[l+1]-with constraints- [W] alpha[l+1] ~ Int- [W] mu[l+1] ~ (->)-Here we abstract over the '->' inside the forall, in case that-is subject to an equality constraint from a GADT match.--Note that we kept the outer (->) because that's part of-the polymorphic "shape". And because of impredicativity,-GADT matches can't give equalities that affect polymorphic-shape.--This reasoning just seems too complicated, so I decided not-to do it. These higher-rank notes are just here to record-the thinking.--}--{- *********************************************************************-* * Generalisation * * ********************************************************************* -}@@ -2046,21 +1879,8 @@ ********************************************************************* -} -{- Note [Occurrence checking: look inside kinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we are considering unifying- (alpha :: *) ~ Int -> (beta :: alpha -> alpha)-This may be an error (what is that alpha doing inside beta's kind?),-but we must not make the mistake of actually unifying or we'll-build an infinite data structure. So when looking for occurrences-of alpha in the rhs, we must look in the kinds of type variables-that occur there.--NB: we may be able to remove the problem via expansion; see- Note [Occurs check expansion]. So we have to try that.--Note [Checking for foralls]-~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Checking for foralls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Unless we have -XImpredicativeTypes (which is a totally unsupported feature), we do not want to unify alpha ~ (forall a. a->a) -> Int@@ -2073,10 +1893,10 @@ (alpha :: forall k. k->*) ~ (beta :: forall k. k->*) This is legal; e.g. dependent/should_compile/T11635. -We don't want to reject it because of the forall in beta's kind,-but (see Note [Occurrence checking: look inside kinds]) we do-need to look in beta's kind. So we carry a flag saying if a 'forall'-is OK, and switch the flag on when stepping inside a kind.+We don't want to reject it because of the forall in beta's kind, but+(see Note [Occurrence checking: look inside kinds] in GHC.Core.Type)+we do need to look in beta's kind. So we carry a flag saying if a+'forall' is OK, and switch the flag on when stepping inside a kind. Why is it OK? Why does it not count as impredicative polymorphism? The reason foralls are bad is because we reply on "seeing" foralls@@ -2197,6 +2017,7 @@ | tv == tv' = MTVU_Occurs | otherwise = fast_check_occ (tyVarKind tv') -- See Note [Occurrence checking: look inside kinds]+ -- in GHC.Core.Type fast_check (TyConApp tc tys) | bad_tc tc = MTVU_Bad
compiler/GHC/Tc/Utils/Zonk.hs view
@@ -825,12 +825,11 @@ new_ms <- zonkMatchGroup env zonkLExpr ms return (HsCase x new_expr new_ms) -zonkExpr env (HsIf x fun e1 e2 e3)- = do (env1, new_fun) <- zonkSyntaxExpr env fun- new_e1 <- zonkLExpr env1 e1- new_e2 <- zonkLExpr env1 e2- new_e3 <- zonkLExpr env1 e3- return (HsIf x new_fun new_e1 new_e2 new_e3)+zonkExpr env (HsIf x e1 e2 e3)+ = do new_e1 <- zonkLExpr env e1+ new_e2 <- zonkLExpr env e2+ new_e3 <- zonkLExpr env e3+ return (HsIf x new_e1 new_e2 new_e3) zonkExpr env (HsMultiIf ty alts) = do { alts' <- mapM (wrapLocM zonk_alt) alts@@ -907,10 +906,13 @@ zonkExpr env (HsStatic fvs expr) = HsStatic fvs <$> zonkLExpr env expr -zonkExpr env (XExpr (HsWrap co_fn expr))+zonkExpr env (XExpr (WrapExpr (HsWrap co_fn expr))) = do (env1, new_co_fn) <- zonkCoFn env co_fn new_expr <- zonkExpr env1 expr- return (XExpr (HsWrap new_co_fn new_expr))+ return (XExpr (WrapExpr (HsWrap new_co_fn new_expr)))++zonkExpr env (XExpr (ExpansionExpr (HsExpanded a b)))+ = XExpr . ExpansionExpr . HsExpanded a <$> zonkExpr env b zonkExpr _ e@(HsUnboundVar {}) = return e
compiler/GHC/ThToHs.hs view
@@ -270,7 +270,7 @@ <+> text "are not allowed:") $$ (Outputable.ppr adts')) ; returnJustL $ TyClD noExtField $- ClassDecl { tcdCExt = noExtField+ ClassDecl { tcdCExt = NoLayoutInfo , tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs' , tcdFixity = Prefix , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-version: 0.20200704+version: 0.20200801 license: BSD3 license-file: LICENSE category: Development@@ -22,9 +22,6 @@ ghc-lib/stage0/lib/ghcplatform.h ghc-lib/stage0/lib/ghcversion.h ghc-lib/stage0/lib/DerivedConstants.h- ghc-lib/stage0/lib/GHCConstantsHaskellExports.hs- ghc-lib/stage0/lib/GHCConstantsHaskellType.hs- ghc-lib/stage0/lib/GHCConstantsHaskellWrappers.hs ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl ghc-lib/stage0/compiler/build/primop-code-size.hs-incl ghc-lib/stage0/compiler/build/primop-commutable.hs-incl@@ -41,13 +38,13 @@ ghc-lib/stage0/compiler/build/primop-vector-tys.hs-incl ghc-lib/stage0/compiler/build/primop-vector-uniques.hs-incl ghc-lib/stage0/compiler/build/primop-docs.hs-incl+ ghc-lib/stage0/compiler/build/GHC/Platform/Constants.hs includes/ghcconfig.h includes/MachDeps.h includes/stg/MachRegs.h includes/CodeGen.Platform.hs compiler/GhclibHsVersions.h compiler/Unique.h-tested-with: GHC==8.10.1, GHC==8.8.2, GHC==8.6.5, GHC==8.4.4 source-repository head type: git location: git@github.com:digital-asset/ghc-lib.git@@ -70,7 +67,7 @@ build-depends: Win32 build-depends: ghc-prim > 0.2 && < 0.7,- base >= 4.11 && < 4.15,+ base >= 4.12 && < 4.15, containers >= 0.5 && < 0.7, bytestring >= 0.9 && < 0.11, binary == 0.8.*,@@ -84,7 +81,7 @@ process >= 1 && < 1.7, hpc == 0.6.*, exceptions == 0.10.*,- ghc-lib-parser == 0.20200704+ ghc-lib-parser == 0.20200801 build-tools: alex >= 3.1, happy >= 1.19.4 other-extensions: BangPatterns@@ -203,6 +200,7 @@ GHC.Data.Stream, GHC.Data.StringBuffer, GHC.Data.TrieMap,+ GHC.Driver.Backend, GHC.Driver.Backpack.Syntax, GHC.Driver.CmdLine, GHC.Driver.Flags,@@ -213,7 +211,6 @@ GHC.Driver.Plugins, GHC.Driver.Session, GHC.Driver.Types,- GHC.Driver.Ways, GHC.Exts.Heap, GHC.Exts.Heap.ClosureTypes, GHC.Exts.Heap.Closures,@@ -254,13 +251,17 @@ GHC.Platform, GHC.Platform.ARM, GHC.Platform.ARM64,+ GHC.Platform.ArchOS,+ GHC.Platform.Constants, GHC.Platform.NoRegs, GHC.Platform.PPC,+ GHC.Platform.Profile, GHC.Platform.Reg, GHC.Platform.Reg.Class, GHC.Platform.Regs, GHC.Platform.S390X, GHC.Platform.SPARC,+ GHC.Platform.Ways, GHC.Platform.X86, GHC.Platform.X86_64, GHC.Prelude,@@ -362,6 +363,7 @@ Paths_ghc_lib GHC GHC.Builtin.Names.TH+ GHC.Builtin.RebindableNames GHC.Builtin.Types.Literals GHC.Builtin.Utils GHC.ByteCode.Asm@@ -432,6 +434,7 @@ GHC.CmmToAsm.Reg.Linear.X86_64 GHC.CmmToAsm.Reg.Liveness GHC.CmmToAsm.Reg.Target+ GHC.CmmToAsm.Reg.Utils GHC.CmmToAsm.SPARC.AddrMode GHC.CmmToAsm.SPARC.Base GHC.CmmToAsm.SPARC.CodeGen@@ -565,7 +568,6 @@ GHC.Runtime.Linker GHC.Runtime.Loader GHC.Settings.IO- GHC.Settings.Platform GHC.Settings.Utils GHC.Stg.CSE GHC.Stg.DepAnal@@ -663,4 +665,5 @@ GHCi.Signals GHCi.StaticPtrTable GHCi.TH+ Language.Haskell.TH.CodeDo Language.Haskell.TH.Quote
+ ghc-lib/stage0/compiler/build/GHC/Platform/Constants.hs view
@@ -0,0 +1,135 @@+module GHC.Platform.Constants where++import Prelude++data PlatformConstants = PlatformConstants {+ pc_CONTROL_GROUP_CONST_291 :: Int,+ pc_STD_HDR_SIZE :: Int,+ pc_PROF_HDR_SIZE :: Int,+ pc_BLOCK_SIZE :: Int,+ pc_BLOCKS_PER_MBLOCK :: Int,+ pc_TICKY_BIN_COUNT :: Int,+ pc_OFFSET_StgRegTable_rR1 :: Int,+ pc_OFFSET_StgRegTable_rR2 :: Int,+ pc_OFFSET_StgRegTable_rR3 :: Int,+ pc_OFFSET_StgRegTable_rR4 :: Int,+ pc_OFFSET_StgRegTable_rR5 :: Int,+ pc_OFFSET_StgRegTable_rR6 :: Int,+ pc_OFFSET_StgRegTable_rR7 :: Int,+ pc_OFFSET_StgRegTable_rR8 :: Int,+ pc_OFFSET_StgRegTable_rR9 :: Int,+ pc_OFFSET_StgRegTable_rR10 :: Int,+ pc_OFFSET_StgRegTable_rF1 :: Int,+ pc_OFFSET_StgRegTable_rF2 :: Int,+ pc_OFFSET_StgRegTable_rF3 :: Int,+ pc_OFFSET_StgRegTable_rF4 :: Int,+ pc_OFFSET_StgRegTable_rF5 :: Int,+ pc_OFFSET_StgRegTable_rF6 :: Int,+ pc_OFFSET_StgRegTable_rD1 :: Int,+ pc_OFFSET_StgRegTable_rD2 :: Int,+ pc_OFFSET_StgRegTable_rD3 :: Int,+ pc_OFFSET_StgRegTable_rD4 :: Int,+ pc_OFFSET_StgRegTable_rD5 :: Int,+ pc_OFFSET_StgRegTable_rD6 :: Int,+ pc_OFFSET_StgRegTable_rXMM1 :: Int,+ pc_OFFSET_StgRegTable_rXMM2 :: Int,+ pc_OFFSET_StgRegTable_rXMM3 :: Int,+ pc_OFFSET_StgRegTable_rXMM4 :: Int,+ pc_OFFSET_StgRegTable_rXMM5 :: Int,+ pc_OFFSET_StgRegTable_rXMM6 :: Int,+ pc_OFFSET_StgRegTable_rYMM1 :: Int,+ pc_OFFSET_StgRegTable_rYMM2 :: Int,+ pc_OFFSET_StgRegTable_rYMM3 :: Int,+ pc_OFFSET_StgRegTable_rYMM4 :: Int,+ pc_OFFSET_StgRegTable_rYMM5 :: Int,+ pc_OFFSET_StgRegTable_rYMM6 :: Int,+ pc_OFFSET_StgRegTable_rZMM1 :: Int,+ pc_OFFSET_StgRegTable_rZMM2 :: Int,+ pc_OFFSET_StgRegTable_rZMM3 :: Int,+ pc_OFFSET_StgRegTable_rZMM4 :: Int,+ pc_OFFSET_StgRegTable_rZMM5 :: Int,+ pc_OFFSET_StgRegTable_rZMM6 :: Int,+ pc_OFFSET_StgRegTable_rL1 :: Int,+ pc_OFFSET_StgRegTable_rSp :: Int,+ pc_OFFSET_StgRegTable_rSpLim :: Int,+ pc_OFFSET_StgRegTable_rHp :: Int,+ pc_OFFSET_StgRegTable_rHpLim :: Int,+ pc_OFFSET_StgRegTable_rCCCS :: Int,+ pc_OFFSET_StgRegTable_rCurrentTSO :: Int,+ pc_OFFSET_StgRegTable_rCurrentNursery :: Int,+ pc_OFFSET_StgRegTable_rHpAlloc :: Int,+ pc_OFFSET_stgEagerBlackholeInfo :: Int,+ pc_OFFSET_stgGCEnter1 :: Int,+ pc_OFFSET_stgGCFun :: Int,+ pc_OFFSET_Capability_r :: Int,+ pc_OFFSET_bdescr_start :: Int,+ pc_OFFSET_bdescr_free :: Int,+ pc_OFFSET_bdescr_blocks :: Int,+ pc_OFFSET_bdescr_flags :: Int,+ pc_SIZEOF_CostCentreStack :: Int,+ pc_OFFSET_CostCentreStack_mem_alloc :: Int,+ pc_REP_CostCentreStack_mem_alloc :: Int,+ pc_OFFSET_CostCentreStack_scc_count :: Int,+ pc_REP_CostCentreStack_scc_count :: Int,+ pc_OFFSET_StgHeader_ccs :: Int,+ pc_OFFSET_StgHeader_ldvw :: Int,+ pc_SIZEOF_StgSMPThunkHeader :: Int,+ pc_OFFSET_StgEntCounter_allocs :: Int,+ pc_REP_StgEntCounter_allocs :: Int,+ pc_OFFSET_StgEntCounter_allocd :: Int,+ pc_REP_StgEntCounter_allocd :: Int,+ pc_OFFSET_StgEntCounter_registeredp :: Int,+ pc_OFFSET_StgEntCounter_link :: Int,+ pc_OFFSET_StgEntCounter_entry_count :: Int,+ pc_SIZEOF_StgUpdateFrame_NoHdr :: Int,+ pc_SIZEOF_StgMutArrPtrs_NoHdr :: Int,+ pc_OFFSET_StgMutArrPtrs_ptrs :: Int,+ pc_OFFSET_StgMutArrPtrs_size :: Int,+ pc_SIZEOF_StgSmallMutArrPtrs_NoHdr :: Int,+ pc_OFFSET_StgSmallMutArrPtrs_ptrs :: Int,+ pc_SIZEOF_StgArrBytes_NoHdr :: Int,+ pc_OFFSET_StgArrBytes_bytes :: Int,+ pc_OFFSET_StgTSO_alloc_limit :: Int,+ pc_OFFSET_StgTSO_cccs :: Int,+ pc_OFFSET_StgTSO_stackobj :: Int,+ pc_OFFSET_StgStack_sp :: Int,+ pc_OFFSET_StgStack_stack :: Int,+ pc_OFFSET_StgUpdateFrame_updatee :: Int,+ pc_OFFSET_StgFunInfoExtraFwd_arity :: Int,+ pc_REP_StgFunInfoExtraFwd_arity :: Int,+ pc_SIZEOF_StgFunInfoExtraRev :: Int,+ pc_OFFSET_StgFunInfoExtraRev_arity :: Int,+ pc_REP_StgFunInfoExtraRev_arity :: Int,+ pc_MAX_SPEC_SELECTEE_SIZE :: Int,+ pc_MAX_SPEC_AP_SIZE :: Int,+ pc_MIN_PAYLOAD_SIZE :: Int,+ pc_MIN_INTLIKE :: Int,+ pc_MAX_INTLIKE :: Int,+ pc_MIN_CHARLIKE :: Int,+ pc_MAX_CHARLIKE :: Int,+ pc_MUT_ARR_PTRS_CARD_BITS :: Int,+ pc_MAX_Vanilla_REG :: Int,+ pc_MAX_Float_REG :: Int,+ pc_MAX_Double_REG :: Int,+ pc_MAX_Long_REG :: Int,+ pc_MAX_XMM_REG :: Int,+ pc_MAX_Real_Vanilla_REG :: Int,+ pc_MAX_Real_Float_REG :: Int,+ pc_MAX_Real_Double_REG :: Int,+ pc_MAX_Real_XMM_REG :: Int,+ pc_MAX_Real_Long_REG :: Int,+ pc_RESERVED_C_STACK_BYTES :: Int,+ pc_RESERVED_STACK_WORDS :: Int,+ pc_AP_STACK_SPLIM :: Int,+ pc_WORD_SIZE :: Int,+ pc_CINT_SIZE :: Int,+ pc_CLONG_SIZE :: Int,+ pc_CLONG_LONG_SIZE :: Int,+ pc_BITMAP_BITS_SHIFT :: Int,+ pc_TAG_BITS :: Int,+ pc_DYNAMIC_BY_DEFAULT :: Bool,+ pc_LDV_SHIFT :: Int,+ pc_ILDV_CREATE_MASK :: Integer,+ pc_ILDV_STATE_CREATE :: Integer,+ pc_ILDV_STATE_USE :: Integer+ } deriving (Show,Read,Eq)
ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl view
@@ -490,6 +490,10 @@ | TryReadMVarOp | SameMVarOp | IsEmptyMVarOp+ | NewIOPortrOp+ | ReadIOPortOp+ | WriteIOPortOp+ | SameIOPortOp | DelayOp | WaitReadOp | WaitWriteOp
ghc-lib/stage0/compiler/build/primop-docs.hs-incl view
@@ -189,6 +189,10 @@ , ("readMVar#","If @MVar\\#@ is empty, block until it becomes full.\n Then read its contents without modifying the MVar, without possibility\n of intervention from other threads.") , ("tryReadMVar#","If @MVar\\#@ is empty, immediately return with integer 0 and value undefined.\n Otherwise, return with integer 1 and contents of @MVar\\#@.") , ("isEmptyMVar#","Return 1 if @MVar\\#@ is empty; 0 otherwise.")+ , ("IOPort#"," A shared I/O port is almost the same as a @MVar\\#@!).\n The main difference is that IOPort has no deadlock detection or\n deadlock breaking code that forcibly releases the lock. ")+ , ("newIOPort#","Create new @IOPort\\#@; initially empty.")+ , ("readIOPort#","If @IOPort\\#@ is empty, block until it becomes full.\n Then remove and return its contents, and set it empty.")+ , ("writeIOPort#","If @IOPort\\#@ is full, immediately return with integer 0.\n Otherwise, store value arg as @IOPort\\#@'s new contents,\n and return with integer 1. ") , ("delay#","Sleep specified number of microseconds.") , ("waitRead#","Block until input is available on specified file descriptor.") , ("waitWrite#","Block until output is possible on specified file descriptor.")
ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl view
@@ -178,6 +178,9 @@ primOpHasSideEffects ReadMVarOp = True primOpHasSideEffects TryReadMVarOp = True primOpHasSideEffects IsEmptyMVarOp = True+primOpHasSideEffects NewIOPortrOp = True+primOpHasSideEffects ReadIOPortOp = True+primOpHasSideEffects WriteIOPortOp = True primOpHasSideEffects DelayOp = True primOpHasSideEffects WaitReadOp = True primOpHasSideEffects WaitWriteOp = True
ghc-lib/stage0/compiler/build/primop-list.hs-incl view
@@ -489,6 +489,10 @@ , TryReadMVarOp , SameMVarOp , IsEmptyMVarOp+ , NewIOPortrOp+ , ReadIOPortOp+ , WriteIOPortOp+ , SameIOPortOp , DelayOp , WaitReadOp , WaitWriteOp
ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl view
@@ -57,6 +57,9 @@ primOpOutOfLine ReadMVarOp = True primOpOutOfLine TryReadMVarOp = True primOpOutOfLine IsEmptyMVarOp = True+primOpOutOfLine NewIOPortrOp = True+primOpOutOfLine ReadIOPortOp = True+primOpOutOfLine WriteIOPortOp = True primOpOutOfLine DelayOp = True primOpOutOfLine WaitReadOp = True primOpOutOfLine WaitWriteOp = True
ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl view
@@ -489,6 +489,10 @@ primOpInfo TryReadMVarOp = mkGenPrimOp (fsLit "tryReadMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) primOpInfo SameMVarOp = mkGenPrimOp (fsLit "sameMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkMVarPrimTy deltaTy alphaTy] (intPrimTy) primOpInfo IsEmptyMVarOp = mkGenPrimOp (fsLit "isEmptyMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo NewIOPortrOp = mkGenPrimOp (fsLit "newIOPort#") [deltaTyVar, alphaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkIOPortPrimTy deltaTy alphaTy]))+primOpInfo ReadIOPortOp = mkGenPrimOp (fsLit "readIOPort#") [deltaTyVar, alphaTyVar] [mkIOPortPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo WriteIOPortOp = mkGenPrimOp (fsLit "writeIOPort#") [deltaTyVar, alphaTyVar] [mkIOPortPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo SameIOPortOp = mkGenPrimOp (fsLit "sameIOPort#") [deltaTyVar, alphaTyVar] [mkIOPortPrimTy deltaTy alphaTy, mkIOPortPrimTy deltaTy alphaTy] (intPrimTy) primOpInfo DelayOp = mkGenPrimOp (fsLit "delay#") [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WaitReadOp = mkGenPrimOp (fsLit "waitRead#") [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WaitWriteOp = mkGenPrimOp (fsLit "waitWrite#") [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
ghc-lib/stage0/compiler/build/primop-tag.hs-incl view
@@ -1,1209 +1,1213 @@ maxPrimOpTag :: Int-maxPrimOpTag = 1206-primOpTag :: PrimOp -> Int-primOpTag CharGtOp = 1-primOpTag CharGeOp = 2-primOpTag CharEqOp = 3-primOpTag CharNeOp = 4-primOpTag CharLtOp = 5-primOpTag CharLeOp = 6-primOpTag OrdOp = 7-primOpTag Int8Extend = 8-primOpTag Int8Narrow = 9-primOpTag Int8NegOp = 10-primOpTag Int8AddOp = 11-primOpTag Int8SubOp = 12-primOpTag Int8MulOp = 13-primOpTag Int8QuotOp = 14-primOpTag Int8RemOp = 15-primOpTag Int8QuotRemOp = 16-primOpTag Int8EqOp = 17-primOpTag Int8GeOp = 18-primOpTag Int8GtOp = 19-primOpTag Int8LeOp = 20-primOpTag Int8LtOp = 21-primOpTag Int8NeOp = 22-primOpTag Word8Extend = 23-primOpTag Word8Narrow = 24-primOpTag Word8NotOp = 25-primOpTag Word8AddOp = 26-primOpTag Word8SubOp = 27-primOpTag Word8MulOp = 28-primOpTag Word8QuotOp = 29-primOpTag Word8RemOp = 30-primOpTag Word8QuotRemOp = 31-primOpTag Word8EqOp = 32-primOpTag Word8GeOp = 33-primOpTag Word8GtOp = 34-primOpTag Word8LeOp = 35-primOpTag Word8LtOp = 36-primOpTag Word8NeOp = 37-primOpTag Int16Extend = 38-primOpTag Int16Narrow = 39-primOpTag Int16NegOp = 40-primOpTag Int16AddOp = 41-primOpTag Int16SubOp = 42-primOpTag Int16MulOp = 43-primOpTag Int16QuotOp = 44-primOpTag Int16RemOp = 45-primOpTag Int16QuotRemOp = 46-primOpTag Int16EqOp = 47-primOpTag Int16GeOp = 48-primOpTag Int16GtOp = 49-primOpTag Int16LeOp = 50-primOpTag Int16LtOp = 51-primOpTag Int16NeOp = 52-primOpTag Word16Extend = 53-primOpTag Word16Narrow = 54-primOpTag Word16NotOp = 55-primOpTag Word16AddOp = 56-primOpTag Word16SubOp = 57-primOpTag Word16MulOp = 58-primOpTag Word16QuotOp = 59-primOpTag Word16RemOp = 60-primOpTag Word16QuotRemOp = 61-primOpTag Word16EqOp = 62-primOpTag Word16GeOp = 63-primOpTag Word16GtOp = 64-primOpTag Word16LeOp = 65-primOpTag Word16LtOp = 66-primOpTag Word16NeOp = 67-primOpTag IntAddOp = 68-primOpTag IntSubOp = 69-primOpTag IntMulOp = 70-primOpTag IntMul2Op = 71-primOpTag IntMulMayOfloOp = 72-primOpTag IntQuotOp = 73-primOpTag IntRemOp = 74-primOpTag IntQuotRemOp = 75-primOpTag AndIOp = 76-primOpTag OrIOp = 77-primOpTag XorIOp = 78-primOpTag NotIOp = 79-primOpTag IntNegOp = 80-primOpTag IntAddCOp = 81-primOpTag IntSubCOp = 82-primOpTag IntGtOp = 83-primOpTag IntGeOp = 84-primOpTag IntEqOp = 85-primOpTag IntNeOp = 86-primOpTag IntLtOp = 87-primOpTag IntLeOp = 88-primOpTag ChrOp = 89-primOpTag Int2WordOp = 90-primOpTag Int2FloatOp = 91-primOpTag Int2DoubleOp = 92-primOpTag Word2FloatOp = 93-primOpTag Word2DoubleOp = 94-primOpTag ISllOp = 95-primOpTag ISraOp = 96-primOpTag ISrlOp = 97-primOpTag WordAddOp = 98-primOpTag WordAddCOp = 99-primOpTag WordSubCOp = 100-primOpTag WordAdd2Op = 101-primOpTag WordSubOp = 102-primOpTag WordMulOp = 103-primOpTag WordMul2Op = 104-primOpTag WordQuotOp = 105-primOpTag WordRemOp = 106-primOpTag WordQuotRemOp = 107-primOpTag WordQuotRem2Op = 108-primOpTag AndOp = 109-primOpTag OrOp = 110-primOpTag XorOp = 111-primOpTag NotOp = 112-primOpTag SllOp = 113-primOpTag SrlOp = 114-primOpTag Word2IntOp = 115-primOpTag WordGtOp = 116-primOpTag WordGeOp = 117-primOpTag WordEqOp = 118-primOpTag WordNeOp = 119-primOpTag WordLtOp = 120-primOpTag WordLeOp = 121-primOpTag PopCnt8Op = 122-primOpTag PopCnt16Op = 123-primOpTag PopCnt32Op = 124-primOpTag PopCnt64Op = 125-primOpTag PopCntOp = 126-primOpTag Pdep8Op = 127-primOpTag Pdep16Op = 128-primOpTag Pdep32Op = 129-primOpTag Pdep64Op = 130-primOpTag PdepOp = 131-primOpTag Pext8Op = 132-primOpTag Pext16Op = 133-primOpTag Pext32Op = 134-primOpTag Pext64Op = 135-primOpTag PextOp = 136-primOpTag Clz8Op = 137-primOpTag Clz16Op = 138-primOpTag Clz32Op = 139-primOpTag Clz64Op = 140-primOpTag ClzOp = 141-primOpTag Ctz8Op = 142-primOpTag Ctz16Op = 143-primOpTag Ctz32Op = 144-primOpTag Ctz64Op = 145-primOpTag CtzOp = 146-primOpTag BSwap16Op = 147-primOpTag BSwap32Op = 148-primOpTag BSwap64Op = 149-primOpTag BSwapOp = 150-primOpTag BRev8Op = 151-primOpTag BRev16Op = 152-primOpTag BRev32Op = 153-primOpTag BRev64Op = 154-primOpTag BRevOp = 155-primOpTag Narrow8IntOp = 156-primOpTag Narrow16IntOp = 157-primOpTag Narrow32IntOp = 158-primOpTag Narrow8WordOp = 159-primOpTag Narrow16WordOp = 160-primOpTag Narrow32WordOp = 161-primOpTag DoubleGtOp = 162-primOpTag DoubleGeOp = 163-primOpTag DoubleEqOp = 164-primOpTag DoubleNeOp = 165-primOpTag DoubleLtOp = 166-primOpTag DoubleLeOp = 167-primOpTag DoubleAddOp = 168-primOpTag DoubleSubOp = 169-primOpTag DoubleMulOp = 170-primOpTag DoubleDivOp = 171-primOpTag DoubleNegOp = 172-primOpTag DoubleFabsOp = 173-primOpTag Double2IntOp = 174-primOpTag Double2FloatOp = 175-primOpTag DoubleExpOp = 176-primOpTag DoubleExpM1Op = 177-primOpTag DoubleLogOp = 178-primOpTag DoubleLog1POp = 179-primOpTag DoubleSqrtOp = 180-primOpTag DoubleSinOp = 181-primOpTag DoubleCosOp = 182-primOpTag DoubleTanOp = 183-primOpTag DoubleAsinOp = 184-primOpTag DoubleAcosOp = 185-primOpTag DoubleAtanOp = 186-primOpTag DoubleSinhOp = 187-primOpTag DoubleCoshOp = 188-primOpTag DoubleTanhOp = 189-primOpTag DoubleAsinhOp = 190-primOpTag DoubleAcoshOp = 191-primOpTag DoubleAtanhOp = 192-primOpTag DoublePowerOp = 193-primOpTag DoubleDecode_2IntOp = 194-primOpTag DoubleDecode_Int64Op = 195-primOpTag FloatGtOp = 196-primOpTag FloatGeOp = 197-primOpTag FloatEqOp = 198-primOpTag FloatNeOp = 199-primOpTag FloatLtOp = 200-primOpTag FloatLeOp = 201-primOpTag FloatAddOp = 202-primOpTag FloatSubOp = 203-primOpTag FloatMulOp = 204-primOpTag FloatDivOp = 205-primOpTag FloatNegOp = 206-primOpTag FloatFabsOp = 207-primOpTag Float2IntOp = 208-primOpTag FloatExpOp = 209-primOpTag FloatExpM1Op = 210-primOpTag FloatLogOp = 211-primOpTag FloatLog1POp = 212-primOpTag FloatSqrtOp = 213-primOpTag FloatSinOp = 214-primOpTag FloatCosOp = 215-primOpTag FloatTanOp = 216-primOpTag FloatAsinOp = 217-primOpTag FloatAcosOp = 218-primOpTag FloatAtanOp = 219-primOpTag FloatSinhOp = 220-primOpTag FloatCoshOp = 221-primOpTag FloatTanhOp = 222-primOpTag FloatAsinhOp = 223-primOpTag FloatAcoshOp = 224-primOpTag FloatAtanhOp = 225-primOpTag FloatPowerOp = 226-primOpTag Float2DoubleOp = 227-primOpTag FloatDecode_IntOp = 228-primOpTag NewArrayOp = 229-primOpTag SameMutableArrayOp = 230-primOpTag ReadArrayOp = 231-primOpTag WriteArrayOp = 232-primOpTag SizeofArrayOp = 233-primOpTag SizeofMutableArrayOp = 234-primOpTag IndexArrayOp = 235-primOpTag UnsafeFreezeArrayOp = 236-primOpTag UnsafeThawArrayOp = 237-primOpTag CopyArrayOp = 238-primOpTag CopyMutableArrayOp = 239-primOpTag CloneArrayOp = 240-primOpTag CloneMutableArrayOp = 241-primOpTag FreezeArrayOp = 242-primOpTag ThawArrayOp = 243-primOpTag CasArrayOp = 244-primOpTag NewSmallArrayOp = 245-primOpTag SameSmallMutableArrayOp = 246-primOpTag ShrinkSmallMutableArrayOp_Char = 247-primOpTag ReadSmallArrayOp = 248-primOpTag WriteSmallArrayOp = 249-primOpTag SizeofSmallArrayOp = 250-primOpTag SizeofSmallMutableArrayOp = 251-primOpTag GetSizeofSmallMutableArrayOp = 252-primOpTag IndexSmallArrayOp = 253-primOpTag UnsafeFreezeSmallArrayOp = 254-primOpTag UnsafeThawSmallArrayOp = 255-primOpTag CopySmallArrayOp = 256-primOpTag CopySmallMutableArrayOp = 257-primOpTag CloneSmallArrayOp = 258-primOpTag CloneSmallMutableArrayOp = 259-primOpTag FreezeSmallArrayOp = 260-primOpTag ThawSmallArrayOp = 261-primOpTag CasSmallArrayOp = 262-primOpTag NewByteArrayOp_Char = 263-primOpTag NewPinnedByteArrayOp_Char = 264-primOpTag NewAlignedPinnedByteArrayOp_Char = 265-primOpTag MutableByteArrayIsPinnedOp = 266-primOpTag ByteArrayIsPinnedOp = 267-primOpTag ByteArrayContents_Char = 268-primOpTag SameMutableByteArrayOp = 269-primOpTag ShrinkMutableByteArrayOp_Char = 270-primOpTag ResizeMutableByteArrayOp_Char = 271-primOpTag UnsafeFreezeByteArrayOp = 272-primOpTag SizeofByteArrayOp = 273-primOpTag SizeofMutableByteArrayOp = 274-primOpTag GetSizeofMutableByteArrayOp = 275-primOpTag IndexByteArrayOp_Char = 276-primOpTag IndexByteArrayOp_WideChar = 277-primOpTag IndexByteArrayOp_Int = 278-primOpTag IndexByteArrayOp_Word = 279-primOpTag IndexByteArrayOp_Addr = 280-primOpTag IndexByteArrayOp_Float = 281-primOpTag IndexByteArrayOp_Double = 282-primOpTag IndexByteArrayOp_StablePtr = 283-primOpTag IndexByteArrayOp_Int8 = 284-primOpTag IndexByteArrayOp_Int16 = 285-primOpTag IndexByteArrayOp_Int32 = 286-primOpTag IndexByteArrayOp_Int64 = 287-primOpTag IndexByteArrayOp_Word8 = 288-primOpTag IndexByteArrayOp_Word16 = 289-primOpTag IndexByteArrayOp_Word32 = 290-primOpTag IndexByteArrayOp_Word64 = 291-primOpTag IndexByteArrayOp_Word8AsChar = 292-primOpTag IndexByteArrayOp_Word8AsWideChar = 293-primOpTag IndexByteArrayOp_Word8AsAddr = 294-primOpTag IndexByteArrayOp_Word8AsFloat = 295-primOpTag IndexByteArrayOp_Word8AsDouble = 296-primOpTag IndexByteArrayOp_Word8AsStablePtr = 297-primOpTag IndexByteArrayOp_Word8AsInt16 = 298-primOpTag IndexByteArrayOp_Word8AsInt32 = 299-primOpTag IndexByteArrayOp_Word8AsInt64 = 300-primOpTag IndexByteArrayOp_Word8AsInt = 301-primOpTag IndexByteArrayOp_Word8AsWord16 = 302-primOpTag IndexByteArrayOp_Word8AsWord32 = 303-primOpTag IndexByteArrayOp_Word8AsWord64 = 304-primOpTag IndexByteArrayOp_Word8AsWord = 305-primOpTag ReadByteArrayOp_Char = 306-primOpTag ReadByteArrayOp_WideChar = 307-primOpTag ReadByteArrayOp_Int = 308-primOpTag ReadByteArrayOp_Word = 309-primOpTag ReadByteArrayOp_Addr = 310-primOpTag ReadByteArrayOp_Float = 311-primOpTag ReadByteArrayOp_Double = 312-primOpTag ReadByteArrayOp_StablePtr = 313-primOpTag ReadByteArrayOp_Int8 = 314-primOpTag ReadByteArrayOp_Int16 = 315-primOpTag ReadByteArrayOp_Int32 = 316-primOpTag ReadByteArrayOp_Int64 = 317-primOpTag ReadByteArrayOp_Word8 = 318-primOpTag ReadByteArrayOp_Word16 = 319-primOpTag ReadByteArrayOp_Word32 = 320-primOpTag ReadByteArrayOp_Word64 = 321-primOpTag ReadByteArrayOp_Word8AsChar = 322-primOpTag ReadByteArrayOp_Word8AsWideChar = 323-primOpTag ReadByteArrayOp_Word8AsAddr = 324-primOpTag ReadByteArrayOp_Word8AsFloat = 325-primOpTag ReadByteArrayOp_Word8AsDouble = 326-primOpTag ReadByteArrayOp_Word8AsStablePtr = 327-primOpTag ReadByteArrayOp_Word8AsInt16 = 328-primOpTag ReadByteArrayOp_Word8AsInt32 = 329-primOpTag ReadByteArrayOp_Word8AsInt64 = 330-primOpTag ReadByteArrayOp_Word8AsInt = 331-primOpTag ReadByteArrayOp_Word8AsWord16 = 332-primOpTag ReadByteArrayOp_Word8AsWord32 = 333-primOpTag ReadByteArrayOp_Word8AsWord64 = 334-primOpTag ReadByteArrayOp_Word8AsWord = 335-primOpTag WriteByteArrayOp_Char = 336-primOpTag WriteByteArrayOp_WideChar = 337-primOpTag WriteByteArrayOp_Int = 338-primOpTag WriteByteArrayOp_Word = 339-primOpTag WriteByteArrayOp_Addr = 340-primOpTag WriteByteArrayOp_Float = 341-primOpTag WriteByteArrayOp_Double = 342-primOpTag WriteByteArrayOp_StablePtr = 343-primOpTag WriteByteArrayOp_Int8 = 344-primOpTag WriteByteArrayOp_Int16 = 345-primOpTag WriteByteArrayOp_Int32 = 346-primOpTag WriteByteArrayOp_Int64 = 347-primOpTag WriteByteArrayOp_Word8 = 348-primOpTag WriteByteArrayOp_Word16 = 349-primOpTag WriteByteArrayOp_Word32 = 350-primOpTag WriteByteArrayOp_Word64 = 351-primOpTag WriteByteArrayOp_Word8AsChar = 352-primOpTag WriteByteArrayOp_Word8AsWideChar = 353-primOpTag WriteByteArrayOp_Word8AsAddr = 354-primOpTag WriteByteArrayOp_Word8AsFloat = 355-primOpTag WriteByteArrayOp_Word8AsDouble = 356-primOpTag WriteByteArrayOp_Word8AsStablePtr = 357-primOpTag WriteByteArrayOp_Word8AsInt16 = 358-primOpTag WriteByteArrayOp_Word8AsInt32 = 359-primOpTag WriteByteArrayOp_Word8AsInt64 = 360-primOpTag WriteByteArrayOp_Word8AsInt = 361-primOpTag WriteByteArrayOp_Word8AsWord16 = 362-primOpTag WriteByteArrayOp_Word8AsWord32 = 363-primOpTag WriteByteArrayOp_Word8AsWord64 = 364-primOpTag WriteByteArrayOp_Word8AsWord = 365-primOpTag CompareByteArraysOp = 366-primOpTag CopyByteArrayOp = 367-primOpTag CopyMutableByteArrayOp = 368-primOpTag CopyByteArrayToAddrOp = 369-primOpTag CopyMutableByteArrayToAddrOp = 370-primOpTag CopyAddrToByteArrayOp = 371-primOpTag SetByteArrayOp = 372-primOpTag AtomicReadByteArrayOp_Int = 373-primOpTag AtomicWriteByteArrayOp_Int = 374-primOpTag CasByteArrayOp_Int = 375-primOpTag FetchAddByteArrayOp_Int = 376-primOpTag FetchSubByteArrayOp_Int = 377-primOpTag FetchAndByteArrayOp_Int = 378-primOpTag FetchNandByteArrayOp_Int = 379-primOpTag FetchOrByteArrayOp_Int = 380-primOpTag FetchXorByteArrayOp_Int = 381-primOpTag NewArrayArrayOp = 382-primOpTag SameMutableArrayArrayOp = 383-primOpTag UnsafeFreezeArrayArrayOp = 384-primOpTag SizeofArrayArrayOp = 385-primOpTag SizeofMutableArrayArrayOp = 386-primOpTag IndexArrayArrayOp_ByteArray = 387-primOpTag IndexArrayArrayOp_ArrayArray = 388-primOpTag ReadArrayArrayOp_ByteArray = 389-primOpTag ReadArrayArrayOp_MutableByteArray = 390-primOpTag ReadArrayArrayOp_ArrayArray = 391-primOpTag ReadArrayArrayOp_MutableArrayArray = 392-primOpTag WriteArrayArrayOp_ByteArray = 393-primOpTag WriteArrayArrayOp_MutableByteArray = 394-primOpTag WriteArrayArrayOp_ArrayArray = 395-primOpTag WriteArrayArrayOp_MutableArrayArray = 396-primOpTag CopyArrayArrayOp = 397-primOpTag CopyMutableArrayArrayOp = 398-primOpTag AddrAddOp = 399-primOpTag AddrSubOp = 400-primOpTag AddrRemOp = 401-primOpTag Addr2IntOp = 402-primOpTag Int2AddrOp = 403-primOpTag AddrGtOp = 404-primOpTag AddrGeOp = 405-primOpTag AddrEqOp = 406-primOpTag AddrNeOp = 407-primOpTag AddrLtOp = 408-primOpTag AddrLeOp = 409-primOpTag IndexOffAddrOp_Char = 410-primOpTag IndexOffAddrOp_WideChar = 411-primOpTag IndexOffAddrOp_Int = 412-primOpTag IndexOffAddrOp_Word = 413-primOpTag IndexOffAddrOp_Addr = 414-primOpTag IndexOffAddrOp_Float = 415-primOpTag IndexOffAddrOp_Double = 416-primOpTag IndexOffAddrOp_StablePtr = 417-primOpTag IndexOffAddrOp_Int8 = 418-primOpTag IndexOffAddrOp_Int16 = 419-primOpTag IndexOffAddrOp_Int32 = 420-primOpTag IndexOffAddrOp_Int64 = 421-primOpTag IndexOffAddrOp_Word8 = 422-primOpTag IndexOffAddrOp_Word16 = 423-primOpTag IndexOffAddrOp_Word32 = 424-primOpTag IndexOffAddrOp_Word64 = 425-primOpTag ReadOffAddrOp_Char = 426-primOpTag ReadOffAddrOp_WideChar = 427-primOpTag ReadOffAddrOp_Int = 428-primOpTag ReadOffAddrOp_Word = 429-primOpTag ReadOffAddrOp_Addr = 430-primOpTag ReadOffAddrOp_Float = 431-primOpTag ReadOffAddrOp_Double = 432-primOpTag ReadOffAddrOp_StablePtr = 433-primOpTag ReadOffAddrOp_Int8 = 434-primOpTag ReadOffAddrOp_Int16 = 435-primOpTag ReadOffAddrOp_Int32 = 436-primOpTag ReadOffAddrOp_Int64 = 437-primOpTag ReadOffAddrOp_Word8 = 438-primOpTag ReadOffAddrOp_Word16 = 439-primOpTag ReadOffAddrOp_Word32 = 440-primOpTag ReadOffAddrOp_Word64 = 441-primOpTag WriteOffAddrOp_Char = 442-primOpTag WriteOffAddrOp_WideChar = 443-primOpTag WriteOffAddrOp_Int = 444-primOpTag WriteOffAddrOp_Word = 445-primOpTag WriteOffAddrOp_Addr = 446-primOpTag WriteOffAddrOp_Float = 447-primOpTag WriteOffAddrOp_Double = 448-primOpTag WriteOffAddrOp_StablePtr = 449-primOpTag WriteOffAddrOp_Int8 = 450-primOpTag WriteOffAddrOp_Int16 = 451-primOpTag WriteOffAddrOp_Int32 = 452-primOpTag WriteOffAddrOp_Int64 = 453-primOpTag WriteOffAddrOp_Word8 = 454-primOpTag WriteOffAddrOp_Word16 = 455-primOpTag WriteOffAddrOp_Word32 = 456-primOpTag WriteOffAddrOp_Word64 = 457-primOpTag InterlockedExchange_Addr = 458-primOpTag InterlockedExchange_Int = 459-primOpTag NewMutVarOp = 460-primOpTag ReadMutVarOp = 461-primOpTag WriteMutVarOp = 462-primOpTag SameMutVarOp = 463-primOpTag AtomicModifyMutVar2Op = 464-primOpTag AtomicModifyMutVar_Op = 465-primOpTag CasMutVarOp = 466-primOpTag CatchOp = 467-primOpTag RaiseOp = 468-primOpTag RaiseIOOp = 469-primOpTag MaskAsyncExceptionsOp = 470-primOpTag MaskUninterruptibleOp = 471-primOpTag UnmaskAsyncExceptionsOp = 472-primOpTag MaskStatus = 473-primOpTag AtomicallyOp = 474-primOpTag RetryOp = 475-primOpTag CatchRetryOp = 476-primOpTag CatchSTMOp = 477-primOpTag NewTVarOp = 478-primOpTag ReadTVarOp = 479-primOpTag ReadTVarIOOp = 480-primOpTag WriteTVarOp = 481-primOpTag SameTVarOp = 482-primOpTag NewMVarOp = 483-primOpTag TakeMVarOp = 484-primOpTag TryTakeMVarOp = 485-primOpTag PutMVarOp = 486-primOpTag TryPutMVarOp = 487-primOpTag ReadMVarOp = 488-primOpTag TryReadMVarOp = 489-primOpTag SameMVarOp = 490-primOpTag IsEmptyMVarOp = 491-primOpTag DelayOp = 492-primOpTag WaitReadOp = 493-primOpTag WaitWriteOp = 494-primOpTag ForkOp = 495-primOpTag ForkOnOp = 496-primOpTag KillThreadOp = 497-primOpTag YieldOp = 498-primOpTag MyThreadIdOp = 499-primOpTag LabelThreadOp = 500-primOpTag IsCurrentThreadBoundOp = 501-primOpTag NoDuplicateOp = 502-primOpTag ThreadStatusOp = 503-primOpTag MkWeakOp = 504-primOpTag MkWeakNoFinalizerOp = 505-primOpTag AddCFinalizerToWeakOp = 506-primOpTag DeRefWeakOp = 507-primOpTag FinalizeWeakOp = 508-primOpTag TouchOp = 509-primOpTag MakeStablePtrOp = 510-primOpTag DeRefStablePtrOp = 511-primOpTag EqStablePtrOp = 512-primOpTag MakeStableNameOp = 513-primOpTag EqStableNameOp = 514-primOpTag StableNameToIntOp = 515-primOpTag CompactNewOp = 516-primOpTag CompactResizeOp = 517-primOpTag CompactContainsOp = 518-primOpTag CompactContainsAnyOp = 519-primOpTag CompactGetFirstBlockOp = 520-primOpTag CompactGetNextBlockOp = 521-primOpTag CompactAllocateBlockOp = 522-primOpTag CompactFixupPointersOp = 523-primOpTag CompactAdd = 524-primOpTag CompactAddWithSharing = 525-primOpTag CompactSize = 526-primOpTag ReallyUnsafePtrEqualityOp = 527-primOpTag ParOp = 528-primOpTag SparkOp = 529-primOpTag SeqOp = 530-primOpTag GetSparkOp = 531-primOpTag NumSparks = 532-primOpTag DataToTagOp = 533-primOpTag TagToEnumOp = 534-primOpTag AddrToAnyOp = 535-primOpTag AnyToAddrOp = 536-primOpTag MkApUpd0_Op = 537-primOpTag NewBCOOp = 538-primOpTag UnpackClosureOp = 539-primOpTag ClosureSizeOp = 540-primOpTag GetApStackValOp = 541-primOpTag GetCCSOfOp = 542-primOpTag GetCurrentCCSOp = 543-primOpTag ClearCCSOp = 544-primOpTag TraceEventOp = 545-primOpTag TraceEventBinaryOp = 546-primOpTag TraceMarkerOp = 547-primOpTag SetThreadAllocationCounter = 548-primOpTag (VecBroadcastOp IntVec 16 W8) = 549-primOpTag (VecBroadcastOp IntVec 8 W16) = 550-primOpTag (VecBroadcastOp IntVec 4 W32) = 551-primOpTag (VecBroadcastOp IntVec 2 W64) = 552-primOpTag (VecBroadcastOp IntVec 32 W8) = 553-primOpTag (VecBroadcastOp IntVec 16 W16) = 554-primOpTag (VecBroadcastOp IntVec 8 W32) = 555-primOpTag (VecBroadcastOp IntVec 4 W64) = 556-primOpTag (VecBroadcastOp IntVec 64 W8) = 557-primOpTag (VecBroadcastOp IntVec 32 W16) = 558-primOpTag (VecBroadcastOp IntVec 16 W32) = 559-primOpTag (VecBroadcastOp IntVec 8 W64) = 560-primOpTag (VecBroadcastOp WordVec 16 W8) = 561-primOpTag (VecBroadcastOp WordVec 8 W16) = 562-primOpTag (VecBroadcastOp WordVec 4 W32) = 563-primOpTag (VecBroadcastOp WordVec 2 W64) = 564-primOpTag (VecBroadcastOp WordVec 32 W8) = 565-primOpTag (VecBroadcastOp WordVec 16 W16) = 566-primOpTag (VecBroadcastOp WordVec 8 W32) = 567-primOpTag (VecBroadcastOp WordVec 4 W64) = 568-primOpTag (VecBroadcastOp WordVec 64 W8) = 569-primOpTag (VecBroadcastOp WordVec 32 W16) = 570-primOpTag (VecBroadcastOp WordVec 16 W32) = 571-primOpTag (VecBroadcastOp WordVec 8 W64) = 572-primOpTag (VecBroadcastOp FloatVec 4 W32) = 573-primOpTag (VecBroadcastOp FloatVec 2 W64) = 574-primOpTag (VecBroadcastOp FloatVec 8 W32) = 575-primOpTag (VecBroadcastOp FloatVec 4 W64) = 576-primOpTag (VecBroadcastOp FloatVec 16 W32) = 577-primOpTag (VecBroadcastOp FloatVec 8 W64) = 578-primOpTag (VecPackOp IntVec 16 W8) = 579-primOpTag (VecPackOp IntVec 8 W16) = 580-primOpTag (VecPackOp IntVec 4 W32) = 581-primOpTag (VecPackOp IntVec 2 W64) = 582-primOpTag (VecPackOp IntVec 32 W8) = 583-primOpTag (VecPackOp IntVec 16 W16) = 584-primOpTag (VecPackOp IntVec 8 W32) = 585-primOpTag (VecPackOp IntVec 4 W64) = 586-primOpTag (VecPackOp IntVec 64 W8) = 587-primOpTag (VecPackOp IntVec 32 W16) = 588-primOpTag (VecPackOp IntVec 16 W32) = 589-primOpTag (VecPackOp IntVec 8 W64) = 590-primOpTag (VecPackOp WordVec 16 W8) = 591-primOpTag (VecPackOp WordVec 8 W16) = 592-primOpTag (VecPackOp WordVec 4 W32) = 593-primOpTag (VecPackOp WordVec 2 W64) = 594-primOpTag (VecPackOp WordVec 32 W8) = 595-primOpTag (VecPackOp WordVec 16 W16) = 596-primOpTag (VecPackOp WordVec 8 W32) = 597-primOpTag (VecPackOp WordVec 4 W64) = 598-primOpTag (VecPackOp WordVec 64 W8) = 599-primOpTag (VecPackOp WordVec 32 W16) = 600-primOpTag (VecPackOp WordVec 16 W32) = 601-primOpTag (VecPackOp WordVec 8 W64) = 602-primOpTag (VecPackOp FloatVec 4 W32) = 603-primOpTag (VecPackOp FloatVec 2 W64) = 604-primOpTag (VecPackOp FloatVec 8 W32) = 605-primOpTag (VecPackOp FloatVec 4 W64) = 606-primOpTag (VecPackOp FloatVec 16 W32) = 607-primOpTag (VecPackOp FloatVec 8 W64) = 608-primOpTag (VecUnpackOp IntVec 16 W8) = 609-primOpTag (VecUnpackOp IntVec 8 W16) = 610-primOpTag (VecUnpackOp IntVec 4 W32) = 611-primOpTag (VecUnpackOp IntVec 2 W64) = 612-primOpTag (VecUnpackOp IntVec 32 W8) = 613-primOpTag (VecUnpackOp IntVec 16 W16) = 614-primOpTag (VecUnpackOp IntVec 8 W32) = 615-primOpTag (VecUnpackOp IntVec 4 W64) = 616-primOpTag (VecUnpackOp IntVec 64 W8) = 617-primOpTag (VecUnpackOp IntVec 32 W16) = 618-primOpTag (VecUnpackOp IntVec 16 W32) = 619-primOpTag (VecUnpackOp IntVec 8 W64) = 620-primOpTag (VecUnpackOp WordVec 16 W8) = 621-primOpTag (VecUnpackOp WordVec 8 W16) = 622-primOpTag (VecUnpackOp WordVec 4 W32) = 623-primOpTag (VecUnpackOp WordVec 2 W64) = 624-primOpTag (VecUnpackOp WordVec 32 W8) = 625-primOpTag (VecUnpackOp WordVec 16 W16) = 626-primOpTag (VecUnpackOp WordVec 8 W32) = 627-primOpTag (VecUnpackOp WordVec 4 W64) = 628-primOpTag (VecUnpackOp WordVec 64 W8) = 629-primOpTag (VecUnpackOp WordVec 32 W16) = 630-primOpTag (VecUnpackOp WordVec 16 W32) = 631-primOpTag (VecUnpackOp WordVec 8 W64) = 632-primOpTag (VecUnpackOp FloatVec 4 W32) = 633-primOpTag (VecUnpackOp FloatVec 2 W64) = 634-primOpTag (VecUnpackOp FloatVec 8 W32) = 635-primOpTag (VecUnpackOp FloatVec 4 W64) = 636-primOpTag (VecUnpackOp FloatVec 16 W32) = 637-primOpTag (VecUnpackOp FloatVec 8 W64) = 638-primOpTag (VecInsertOp IntVec 16 W8) = 639-primOpTag (VecInsertOp IntVec 8 W16) = 640-primOpTag (VecInsertOp IntVec 4 W32) = 641-primOpTag (VecInsertOp IntVec 2 W64) = 642-primOpTag (VecInsertOp IntVec 32 W8) = 643-primOpTag (VecInsertOp IntVec 16 W16) = 644-primOpTag (VecInsertOp IntVec 8 W32) = 645-primOpTag (VecInsertOp IntVec 4 W64) = 646-primOpTag (VecInsertOp IntVec 64 W8) = 647-primOpTag (VecInsertOp IntVec 32 W16) = 648-primOpTag (VecInsertOp IntVec 16 W32) = 649-primOpTag (VecInsertOp IntVec 8 W64) = 650-primOpTag (VecInsertOp WordVec 16 W8) = 651-primOpTag (VecInsertOp WordVec 8 W16) = 652-primOpTag (VecInsertOp WordVec 4 W32) = 653-primOpTag (VecInsertOp WordVec 2 W64) = 654-primOpTag (VecInsertOp WordVec 32 W8) = 655-primOpTag (VecInsertOp WordVec 16 W16) = 656-primOpTag (VecInsertOp WordVec 8 W32) = 657-primOpTag (VecInsertOp WordVec 4 W64) = 658-primOpTag (VecInsertOp WordVec 64 W8) = 659-primOpTag (VecInsertOp WordVec 32 W16) = 660-primOpTag (VecInsertOp WordVec 16 W32) = 661-primOpTag (VecInsertOp WordVec 8 W64) = 662-primOpTag (VecInsertOp FloatVec 4 W32) = 663-primOpTag (VecInsertOp FloatVec 2 W64) = 664-primOpTag (VecInsertOp FloatVec 8 W32) = 665-primOpTag (VecInsertOp FloatVec 4 W64) = 666-primOpTag (VecInsertOp FloatVec 16 W32) = 667-primOpTag (VecInsertOp FloatVec 8 W64) = 668-primOpTag (VecAddOp IntVec 16 W8) = 669-primOpTag (VecAddOp IntVec 8 W16) = 670-primOpTag (VecAddOp IntVec 4 W32) = 671-primOpTag (VecAddOp IntVec 2 W64) = 672-primOpTag (VecAddOp IntVec 32 W8) = 673-primOpTag (VecAddOp IntVec 16 W16) = 674-primOpTag (VecAddOp IntVec 8 W32) = 675-primOpTag (VecAddOp IntVec 4 W64) = 676-primOpTag (VecAddOp IntVec 64 W8) = 677-primOpTag (VecAddOp IntVec 32 W16) = 678-primOpTag (VecAddOp IntVec 16 W32) = 679-primOpTag (VecAddOp IntVec 8 W64) = 680-primOpTag (VecAddOp WordVec 16 W8) = 681-primOpTag (VecAddOp WordVec 8 W16) = 682-primOpTag (VecAddOp WordVec 4 W32) = 683-primOpTag (VecAddOp WordVec 2 W64) = 684-primOpTag (VecAddOp WordVec 32 W8) = 685-primOpTag (VecAddOp WordVec 16 W16) = 686-primOpTag (VecAddOp WordVec 8 W32) = 687-primOpTag (VecAddOp WordVec 4 W64) = 688-primOpTag (VecAddOp WordVec 64 W8) = 689-primOpTag (VecAddOp WordVec 32 W16) = 690-primOpTag (VecAddOp WordVec 16 W32) = 691-primOpTag (VecAddOp WordVec 8 W64) = 692-primOpTag (VecAddOp FloatVec 4 W32) = 693-primOpTag (VecAddOp FloatVec 2 W64) = 694-primOpTag (VecAddOp FloatVec 8 W32) = 695-primOpTag (VecAddOp FloatVec 4 W64) = 696-primOpTag (VecAddOp FloatVec 16 W32) = 697-primOpTag (VecAddOp FloatVec 8 W64) = 698-primOpTag (VecSubOp IntVec 16 W8) = 699-primOpTag (VecSubOp IntVec 8 W16) = 700-primOpTag (VecSubOp IntVec 4 W32) = 701-primOpTag (VecSubOp IntVec 2 W64) = 702-primOpTag (VecSubOp IntVec 32 W8) = 703-primOpTag (VecSubOp IntVec 16 W16) = 704-primOpTag (VecSubOp IntVec 8 W32) = 705-primOpTag (VecSubOp IntVec 4 W64) = 706-primOpTag (VecSubOp IntVec 64 W8) = 707-primOpTag (VecSubOp IntVec 32 W16) = 708-primOpTag (VecSubOp IntVec 16 W32) = 709-primOpTag (VecSubOp IntVec 8 W64) = 710-primOpTag (VecSubOp WordVec 16 W8) = 711-primOpTag (VecSubOp WordVec 8 W16) = 712-primOpTag (VecSubOp WordVec 4 W32) = 713-primOpTag (VecSubOp WordVec 2 W64) = 714-primOpTag (VecSubOp WordVec 32 W8) = 715-primOpTag (VecSubOp WordVec 16 W16) = 716-primOpTag (VecSubOp WordVec 8 W32) = 717-primOpTag (VecSubOp WordVec 4 W64) = 718-primOpTag (VecSubOp WordVec 64 W8) = 719-primOpTag (VecSubOp WordVec 32 W16) = 720-primOpTag (VecSubOp WordVec 16 W32) = 721-primOpTag (VecSubOp WordVec 8 W64) = 722-primOpTag (VecSubOp FloatVec 4 W32) = 723-primOpTag (VecSubOp FloatVec 2 W64) = 724-primOpTag (VecSubOp FloatVec 8 W32) = 725-primOpTag (VecSubOp FloatVec 4 W64) = 726-primOpTag (VecSubOp FloatVec 16 W32) = 727-primOpTag (VecSubOp FloatVec 8 W64) = 728-primOpTag (VecMulOp IntVec 16 W8) = 729-primOpTag (VecMulOp IntVec 8 W16) = 730-primOpTag (VecMulOp IntVec 4 W32) = 731-primOpTag (VecMulOp IntVec 2 W64) = 732-primOpTag (VecMulOp IntVec 32 W8) = 733-primOpTag (VecMulOp IntVec 16 W16) = 734-primOpTag (VecMulOp IntVec 8 W32) = 735-primOpTag (VecMulOp IntVec 4 W64) = 736-primOpTag (VecMulOp IntVec 64 W8) = 737-primOpTag (VecMulOp IntVec 32 W16) = 738-primOpTag (VecMulOp IntVec 16 W32) = 739-primOpTag (VecMulOp IntVec 8 W64) = 740-primOpTag (VecMulOp WordVec 16 W8) = 741-primOpTag (VecMulOp WordVec 8 W16) = 742-primOpTag (VecMulOp WordVec 4 W32) = 743-primOpTag (VecMulOp WordVec 2 W64) = 744-primOpTag (VecMulOp WordVec 32 W8) = 745-primOpTag (VecMulOp WordVec 16 W16) = 746-primOpTag (VecMulOp WordVec 8 W32) = 747-primOpTag (VecMulOp WordVec 4 W64) = 748-primOpTag (VecMulOp WordVec 64 W8) = 749-primOpTag (VecMulOp WordVec 32 W16) = 750-primOpTag (VecMulOp WordVec 16 W32) = 751-primOpTag (VecMulOp WordVec 8 W64) = 752-primOpTag (VecMulOp FloatVec 4 W32) = 753-primOpTag (VecMulOp FloatVec 2 W64) = 754-primOpTag (VecMulOp FloatVec 8 W32) = 755-primOpTag (VecMulOp FloatVec 4 W64) = 756-primOpTag (VecMulOp FloatVec 16 W32) = 757-primOpTag (VecMulOp FloatVec 8 W64) = 758-primOpTag (VecDivOp FloatVec 4 W32) = 759-primOpTag (VecDivOp FloatVec 2 W64) = 760-primOpTag (VecDivOp FloatVec 8 W32) = 761-primOpTag (VecDivOp FloatVec 4 W64) = 762-primOpTag (VecDivOp FloatVec 16 W32) = 763-primOpTag (VecDivOp FloatVec 8 W64) = 764-primOpTag (VecQuotOp IntVec 16 W8) = 765-primOpTag (VecQuotOp IntVec 8 W16) = 766-primOpTag (VecQuotOp IntVec 4 W32) = 767-primOpTag (VecQuotOp IntVec 2 W64) = 768-primOpTag (VecQuotOp IntVec 32 W8) = 769-primOpTag (VecQuotOp IntVec 16 W16) = 770-primOpTag (VecQuotOp IntVec 8 W32) = 771-primOpTag (VecQuotOp IntVec 4 W64) = 772-primOpTag (VecQuotOp IntVec 64 W8) = 773-primOpTag (VecQuotOp IntVec 32 W16) = 774-primOpTag (VecQuotOp IntVec 16 W32) = 775-primOpTag (VecQuotOp IntVec 8 W64) = 776-primOpTag (VecQuotOp WordVec 16 W8) = 777-primOpTag (VecQuotOp WordVec 8 W16) = 778-primOpTag (VecQuotOp WordVec 4 W32) = 779-primOpTag (VecQuotOp WordVec 2 W64) = 780-primOpTag (VecQuotOp WordVec 32 W8) = 781-primOpTag (VecQuotOp WordVec 16 W16) = 782-primOpTag (VecQuotOp WordVec 8 W32) = 783-primOpTag (VecQuotOp WordVec 4 W64) = 784-primOpTag (VecQuotOp WordVec 64 W8) = 785-primOpTag (VecQuotOp WordVec 32 W16) = 786-primOpTag (VecQuotOp WordVec 16 W32) = 787-primOpTag (VecQuotOp WordVec 8 W64) = 788-primOpTag (VecRemOp IntVec 16 W8) = 789-primOpTag (VecRemOp IntVec 8 W16) = 790-primOpTag (VecRemOp IntVec 4 W32) = 791-primOpTag (VecRemOp IntVec 2 W64) = 792-primOpTag (VecRemOp IntVec 32 W8) = 793-primOpTag (VecRemOp IntVec 16 W16) = 794-primOpTag (VecRemOp IntVec 8 W32) = 795-primOpTag (VecRemOp IntVec 4 W64) = 796-primOpTag (VecRemOp IntVec 64 W8) = 797-primOpTag (VecRemOp IntVec 32 W16) = 798-primOpTag (VecRemOp IntVec 16 W32) = 799-primOpTag (VecRemOp IntVec 8 W64) = 800-primOpTag (VecRemOp WordVec 16 W8) = 801-primOpTag (VecRemOp WordVec 8 W16) = 802-primOpTag (VecRemOp WordVec 4 W32) = 803-primOpTag (VecRemOp WordVec 2 W64) = 804-primOpTag (VecRemOp WordVec 32 W8) = 805-primOpTag (VecRemOp WordVec 16 W16) = 806-primOpTag (VecRemOp WordVec 8 W32) = 807-primOpTag (VecRemOp WordVec 4 W64) = 808-primOpTag (VecRemOp WordVec 64 W8) = 809-primOpTag (VecRemOp WordVec 32 W16) = 810-primOpTag (VecRemOp WordVec 16 W32) = 811-primOpTag (VecRemOp WordVec 8 W64) = 812-primOpTag (VecNegOp IntVec 16 W8) = 813-primOpTag (VecNegOp IntVec 8 W16) = 814-primOpTag (VecNegOp IntVec 4 W32) = 815-primOpTag (VecNegOp IntVec 2 W64) = 816-primOpTag (VecNegOp IntVec 32 W8) = 817-primOpTag (VecNegOp IntVec 16 W16) = 818-primOpTag (VecNegOp IntVec 8 W32) = 819-primOpTag (VecNegOp IntVec 4 W64) = 820-primOpTag (VecNegOp IntVec 64 W8) = 821-primOpTag (VecNegOp IntVec 32 W16) = 822-primOpTag (VecNegOp IntVec 16 W32) = 823-primOpTag (VecNegOp IntVec 8 W64) = 824-primOpTag (VecNegOp FloatVec 4 W32) = 825-primOpTag (VecNegOp FloatVec 2 W64) = 826-primOpTag (VecNegOp FloatVec 8 W32) = 827-primOpTag (VecNegOp FloatVec 4 W64) = 828-primOpTag (VecNegOp FloatVec 16 W32) = 829-primOpTag (VecNegOp FloatVec 8 W64) = 830-primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 831-primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 832-primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 833-primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 834-primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 835-primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 836-primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 837-primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 838-primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 839-primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 840-primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 841-primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 842-primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 843-primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 844-primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 845-primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 846-primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 847-primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 848-primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 849-primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 850-primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 851-primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 852-primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 853-primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 854-primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 855-primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 856-primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 857-primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 858-primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 859-primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 860-primOpTag (VecReadByteArrayOp IntVec 16 W8) = 861-primOpTag (VecReadByteArrayOp IntVec 8 W16) = 862-primOpTag (VecReadByteArrayOp IntVec 4 W32) = 863-primOpTag (VecReadByteArrayOp IntVec 2 W64) = 864-primOpTag (VecReadByteArrayOp IntVec 32 W8) = 865-primOpTag (VecReadByteArrayOp IntVec 16 W16) = 866-primOpTag (VecReadByteArrayOp IntVec 8 W32) = 867-primOpTag (VecReadByteArrayOp IntVec 4 W64) = 868-primOpTag (VecReadByteArrayOp IntVec 64 W8) = 869-primOpTag (VecReadByteArrayOp IntVec 32 W16) = 870-primOpTag (VecReadByteArrayOp IntVec 16 W32) = 871-primOpTag (VecReadByteArrayOp IntVec 8 W64) = 872-primOpTag (VecReadByteArrayOp WordVec 16 W8) = 873-primOpTag (VecReadByteArrayOp WordVec 8 W16) = 874-primOpTag (VecReadByteArrayOp WordVec 4 W32) = 875-primOpTag (VecReadByteArrayOp WordVec 2 W64) = 876-primOpTag (VecReadByteArrayOp WordVec 32 W8) = 877-primOpTag (VecReadByteArrayOp WordVec 16 W16) = 878-primOpTag (VecReadByteArrayOp WordVec 8 W32) = 879-primOpTag (VecReadByteArrayOp WordVec 4 W64) = 880-primOpTag (VecReadByteArrayOp WordVec 64 W8) = 881-primOpTag (VecReadByteArrayOp WordVec 32 W16) = 882-primOpTag (VecReadByteArrayOp WordVec 16 W32) = 883-primOpTag (VecReadByteArrayOp WordVec 8 W64) = 884-primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 885-primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 886-primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 887-primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 888-primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 889-primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 890-primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 891-primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 892-primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 893-primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 894-primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 895-primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 896-primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 897-primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 898-primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 899-primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 900-primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 901-primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 902-primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 903-primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 904-primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 905-primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 906-primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 907-primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 908-primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 909-primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 910-primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 911-primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 912-primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 913-primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 914-primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 915-primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 916-primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 917-primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 918-primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 919-primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 920-primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 921-primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 922-primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 923-primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 924-primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 925-primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 926-primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 927-primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 928-primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 929-primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 930-primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 931-primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 932-primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 933-primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 934-primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 935-primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 936-primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 937-primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 938-primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 939-primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 940-primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 941-primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 942-primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 943-primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 944-primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 945-primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 946-primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 947-primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 948-primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 949-primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 950-primOpTag (VecReadOffAddrOp IntVec 16 W8) = 951-primOpTag (VecReadOffAddrOp IntVec 8 W16) = 952-primOpTag (VecReadOffAddrOp IntVec 4 W32) = 953-primOpTag (VecReadOffAddrOp IntVec 2 W64) = 954-primOpTag (VecReadOffAddrOp IntVec 32 W8) = 955-primOpTag (VecReadOffAddrOp IntVec 16 W16) = 956-primOpTag (VecReadOffAddrOp IntVec 8 W32) = 957-primOpTag (VecReadOffAddrOp IntVec 4 W64) = 958-primOpTag (VecReadOffAddrOp IntVec 64 W8) = 959-primOpTag (VecReadOffAddrOp IntVec 32 W16) = 960-primOpTag (VecReadOffAddrOp IntVec 16 W32) = 961-primOpTag (VecReadOffAddrOp IntVec 8 W64) = 962-primOpTag (VecReadOffAddrOp WordVec 16 W8) = 963-primOpTag (VecReadOffAddrOp WordVec 8 W16) = 964-primOpTag (VecReadOffAddrOp WordVec 4 W32) = 965-primOpTag (VecReadOffAddrOp WordVec 2 W64) = 966-primOpTag (VecReadOffAddrOp WordVec 32 W8) = 967-primOpTag (VecReadOffAddrOp WordVec 16 W16) = 968-primOpTag (VecReadOffAddrOp WordVec 8 W32) = 969-primOpTag (VecReadOffAddrOp WordVec 4 W64) = 970-primOpTag (VecReadOffAddrOp WordVec 64 W8) = 971-primOpTag (VecReadOffAddrOp WordVec 32 W16) = 972-primOpTag (VecReadOffAddrOp WordVec 16 W32) = 973-primOpTag (VecReadOffAddrOp WordVec 8 W64) = 974-primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 975-primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 976-primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 977-primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 978-primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 979-primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 980-primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 981-primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 982-primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 983-primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 984-primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 985-primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 986-primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 987-primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 988-primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 989-primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 990-primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 991-primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 992-primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 993-primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 994-primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 995-primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 996-primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 997-primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 998-primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 999-primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 1000-primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 1001-primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 1002-primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1003-primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1004-primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1005-primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1006-primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1007-primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1008-primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1009-primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1010-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1011-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1012-primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1013-primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1014-primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1015-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1016-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1017-primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1018-primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1019-primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1020-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1021-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1022-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1023-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1024-primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1025-primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1026-primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1027-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1028-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1029-primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1030-primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1031-primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1032-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1033-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1034-primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1035-primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1036-primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1037-primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1038-primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1039-primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1040-primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1041-primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1042-primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1043-primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1044-primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1045-primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1046-primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1047-primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1048-primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1049-primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1050-primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1051-primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1052-primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1053-primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1054-primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1055-primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1056-primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1057-primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1058-primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1059-primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1060-primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1061-primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1062-primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1063-primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1064-primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1065-primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1066-primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1067-primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1068-primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1069-primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1070-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1071-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1072-primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1073-primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1074-primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1075-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1076-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1077-primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1078-primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1079-primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1080-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1081-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1082-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1083-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1084-primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1085-primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1086-primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1087-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1088-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1089-primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1090-primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1091-primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1092-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1093-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1094-primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1095-primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1096-primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1097-primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1098-primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1099-primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1100-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1101-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1102-primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1103-primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1104-primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1105-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1106-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1107-primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1108-primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1109-primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1110-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1111-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1112-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1113-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1114-primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1115-primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1116-primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1117-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1118-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1119-primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1120-primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1121-primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1122-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1123-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1124-primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1125-primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1126-primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1127-primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1128-primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1129-primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1130-primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1131-primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1132-primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1133-primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1134-primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1135-primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1136-primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1137-primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1138-primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1139-primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1140-primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1141-primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1142-primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1143-primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1144-primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1145-primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1146-primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1147-primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1148-primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1149-primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1150-primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1151-primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1152-primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1153-primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1154-primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1155-primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1156-primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1157-primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1158-primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1159-primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1160-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1161-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1162-primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1163-primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1164-primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1165-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1166-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1167-primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1168-primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1169-primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1170-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1171-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1172-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1173-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1174-primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1175-primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1176-primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1177-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1178-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1179-primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1180-primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1181-primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1182-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1183-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1184-primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1185-primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1186-primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1187-primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1188-primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1189-primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1190-primOpTag PrefetchByteArrayOp3 = 1191-primOpTag PrefetchMutableByteArrayOp3 = 1192-primOpTag PrefetchAddrOp3 = 1193-primOpTag PrefetchValueOp3 = 1194-primOpTag PrefetchByteArrayOp2 = 1195-primOpTag PrefetchMutableByteArrayOp2 = 1196-primOpTag PrefetchAddrOp2 = 1197-primOpTag PrefetchValueOp2 = 1198-primOpTag PrefetchByteArrayOp1 = 1199-primOpTag PrefetchMutableByteArrayOp1 = 1200-primOpTag PrefetchAddrOp1 = 1201-primOpTag PrefetchValueOp1 = 1202-primOpTag PrefetchByteArrayOp0 = 1203-primOpTag PrefetchMutableByteArrayOp0 = 1204-primOpTag PrefetchAddrOp0 = 1205-primOpTag PrefetchValueOp0 = 1206+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 Int2WordOp = 90+primOpTag Int2FloatOp = 91+primOpTag Int2DoubleOp = 92+primOpTag Word2FloatOp = 93+primOpTag Word2DoubleOp = 94+primOpTag ISllOp = 95+primOpTag ISraOp = 96+primOpTag ISrlOp = 97+primOpTag WordAddOp = 98+primOpTag WordAddCOp = 99+primOpTag WordSubCOp = 100+primOpTag WordAdd2Op = 101+primOpTag WordSubOp = 102+primOpTag WordMulOp = 103+primOpTag WordMul2Op = 104+primOpTag WordQuotOp = 105+primOpTag WordRemOp = 106+primOpTag WordQuotRemOp = 107+primOpTag WordQuotRem2Op = 108+primOpTag AndOp = 109+primOpTag OrOp = 110+primOpTag XorOp = 111+primOpTag NotOp = 112+primOpTag SllOp = 113+primOpTag SrlOp = 114+primOpTag Word2IntOp = 115+primOpTag WordGtOp = 116+primOpTag WordGeOp = 117+primOpTag WordEqOp = 118+primOpTag WordNeOp = 119+primOpTag WordLtOp = 120+primOpTag WordLeOp = 121+primOpTag PopCnt8Op = 122+primOpTag PopCnt16Op = 123+primOpTag PopCnt32Op = 124+primOpTag PopCnt64Op = 125+primOpTag PopCntOp = 126+primOpTag Pdep8Op = 127+primOpTag Pdep16Op = 128+primOpTag Pdep32Op = 129+primOpTag Pdep64Op = 130+primOpTag PdepOp = 131+primOpTag Pext8Op = 132+primOpTag Pext16Op = 133+primOpTag Pext32Op = 134+primOpTag Pext64Op = 135+primOpTag PextOp = 136+primOpTag Clz8Op = 137+primOpTag Clz16Op = 138+primOpTag Clz32Op = 139+primOpTag Clz64Op = 140+primOpTag ClzOp = 141+primOpTag Ctz8Op = 142+primOpTag Ctz16Op = 143+primOpTag Ctz32Op = 144+primOpTag Ctz64Op = 145+primOpTag CtzOp = 146+primOpTag BSwap16Op = 147+primOpTag BSwap32Op = 148+primOpTag BSwap64Op = 149+primOpTag BSwapOp = 150+primOpTag BRev8Op = 151+primOpTag BRev16Op = 152+primOpTag BRev32Op = 153+primOpTag BRev64Op = 154+primOpTag BRevOp = 155+primOpTag Narrow8IntOp = 156+primOpTag Narrow16IntOp = 157+primOpTag Narrow32IntOp = 158+primOpTag Narrow8WordOp = 159+primOpTag Narrow16WordOp = 160+primOpTag Narrow32WordOp = 161+primOpTag DoubleGtOp = 162+primOpTag DoubleGeOp = 163+primOpTag DoubleEqOp = 164+primOpTag DoubleNeOp = 165+primOpTag DoubleLtOp = 166+primOpTag DoubleLeOp = 167+primOpTag DoubleAddOp = 168+primOpTag DoubleSubOp = 169+primOpTag DoubleMulOp = 170+primOpTag DoubleDivOp = 171+primOpTag DoubleNegOp = 172+primOpTag DoubleFabsOp = 173+primOpTag Double2IntOp = 174+primOpTag Double2FloatOp = 175+primOpTag DoubleExpOp = 176+primOpTag DoubleExpM1Op = 177+primOpTag DoubleLogOp = 178+primOpTag DoubleLog1POp = 179+primOpTag DoubleSqrtOp = 180+primOpTag DoubleSinOp = 181+primOpTag DoubleCosOp = 182+primOpTag DoubleTanOp = 183+primOpTag DoubleAsinOp = 184+primOpTag DoubleAcosOp = 185+primOpTag DoubleAtanOp = 186+primOpTag DoubleSinhOp = 187+primOpTag DoubleCoshOp = 188+primOpTag DoubleTanhOp = 189+primOpTag DoubleAsinhOp = 190+primOpTag DoubleAcoshOp = 191+primOpTag DoubleAtanhOp = 192+primOpTag DoublePowerOp = 193+primOpTag DoubleDecode_2IntOp = 194+primOpTag DoubleDecode_Int64Op = 195+primOpTag FloatGtOp = 196+primOpTag FloatGeOp = 197+primOpTag FloatEqOp = 198+primOpTag FloatNeOp = 199+primOpTag FloatLtOp = 200+primOpTag FloatLeOp = 201+primOpTag FloatAddOp = 202+primOpTag FloatSubOp = 203+primOpTag FloatMulOp = 204+primOpTag FloatDivOp = 205+primOpTag FloatNegOp = 206+primOpTag FloatFabsOp = 207+primOpTag Float2IntOp = 208+primOpTag FloatExpOp = 209+primOpTag FloatExpM1Op = 210+primOpTag FloatLogOp = 211+primOpTag FloatLog1POp = 212+primOpTag FloatSqrtOp = 213+primOpTag FloatSinOp = 214+primOpTag FloatCosOp = 215+primOpTag FloatTanOp = 216+primOpTag FloatAsinOp = 217+primOpTag FloatAcosOp = 218+primOpTag FloatAtanOp = 219+primOpTag FloatSinhOp = 220+primOpTag FloatCoshOp = 221+primOpTag FloatTanhOp = 222+primOpTag FloatAsinhOp = 223+primOpTag FloatAcoshOp = 224+primOpTag FloatAtanhOp = 225+primOpTag FloatPowerOp = 226+primOpTag Float2DoubleOp = 227+primOpTag FloatDecode_IntOp = 228+primOpTag NewArrayOp = 229+primOpTag SameMutableArrayOp = 230+primOpTag ReadArrayOp = 231+primOpTag WriteArrayOp = 232+primOpTag SizeofArrayOp = 233+primOpTag SizeofMutableArrayOp = 234+primOpTag IndexArrayOp = 235+primOpTag UnsafeFreezeArrayOp = 236+primOpTag UnsafeThawArrayOp = 237+primOpTag CopyArrayOp = 238+primOpTag CopyMutableArrayOp = 239+primOpTag CloneArrayOp = 240+primOpTag CloneMutableArrayOp = 241+primOpTag FreezeArrayOp = 242+primOpTag ThawArrayOp = 243+primOpTag CasArrayOp = 244+primOpTag NewSmallArrayOp = 245+primOpTag SameSmallMutableArrayOp = 246+primOpTag ShrinkSmallMutableArrayOp_Char = 247+primOpTag ReadSmallArrayOp = 248+primOpTag WriteSmallArrayOp = 249+primOpTag SizeofSmallArrayOp = 250+primOpTag SizeofSmallMutableArrayOp = 251+primOpTag GetSizeofSmallMutableArrayOp = 252+primOpTag IndexSmallArrayOp = 253+primOpTag UnsafeFreezeSmallArrayOp = 254+primOpTag UnsafeThawSmallArrayOp = 255+primOpTag CopySmallArrayOp = 256+primOpTag CopySmallMutableArrayOp = 257+primOpTag CloneSmallArrayOp = 258+primOpTag CloneSmallMutableArrayOp = 259+primOpTag FreezeSmallArrayOp = 260+primOpTag ThawSmallArrayOp = 261+primOpTag CasSmallArrayOp = 262+primOpTag NewByteArrayOp_Char = 263+primOpTag NewPinnedByteArrayOp_Char = 264+primOpTag NewAlignedPinnedByteArrayOp_Char = 265+primOpTag MutableByteArrayIsPinnedOp = 266+primOpTag ByteArrayIsPinnedOp = 267+primOpTag ByteArrayContents_Char = 268+primOpTag SameMutableByteArrayOp = 269+primOpTag ShrinkMutableByteArrayOp_Char = 270+primOpTag ResizeMutableByteArrayOp_Char = 271+primOpTag UnsafeFreezeByteArrayOp = 272+primOpTag SizeofByteArrayOp = 273+primOpTag SizeofMutableByteArrayOp = 274+primOpTag GetSizeofMutableByteArrayOp = 275+primOpTag IndexByteArrayOp_Char = 276+primOpTag IndexByteArrayOp_WideChar = 277+primOpTag IndexByteArrayOp_Int = 278+primOpTag IndexByteArrayOp_Word = 279+primOpTag IndexByteArrayOp_Addr = 280+primOpTag IndexByteArrayOp_Float = 281+primOpTag IndexByteArrayOp_Double = 282+primOpTag IndexByteArrayOp_StablePtr = 283+primOpTag IndexByteArrayOp_Int8 = 284+primOpTag IndexByteArrayOp_Int16 = 285+primOpTag IndexByteArrayOp_Int32 = 286+primOpTag IndexByteArrayOp_Int64 = 287+primOpTag IndexByteArrayOp_Word8 = 288+primOpTag IndexByteArrayOp_Word16 = 289+primOpTag IndexByteArrayOp_Word32 = 290+primOpTag IndexByteArrayOp_Word64 = 291+primOpTag IndexByteArrayOp_Word8AsChar = 292+primOpTag IndexByteArrayOp_Word8AsWideChar = 293+primOpTag IndexByteArrayOp_Word8AsAddr = 294+primOpTag IndexByteArrayOp_Word8AsFloat = 295+primOpTag IndexByteArrayOp_Word8AsDouble = 296+primOpTag IndexByteArrayOp_Word8AsStablePtr = 297+primOpTag IndexByteArrayOp_Word8AsInt16 = 298+primOpTag IndexByteArrayOp_Word8AsInt32 = 299+primOpTag IndexByteArrayOp_Word8AsInt64 = 300+primOpTag IndexByteArrayOp_Word8AsInt = 301+primOpTag IndexByteArrayOp_Word8AsWord16 = 302+primOpTag IndexByteArrayOp_Word8AsWord32 = 303+primOpTag IndexByteArrayOp_Word8AsWord64 = 304+primOpTag IndexByteArrayOp_Word8AsWord = 305+primOpTag ReadByteArrayOp_Char = 306+primOpTag ReadByteArrayOp_WideChar = 307+primOpTag ReadByteArrayOp_Int = 308+primOpTag ReadByteArrayOp_Word = 309+primOpTag ReadByteArrayOp_Addr = 310+primOpTag ReadByteArrayOp_Float = 311+primOpTag ReadByteArrayOp_Double = 312+primOpTag ReadByteArrayOp_StablePtr = 313+primOpTag ReadByteArrayOp_Int8 = 314+primOpTag ReadByteArrayOp_Int16 = 315+primOpTag ReadByteArrayOp_Int32 = 316+primOpTag ReadByteArrayOp_Int64 = 317+primOpTag ReadByteArrayOp_Word8 = 318+primOpTag ReadByteArrayOp_Word16 = 319+primOpTag ReadByteArrayOp_Word32 = 320+primOpTag ReadByteArrayOp_Word64 = 321+primOpTag ReadByteArrayOp_Word8AsChar = 322+primOpTag ReadByteArrayOp_Word8AsWideChar = 323+primOpTag ReadByteArrayOp_Word8AsAddr = 324+primOpTag ReadByteArrayOp_Word8AsFloat = 325+primOpTag ReadByteArrayOp_Word8AsDouble = 326+primOpTag ReadByteArrayOp_Word8AsStablePtr = 327+primOpTag ReadByteArrayOp_Word8AsInt16 = 328+primOpTag ReadByteArrayOp_Word8AsInt32 = 329+primOpTag ReadByteArrayOp_Word8AsInt64 = 330+primOpTag ReadByteArrayOp_Word8AsInt = 331+primOpTag ReadByteArrayOp_Word8AsWord16 = 332+primOpTag ReadByteArrayOp_Word8AsWord32 = 333+primOpTag ReadByteArrayOp_Word8AsWord64 = 334+primOpTag ReadByteArrayOp_Word8AsWord = 335+primOpTag WriteByteArrayOp_Char = 336+primOpTag WriteByteArrayOp_WideChar = 337+primOpTag WriteByteArrayOp_Int = 338+primOpTag WriteByteArrayOp_Word = 339+primOpTag WriteByteArrayOp_Addr = 340+primOpTag WriteByteArrayOp_Float = 341+primOpTag WriteByteArrayOp_Double = 342+primOpTag WriteByteArrayOp_StablePtr = 343+primOpTag WriteByteArrayOp_Int8 = 344+primOpTag WriteByteArrayOp_Int16 = 345+primOpTag WriteByteArrayOp_Int32 = 346+primOpTag WriteByteArrayOp_Int64 = 347+primOpTag WriteByteArrayOp_Word8 = 348+primOpTag WriteByteArrayOp_Word16 = 349+primOpTag WriteByteArrayOp_Word32 = 350+primOpTag WriteByteArrayOp_Word64 = 351+primOpTag WriteByteArrayOp_Word8AsChar = 352+primOpTag WriteByteArrayOp_Word8AsWideChar = 353+primOpTag WriteByteArrayOp_Word8AsAddr = 354+primOpTag WriteByteArrayOp_Word8AsFloat = 355+primOpTag WriteByteArrayOp_Word8AsDouble = 356+primOpTag WriteByteArrayOp_Word8AsStablePtr = 357+primOpTag WriteByteArrayOp_Word8AsInt16 = 358+primOpTag WriteByteArrayOp_Word8AsInt32 = 359+primOpTag WriteByteArrayOp_Word8AsInt64 = 360+primOpTag WriteByteArrayOp_Word8AsInt = 361+primOpTag WriteByteArrayOp_Word8AsWord16 = 362+primOpTag WriteByteArrayOp_Word8AsWord32 = 363+primOpTag WriteByteArrayOp_Word8AsWord64 = 364+primOpTag WriteByteArrayOp_Word8AsWord = 365+primOpTag CompareByteArraysOp = 366+primOpTag CopyByteArrayOp = 367+primOpTag CopyMutableByteArrayOp = 368+primOpTag CopyByteArrayToAddrOp = 369+primOpTag CopyMutableByteArrayToAddrOp = 370+primOpTag CopyAddrToByteArrayOp = 371+primOpTag SetByteArrayOp = 372+primOpTag AtomicReadByteArrayOp_Int = 373+primOpTag AtomicWriteByteArrayOp_Int = 374+primOpTag CasByteArrayOp_Int = 375+primOpTag FetchAddByteArrayOp_Int = 376+primOpTag FetchSubByteArrayOp_Int = 377+primOpTag FetchAndByteArrayOp_Int = 378+primOpTag FetchNandByteArrayOp_Int = 379+primOpTag FetchOrByteArrayOp_Int = 380+primOpTag FetchXorByteArrayOp_Int = 381+primOpTag NewArrayArrayOp = 382+primOpTag SameMutableArrayArrayOp = 383+primOpTag UnsafeFreezeArrayArrayOp = 384+primOpTag SizeofArrayArrayOp = 385+primOpTag SizeofMutableArrayArrayOp = 386+primOpTag IndexArrayArrayOp_ByteArray = 387+primOpTag IndexArrayArrayOp_ArrayArray = 388+primOpTag ReadArrayArrayOp_ByteArray = 389+primOpTag ReadArrayArrayOp_MutableByteArray = 390+primOpTag ReadArrayArrayOp_ArrayArray = 391+primOpTag ReadArrayArrayOp_MutableArrayArray = 392+primOpTag WriteArrayArrayOp_ByteArray = 393+primOpTag WriteArrayArrayOp_MutableByteArray = 394+primOpTag WriteArrayArrayOp_ArrayArray = 395+primOpTag WriteArrayArrayOp_MutableArrayArray = 396+primOpTag CopyArrayArrayOp = 397+primOpTag CopyMutableArrayArrayOp = 398+primOpTag AddrAddOp = 399+primOpTag AddrSubOp = 400+primOpTag AddrRemOp = 401+primOpTag Addr2IntOp = 402+primOpTag Int2AddrOp = 403+primOpTag AddrGtOp = 404+primOpTag AddrGeOp = 405+primOpTag AddrEqOp = 406+primOpTag AddrNeOp = 407+primOpTag AddrLtOp = 408+primOpTag AddrLeOp = 409+primOpTag IndexOffAddrOp_Char = 410+primOpTag IndexOffAddrOp_WideChar = 411+primOpTag IndexOffAddrOp_Int = 412+primOpTag IndexOffAddrOp_Word = 413+primOpTag IndexOffAddrOp_Addr = 414+primOpTag IndexOffAddrOp_Float = 415+primOpTag IndexOffAddrOp_Double = 416+primOpTag IndexOffAddrOp_StablePtr = 417+primOpTag IndexOffAddrOp_Int8 = 418+primOpTag IndexOffAddrOp_Int16 = 419+primOpTag IndexOffAddrOp_Int32 = 420+primOpTag IndexOffAddrOp_Int64 = 421+primOpTag IndexOffAddrOp_Word8 = 422+primOpTag IndexOffAddrOp_Word16 = 423+primOpTag IndexOffAddrOp_Word32 = 424+primOpTag IndexOffAddrOp_Word64 = 425+primOpTag ReadOffAddrOp_Char = 426+primOpTag ReadOffAddrOp_WideChar = 427+primOpTag ReadOffAddrOp_Int = 428+primOpTag ReadOffAddrOp_Word = 429+primOpTag ReadOffAddrOp_Addr = 430+primOpTag ReadOffAddrOp_Float = 431+primOpTag ReadOffAddrOp_Double = 432+primOpTag ReadOffAddrOp_StablePtr = 433+primOpTag ReadOffAddrOp_Int8 = 434+primOpTag ReadOffAddrOp_Int16 = 435+primOpTag ReadOffAddrOp_Int32 = 436+primOpTag ReadOffAddrOp_Int64 = 437+primOpTag ReadOffAddrOp_Word8 = 438+primOpTag ReadOffAddrOp_Word16 = 439+primOpTag ReadOffAddrOp_Word32 = 440+primOpTag ReadOffAddrOp_Word64 = 441+primOpTag WriteOffAddrOp_Char = 442+primOpTag WriteOffAddrOp_WideChar = 443+primOpTag WriteOffAddrOp_Int = 444+primOpTag WriteOffAddrOp_Word = 445+primOpTag WriteOffAddrOp_Addr = 446+primOpTag WriteOffAddrOp_Float = 447+primOpTag WriteOffAddrOp_Double = 448+primOpTag WriteOffAddrOp_StablePtr = 449+primOpTag WriteOffAddrOp_Int8 = 450+primOpTag WriteOffAddrOp_Int16 = 451+primOpTag WriteOffAddrOp_Int32 = 452+primOpTag WriteOffAddrOp_Int64 = 453+primOpTag WriteOffAddrOp_Word8 = 454+primOpTag WriteOffAddrOp_Word16 = 455+primOpTag WriteOffAddrOp_Word32 = 456+primOpTag WriteOffAddrOp_Word64 = 457+primOpTag InterlockedExchange_Addr = 458+primOpTag InterlockedExchange_Int = 459+primOpTag NewMutVarOp = 460+primOpTag ReadMutVarOp = 461+primOpTag WriteMutVarOp = 462+primOpTag SameMutVarOp = 463+primOpTag AtomicModifyMutVar2Op = 464+primOpTag AtomicModifyMutVar_Op = 465+primOpTag CasMutVarOp = 466+primOpTag CatchOp = 467+primOpTag RaiseOp = 468+primOpTag RaiseIOOp = 469+primOpTag MaskAsyncExceptionsOp = 470+primOpTag MaskUninterruptibleOp = 471+primOpTag UnmaskAsyncExceptionsOp = 472+primOpTag MaskStatus = 473+primOpTag AtomicallyOp = 474+primOpTag RetryOp = 475+primOpTag CatchRetryOp = 476+primOpTag CatchSTMOp = 477+primOpTag NewTVarOp = 478+primOpTag ReadTVarOp = 479+primOpTag ReadTVarIOOp = 480+primOpTag WriteTVarOp = 481+primOpTag SameTVarOp = 482+primOpTag NewMVarOp = 483+primOpTag TakeMVarOp = 484+primOpTag TryTakeMVarOp = 485+primOpTag PutMVarOp = 486+primOpTag TryPutMVarOp = 487+primOpTag ReadMVarOp = 488+primOpTag TryReadMVarOp = 489+primOpTag SameMVarOp = 490+primOpTag IsEmptyMVarOp = 491+primOpTag 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
ghc-lib/stage0/lib/DerivedConstants.h view
@@ -491,16 +491,16 @@ #define OFFSET_StgCompactNFDataBlock_next 16 #define REP_StgCompactNFDataBlock_next b64 #define StgCompactNFDataBlock_next(__ptr__) REP_StgCompactNFDataBlock_next[__ptr__+OFFSET_StgCompactNFDataBlock_next]-#define OFFSET_RtsFlags_ProfFlags_showCCSOnException 285+#define OFFSET_RtsFlags_ProfFlags_showCCSOnException 293 #define REP_RtsFlags_ProfFlags_showCCSOnException b8 #define RtsFlags_ProfFlags_showCCSOnException(__ptr__) REP_RtsFlags_ProfFlags_showCCSOnException[__ptr__+OFFSET_RtsFlags_ProfFlags_showCCSOnException]-#define OFFSET_RtsFlags_DebugFlags_apply 228+#define OFFSET_RtsFlags_DebugFlags_apply 236 #define REP_RtsFlags_DebugFlags_apply b8 #define RtsFlags_DebugFlags_apply(__ptr__) REP_RtsFlags_DebugFlags_apply[__ptr__+OFFSET_RtsFlags_DebugFlags_apply]-#define OFFSET_RtsFlags_DebugFlags_sanity 223+#define OFFSET_RtsFlags_DebugFlags_sanity 231 #define REP_RtsFlags_DebugFlags_sanity b8 #define RtsFlags_DebugFlags_sanity(__ptr__) REP_RtsFlags_DebugFlags_sanity[__ptr__+OFFSET_RtsFlags_DebugFlags_sanity]-#define OFFSET_RtsFlags_DebugFlags_weak 218+#define OFFSET_RtsFlags_DebugFlags_weak 226 #define REP_RtsFlags_DebugFlags_weak b8 #define RtsFlags_DebugFlags_weak(__ptr__) REP_RtsFlags_DebugFlags_weak[__ptr__+OFFSET_RtsFlags_DebugFlags_weak] #define OFFSET_RtsFlags_GcFlags_initialStkSize 16
− ghc-lib/stage0/lib/GHCConstantsHaskellExports.hs
@@ -1,123 +0,0 @@- cONTROL_GROUP_CONST_291,- sTD_HDR_SIZE,- pROF_HDR_SIZE,- bLOCK_SIZE,- bLOCKS_PER_MBLOCK,- tICKY_BIN_COUNT,- oFFSET_StgRegTable_rR1,- oFFSET_StgRegTable_rR2,- oFFSET_StgRegTable_rR3,- oFFSET_StgRegTable_rR4,- oFFSET_StgRegTable_rR5,- oFFSET_StgRegTable_rR6,- oFFSET_StgRegTable_rR7,- oFFSET_StgRegTable_rR8,- oFFSET_StgRegTable_rR9,- oFFSET_StgRegTable_rR10,- oFFSET_StgRegTable_rF1,- oFFSET_StgRegTable_rF2,- oFFSET_StgRegTable_rF3,- oFFSET_StgRegTable_rF4,- oFFSET_StgRegTable_rF5,- oFFSET_StgRegTable_rF6,- oFFSET_StgRegTable_rD1,- oFFSET_StgRegTable_rD2,- oFFSET_StgRegTable_rD3,- oFFSET_StgRegTable_rD4,- oFFSET_StgRegTable_rD5,- oFFSET_StgRegTable_rD6,- oFFSET_StgRegTable_rXMM1,- oFFSET_StgRegTable_rXMM2,- oFFSET_StgRegTable_rXMM3,- oFFSET_StgRegTable_rXMM4,- oFFSET_StgRegTable_rXMM5,- oFFSET_StgRegTable_rXMM6,- oFFSET_StgRegTable_rYMM1,- oFFSET_StgRegTable_rYMM2,- oFFSET_StgRegTable_rYMM3,- oFFSET_StgRegTable_rYMM4,- oFFSET_StgRegTable_rYMM5,- oFFSET_StgRegTable_rYMM6,- oFFSET_StgRegTable_rZMM1,- oFFSET_StgRegTable_rZMM2,- oFFSET_StgRegTable_rZMM3,- oFFSET_StgRegTable_rZMM4,- oFFSET_StgRegTable_rZMM5,- oFFSET_StgRegTable_rZMM6,- oFFSET_StgRegTable_rL1,- oFFSET_StgRegTable_rSp,- oFFSET_StgRegTable_rSpLim,- oFFSET_StgRegTable_rHp,- oFFSET_StgRegTable_rHpLim,- oFFSET_StgRegTable_rCCCS,- oFFSET_StgRegTable_rCurrentTSO,- oFFSET_StgRegTable_rCurrentNursery,- oFFSET_StgRegTable_rHpAlloc,- oFFSET_stgEagerBlackholeInfo,- oFFSET_stgGCEnter1,- oFFSET_stgGCFun,- oFFSET_Capability_r,- oFFSET_bdescr_start,- oFFSET_bdescr_free,- oFFSET_bdescr_blocks,- oFFSET_bdescr_flags,- sIZEOF_CostCentreStack,- oFFSET_CostCentreStack_mem_alloc,- oFFSET_CostCentreStack_scc_count,- oFFSET_StgHeader_ccs,- oFFSET_StgHeader_ldvw,- sIZEOF_StgSMPThunkHeader,- oFFSET_StgEntCounter_allocs,- oFFSET_StgEntCounter_allocd,- oFFSET_StgEntCounter_registeredp,- oFFSET_StgEntCounter_link,- oFFSET_StgEntCounter_entry_count,- sIZEOF_StgUpdateFrame_NoHdr,- sIZEOF_StgMutArrPtrs_NoHdr,- oFFSET_StgMutArrPtrs_ptrs,- oFFSET_StgMutArrPtrs_size,- sIZEOF_StgSmallMutArrPtrs_NoHdr,- oFFSET_StgSmallMutArrPtrs_ptrs,- sIZEOF_StgArrBytes_NoHdr,- oFFSET_StgArrBytes_bytes,- oFFSET_StgTSO_alloc_limit,- oFFSET_StgTSO_cccs,- oFFSET_StgTSO_stackobj,- oFFSET_StgStack_sp,- oFFSET_StgStack_stack,- oFFSET_StgUpdateFrame_updatee,- oFFSET_StgFunInfoExtraFwd_arity,- sIZEOF_StgFunInfoExtraRev,- oFFSET_StgFunInfoExtraRev_arity,- mAX_SPEC_SELECTEE_SIZE,- mAX_SPEC_AP_SIZE,- mIN_PAYLOAD_SIZE,- mIN_INTLIKE,- mAX_INTLIKE,- mIN_CHARLIKE,- mAX_CHARLIKE,- mUT_ARR_PTRS_CARD_BITS,- mAX_Vanilla_REG,- mAX_Float_REG,- mAX_Double_REG,- mAX_Long_REG,- mAX_XMM_REG,- mAX_Real_Vanilla_REG,- mAX_Real_Float_REG,- mAX_Real_Double_REG,- mAX_Real_XMM_REG,- mAX_Real_Long_REG,- rESERVED_C_STACK_BYTES,- rESERVED_STACK_WORDS,- aP_STACK_SPLIM,- wORD_SIZE,- cINT_SIZE,- cLONG_SIZE,- cLONG_LONG_SIZE,- bITMAP_BITS_SHIFT,- tAG_BITS,- dYNAMIC_BY_DEFAULT,- lDV_SHIFT,- iLDV_CREATE_MASK,- iLDV_STATE_CREATE,- iLDV_STATE_USE,
− ghc-lib/stage0/lib/GHCConstantsHaskellType.hs
@@ -1,131 +0,0 @@-data PlatformConstants = PlatformConstants {- pc_CONTROL_GROUP_CONST_291 :: Int,- pc_STD_HDR_SIZE :: Int,- pc_PROF_HDR_SIZE :: Int,- pc_BLOCK_SIZE :: Int,- pc_BLOCKS_PER_MBLOCK :: Int,- pc_TICKY_BIN_COUNT :: Int,- pc_OFFSET_StgRegTable_rR1 :: Int,- pc_OFFSET_StgRegTable_rR2 :: Int,- pc_OFFSET_StgRegTable_rR3 :: Int,- pc_OFFSET_StgRegTable_rR4 :: Int,- pc_OFFSET_StgRegTable_rR5 :: Int,- pc_OFFSET_StgRegTable_rR6 :: Int,- pc_OFFSET_StgRegTable_rR7 :: Int,- pc_OFFSET_StgRegTable_rR8 :: Int,- pc_OFFSET_StgRegTable_rR9 :: Int,- pc_OFFSET_StgRegTable_rR10 :: Int,- pc_OFFSET_StgRegTable_rF1 :: Int,- pc_OFFSET_StgRegTable_rF2 :: Int,- pc_OFFSET_StgRegTable_rF3 :: Int,- pc_OFFSET_StgRegTable_rF4 :: Int,- pc_OFFSET_StgRegTable_rF5 :: Int,- pc_OFFSET_StgRegTable_rF6 :: Int,- pc_OFFSET_StgRegTable_rD1 :: Int,- pc_OFFSET_StgRegTable_rD2 :: Int,- pc_OFFSET_StgRegTable_rD3 :: Int,- pc_OFFSET_StgRegTable_rD4 :: Int,- pc_OFFSET_StgRegTable_rD5 :: Int,- pc_OFFSET_StgRegTable_rD6 :: Int,- pc_OFFSET_StgRegTable_rXMM1 :: Int,- pc_OFFSET_StgRegTable_rXMM2 :: Int,- pc_OFFSET_StgRegTable_rXMM3 :: Int,- pc_OFFSET_StgRegTable_rXMM4 :: Int,- pc_OFFSET_StgRegTable_rXMM5 :: Int,- pc_OFFSET_StgRegTable_rXMM6 :: Int,- pc_OFFSET_StgRegTable_rYMM1 :: Int,- pc_OFFSET_StgRegTable_rYMM2 :: Int,- pc_OFFSET_StgRegTable_rYMM3 :: Int,- pc_OFFSET_StgRegTable_rYMM4 :: Int,- pc_OFFSET_StgRegTable_rYMM5 :: Int,- pc_OFFSET_StgRegTable_rYMM6 :: Int,- pc_OFFSET_StgRegTable_rZMM1 :: Int,- pc_OFFSET_StgRegTable_rZMM2 :: Int,- pc_OFFSET_StgRegTable_rZMM3 :: Int,- pc_OFFSET_StgRegTable_rZMM4 :: Int,- pc_OFFSET_StgRegTable_rZMM5 :: Int,- pc_OFFSET_StgRegTable_rZMM6 :: Int,- pc_OFFSET_StgRegTable_rL1 :: Int,- pc_OFFSET_StgRegTable_rSp :: Int,- pc_OFFSET_StgRegTable_rSpLim :: Int,- pc_OFFSET_StgRegTable_rHp :: Int,- pc_OFFSET_StgRegTable_rHpLim :: Int,- pc_OFFSET_StgRegTable_rCCCS :: Int,- pc_OFFSET_StgRegTable_rCurrentTSO :: Int,- pc_OFFSET_StgRegTable_rCurrentNursery :: Int,- pc_OFFSET_StgRegTable_rHpAlloc :: Int,- pc_OFFSET_stgEagerBlackholeInfo :: Int,- pc_OFFSET_stgGCEnter1 :: Int,- pc_OFFSET_stgGCFun :: Int,- pc_OFFSET_Capability_r :: Int,- pc_OFFSET_bdescr_start :: Int,- pc_OFFSET_bdescr_free :: Int,- pc_OFFSET_bdescr_blocks :: Int,- pc_OFFSET_bdescr_flags :: Int,- pc_SIZEOF_CostCentreStack :: Int,- pc_OFFSET_CostCentreStack_mem_alloc :: Int,- pc_REP_CostCentreStack_mem_alloc :: Int,- pc_OFFSET_CostCentreStack_scc_count :: Int,- pc_REP_CostCentreStack_scc_count :: Int,- pc_OFFSET_StgHeader_ccs :: Int,- pc_OFFSET_StgHeader_ldvw :: Int,- pc_SIZEOF_StgSMPThunkHeader :: Int,- pc_OFFSET_StgEntCounter_allocs :: Int,- pc_REP_StgEntCounter_allocs :: Int,- pc_OFFSET_StgEntCounter_allocd :: Int,- pc_REP_StgEntCounter_allocd :: Int,- pc_OFFSET_StgEntCounter_registeredp :: Int,- pc_OFFSET_StgEntCounter_link :: Int,- pc_OFFSET_StgEntCounter_entry_count :: Int,- pc_SIZEOF_StgUpdateFrame_NoHdr :: Int,- pc_SIZEOF_StgMutArrPtrs_NoHdr :: Int,- pc_OFFSET_StgMutArrPtrs_ptrs :: Int,- pc_OFFSET_StgMutArrPtrs_size :: Int,- pc_SIZEOF_StgSmallMutArrPtrs_NoHdr :: Int,- pc_OFFSET_StgSmallMutArrPtrs_ptrs :: Int,- pc_SIZEOF_StgArrBytes_NoHdr :: Int,- pc_OFFSET_StgArrBytes_bytes :: Int,- pc_OFFSET_StgTSO_alloc_limit :: Int,- pc_OFFSET_StgTSO_cccs :: Int,- pc_OFFSET_StgTSO_stackobj :: Int,- pc_OFFSET_StgStack_sp :: Int,- pc_OFFSET_StgStack_stack :: Int,- pc_OFFSET_StgUpdateFrame_updatee :: Int,- pc_OFFSET_StgFunInfoExtraFwd_arity :: Int,- pc_REP_StgFunInfoExtraFwd_arity :: Int,- pc_SIZEOF_StgFunInfoExtraRev :: Int,- pc_OFFSET_StgFunInfoExtraRev_arity :: Int,- pc_REP_StgFunInfoExtraRev_arity :: Int,- pc_MAX_SPEC_SELECTEE_SIZE :: Int,- pc_MAX_SPEC_AP_SIZE :: Int,- pc_MIN_PAYLOAD_SIZE :: Int,- pc_MIN_INTLIKE :: Int,- pc_MAX_INTLIKE :: Int,- pc_MIN_CHARLIKE :: Int,- pc_MAX_CHARLIKE :: Int,- pc_MUT_ARR_PTRS_CARD_BITS :: Int,- pc_MAX_Vanilla_REG :: Int,- pc_MAX_Float_REG :: Int,- pc_MAX_Double_REG :: Int,- pc_MAX_Long_REG :: Int,- pc_MAX_XMM_REG :: Int,- pc_MAX_Real_Vanilla_REG :: Int,- pc_MAX_Real_Float_REG :: Int,- pc_MAX_Real_Double_REG :: Int,- pc_MAX_Real_XMM_REG :: Int,- pc_MAX_Real_Long_REG :: Int,- pc_RESERVED_C_STACK_BYTES :: Int,- pc_RESERVED_STACK_WORDS :: Int,- pc_AP_STACK_SPLIM :: Int,- pc_WORD_SIZE :: Int,- pc_CINT_SIZE :: Int,- pc_CLONG_SIZE :: Int,- pc_CLONG_LONG_SIZE :: Int,- pc_BITMAP_BITS_SHIFT :: Int,- pc_TAG_BITS :: Int,- pc_DYNAMIC_BY_DEFAULT :: Bool,- pc_LDV_SHIFT :: Int,- pc_ILDV_CREATE_MASK :: Integer,- pc_ILDV_STATE_CREATE :: Integer,- pc_ILDV_STATE_USE :: Integer- } deriving Read
− ghc-lib/stage0/lib/GHCConstantsHaskellWrappers.hs
@@ -1,246 +0,0 @@-cONTROL_GROUP_CONST_291 :: DynFlags -> Int-cONTROL_GROUP_CONST_291 dflags = pc_CONTROL_GROUP_CONST_291 (platformConstants dflags)-sTD_HDR_SIZE :: DynFlags -> Int-sTD_HDR_SIZE dflags = pc_STD_HDR_SIZE (platformConstants dflags)-pROF_HDR_SIZE :: DynFlags -> Int-pROF_HDR_SIZE dflags = pc_PROF_HDR_SIZE (platformConstants dflags)-bLOCK_SIZE :: DynFlags -> Int-bLOCK_SIZE dflags = pc_BLOCK_SIZE (platformConstants dflags)-bLOCKS_PER_MBLOCK :: DynFlags -> Int-bLOCKS_PER_MBLOCK dflags = pc_BLOCKS_PER_MBLOCK (platformConstants dflags)-tICKY_BIN_COUNT :: DynFlags -> Int-tICKY_BIN_COUNT dflags = pc_TICKY_BIN_COUNT (platformConstants dflags)-oFFSET_StgRegTable_rR1 :: DynFlags -> Int-oFFSET_StgRegTable_rR1 dflags = pc_OFFSET_StgRegTable_rR1 (platformConstants dflags)-oFFSET_StgRegTable_rR2 :: DynFlags -> Int-oFFSET_StgRegTable_rR2 dflags = pc_OFFSET_StgRegTable_rR2 (platformConstants dflags)-oFFSET_StgRegTable_rR3 :: DynFlags -> Int-oFFSET_StgRegTable_rR3 dflags = pc_OFFSET_StgRegTable_rR3 (platformConstants dflags)-oFFSET_StgRegTable_rR4 :: DynFlags -> Int-oFFSET_StgRegTable_rR4 dflags = pc_OFFSET_StgRegTable_rR4 (platformConstants dflags)-oFFSET_StgRegTable_rR5 :: DynFlags -> Int-oFFSET_StgRegTable_rR5 dflags = pc_OFFSET_StgRegTable_rR5 (platformConstants dflags)-oFFSET_StgRegTable_rR6 :: DynFlags -> Int-oFFSET_StgRegTable_rR6 dflags = pc_OFFSET_StgRegTable_rR6 (platformConstants dflags)-oFFSET_StgRegTable_rR7 :: DynFlags -> Int-oFFSET_StgRegTable_rR7 dflags = pc_OFFSET_StgRegTable_rR7 (platformConstants dflags)-oFFSET_StgRegTable_rR8 :: DynFlags -> Int-oFFSET_StgRegTable_rR8 dflags = pc_OFFSET_StgRegTable_rR8 (platformConstants dflags)-oFFSET_StgRegTable_rR9 :: DynFlags -> Int-oFFSET_StgRegTable_rR9 dflags = pc_OFFSET_StgRegTable_rR9 (platformConstants dflags)-oFFSET_StgRegTable_rR10 :: DynFlags -> Int-oFFSET_StgRegTable_rR10 dflags = pc_OFFSET_StgRegTable_rR10 (platformConstants dflags)-oFFSET_StgRegTable_rF1 :: DynFlags -> Int-oFFSET_StgRegTable_rF1 dflags = pc_OFFSET_StgRegTable_rF1 (platformConstants dflags)-oFFSET_StgRegTable_rF2 :: DynFlags -> Int-oFFSET_StgRegTable_rF2 dflags = pc_OFFSET_StgRegTable_rF2 (platformConstants dflags)-oFFSET_StgRegTable_rF3 :: DynFlags -> Int-oFFSET_StgRegTable_rF3 dflags = pc_OFFSET_StgRegTable_rF3 (platformConstants dflags)-oFFSET_StgRegTable_rF4 :: DynFlags -> Int-oFFSET_StgRegTable_rF4 dflags = pc_OFFSET_StgRegTable_rF4 (platformConstants dflags)-oFFSET_StgRegTable_rF5 :: DynFlags -> Int-oFFSET_StgRegTable_rF5 dflags = pc_OFFSET_StgRegTable_rF5 (platformConstants dflags)-oFFSET_StgRegTable_rF6 :: DynFlags -> Int-oFFSET_StgRegTable_rF6 dflags = pc_OFFSET_StgRegTable_rF6 (platformConstants dflags)-oFFSET_StgRegTable_rD1 :: DynFlags -> Int-oFFSET_StgRegTable_rD1 dflags = pc_OFFSET_StgRegTable_rD1 (platformConstants dflags)-oFFSET_StgRegTable_rD2 :: DynFlags -> Int-oFFSET_StgRegTable_rD2 dflags = pc_OFFSET_StgRegTable_rD2 (platformConstants dflags)-oFFSET_StgRegTable_rD3 :: DynFlags -> Int-oFFSET_StgRegTable_rD3 dflags = pc_OFFSET_StgRegTable_rD3 (platformConstants dflags)-oFFSET_StgRegTable_rD4 :: DynFlags -> Int-oFFSET_StgRegTable_rD4 dflags = pc_OFFSET_StgRegTable_rD4 (platformConstants dflags)-oFFSET_StgRegTable_rD5 :: DynFlags -> Int-oFFSET_StgRegTable_rD5 dflags = pc_OFFSET_StgRegTable_rD5 (platformConstants dflags)-oFFSET_StgRegTable_rD6 :: DynFlags -> Int-oFFSET_StgRegTable_rD6 dflags = pc_OFFSET_StgRegTable_rD6 (platformConstants dflags)-oFFSET_StgRegTable_rXMM1 :: DynFlags -> Int-oFFSET_StgRegTable_rXMM1 dflags = pc_OFFSET_StgRegTable_rXMM1 (platformConstants dflags)-oFFSET_StgRegTable_rXMM2 :: DynFlags -> Int-oFFSET_StgRegTable_rXMM2 dflags = pc_OFFSET_StgRegTable_rXMM2 (platformConstants dflags)-oFFSET_StgRegTable_rXMM3 :: DynFlags -> Int-oFFSET_StgRegTable_rXMM3 dflags = pc_OFFSET_StgRegTable_rXMM3 (platformConstants dflags)-oFFSET_StgRegTable_rXMM4 :: DynFlags -> Int-oFFSET_StgRegTable_rXMM4 dflags = pc_OFFSET_StgRegTable_rXMM4 (platformConstants dflags)-oFFSET_StgRegTable_rXMM5 :: DynFlags -> Int-oFFSET_StgRegTable_rXMM5 dflags = pc_OFFSET_StgRegTable_rXMM5 (platformConstants dflags)-oFFSET_StgRegTable_rXMM6 :: DynFlags -> Int-oFFSET_StgRegTable_rXMM6 dflags = pc_OFFSET_StgRegTable_rXMM6 (platformConstants dflags)-oFFSET_StgRegTable_rYMM1 :: DynFlags -> Int-oFFSET_StgRegTable_rYMM1 dflags = pc_OFFSET_StgRegTable_rYMM1 (platformConstants dflags)-oFFSET_StgRegTable_rYMM2 :: DynFlags -> Int-oFFSET_StgRegTable_rYMM2 dflags = pc_OFFSET_StgRegTable_rYMM2 (platformConstants dflags)-oFFSET_StgRegTable_rYMM3 :: DynFlags -> Int-oFFSET_StgRegTable_rYMM3 dflags = pc_OFFSET_StgRegTable_rYMM3 (platformConstants dflags)-oFFSET_StgRegTable_rYMM4 :: DynFlags -> Int-oFFSET_StgRegTable_rYMM4 dflags = pc_OFFSET_StgRegTable_rYMM4 (platformConstants dflags)-oFFSET_StgRegTable_rYMM5 :: DynFlags -> Int-oFFSET_StgRegTable_rYMM5 dflags = pc_OFFSET_StgRegTable_rYMM5 (platformConstants dflags)-oFFSET_StgRegTable_rYMM6 :: DynFlags -> Int-oFFSET_StgRegTable_rYMM6 dflags = pc_OFFSET_StgRegTable_rYMM6 (platformConstants dflags)-oFFSET_StgRegTable_rZMM1 :: DynFlags -> Int-oFFSET_StgRegTable_rZMM1 dflags = pc_OFFSET_StgRegTable_rZMM1 (platformConstants dflags)-oFFSET_StgRegTable_rZMM2 :: DynFlags -> Int-oFFSET_StgRegTable_rZMM2 dflags = pc_OFFSET_StgRegTable_rZMM2 (platformConstants dflags)-oFFSET_StgRegTable_rZMM3 :: DynFlags -> Int-oFFSET_StgRegTable_rZMM3 dflags = pc_OFFSET_StgRegTable_rZMM3 (platformConstants dflags)-oFFSET_StgRegTable_rZMM4 :: DynFlags -> Int-oFFSET_StgRegTable_rZMM4 dflags = pc_OFFSET_StgRegTable_rZMM4 (platformConstants dflags)-oFFSET_StgRegTable_rZMM5 :: DynFlags -> Int-oFFSET_StgRegTable_rZMM5 dflags = pc_OFFSET_StgRegTable_rZMM5 (platformConstants dflags)-oFFSET_StgRegTable_rZMM6 :: DynFlags -> Int-oFFSET_StgRegTable_rZMM6 dflags = pc_OFFSET_StgRegTable_rZMM6 (platformConstants dflags)-oFFSET_StgRegTable_rL1 :: DynFlags -> Int-oFFSET_StgRegTable_rL1 dflags = pc_OFFSET_StgRegTable_rL1 (platformConstants dflags)-oFFSET_StgRegTable_rSp :: DynFlags -> Int-oFFSET_StgRegTable_rSp dflags = pc_OFFSET_StgRegTable_rSp (platformConstants dflags)-oFFSET_StgRegTable_rSpLim :: DynFlags -> Int-oFFSET_StgRegTable_rSpLim dflags = pc_OFFSET_StgRegTable_rSpLim (platformConstants dflags)-oFFSET_StgRegTable_rHp :: DynFlags -> Int-oFFSET_StgRegTable_rHp dflags = pc_OFFSET_StgRegTable_rHp (platformConstants dflags)-oFFSET_StgRegTable_rHpLim :: DynFlags -> Int-oFFSET_StgRegTable_rHpLim dflags = pc_OFFSET_StgRegTable_rHpLim (platformConstants dflags)-oFFSET_StgRegTable_rCCCS :: DynFlags -> Int-oFFSET_StgRegTable_rCCCS dflags = pc_OFFSET_StgRegTable_rCCCS (platformConstants dflags)-oFFSET_StgRegTable_rCurrentTSO :: DynFlags -> Int-oFFSET_StgRegTable_rCurrentTSO dflags = pc_OFFSET_StgRegTable_rCurrentTSO (platformConstants dflags)-oFFSET_StgRegTable_rCurrentNursery :: DynFlags -> Int-oFFSET_StgRegTable_rCurrentNursery dflags = pc_OFFSET_StgRegTable_rCurrentNursery (platformConstants dflags)-oFFSET_StgRegTable_rHpAlloc :: DynFlags -> Int-oFFSET_StgRegTable_rHpAlloc dflags = pc_OFFSET_StgRegTable_rHpAlloc (platformConstants dflags)-oFFSET_stgEagerBlackholeInfo :: DynFlags -> Int-oFFSET_stgEagerBlackholeInfo dflags = pc_OFFSET_stgEagerBlackholeInfo (platformConstants dflags)-oFFSET_stgGCEnter1 :: DynFlags -> Int-oFFSET_stgGCEnter1 dflags = pc_OFFSET_stgGCEnter1 (platformConstants dflags)-oFFSET_stgGCFun :: DynFlags -> Int-oFFSET_stgGCFun dflags = pc_OFFSET_stgGCFun (platformConstants dflags)-oFFSET_Capability_r :: DynFlags -> Int-oFFSET_Capability_r dflags = pc_OFFSET_Capability_r (platformConstants dflags)-oFFSET_bdescr_start :: DynFlags -> Int-oFFSET_bdescr_start dflags = pc_OFFSET_bdescr_start (platformConstants dflags)-oFFSET_bdescr_free :: DynFlags -> Int-oFFSET_bdescr_free dflags = pc_OFFSET_bdescr_free (platformConstants dflags)-oFFSET_bdescr_blocks :: DynFlags -> Int-oFFSET_bdescr_blocks dflags = pc_OFFSET_bdescr_blocks (platformConstants dflags)-oFFSET_bdescr_flags :: DynFlags -> Int-oFFSET_bdescr_flags dflags = pc_OFFSET_bdescr_flags (platformConstants dflags)-sIZEOF_CostCentreStack :: DynFlags -> Int-sIZEOF_CostCentreStack dflags = pc_SIZEOF_CostCentreStack (platformConstants dflags)-oFFSET_CostCentreStack_mem_alloc :: DynFlags -> Int-oFFSET_CostCentreStack_mem_alloc dflags = pc_OFFSET_CostCentreStack_mem_alloc (platformConstants dflags)-oFFSET_CostCentreStack_scc_count :: DynFlags -> Int-oFFSET_CostCentreStack_scc_count dflags = pc_OFFSET_CostCentreStack_scc_count (platformConstants dflags)-oFFSET_StgHeader_ccs :: DynFlags -> Int-oFFSET_StgHeader_ccs dflags = pc_OFFSET_StgHeader_ccs (platformConstants dflags)-oFFSET_StgHeader_ldvw :: DynFlags -> Int-oFFSET_StgHeader_ldvw dflags = pc_OFFSET_StgHeader_ldvw (platformConstants dflags)-sIZEOF_StgSMPThunkHeader :: DynFlags -> Int-sIZEOF_StgSMPThunkHeader dflags = pc_SIZEOF_StgSMPThunkHeader (platformConstants dflags)-oFFSET_StgEntCounter_allocs :: DynFlags -> Int-oFFSET_StgEntCounter_allocs dflags = pc_OFFSET_StgEntCounter_allocs (platformConstants dflags)-oFFSET_StgEntCounter_allocd :: DynFlags -> Int-oFFSET_StgEntCounter_allocd dflags = pc_OFFSET_StgEntCounter_allocd (platformConstants dflags)-oFFSET_StgEntCounter_registeredp :: DynFlags -> Int-oFFSET_StgEntCounter_registeredp dflags = pc_OFFSET_StgEntCounter_registeredp (platformConstants dflags)-oFFSET_StgEntCounter_link :: DynFlags -> Int-oFFSET_StgEntCounter_link dflags = pc_OFFSET_StgEntCounter_link (platformConstants dflags)-oFFSET_StgEntCounter_entry_count :: DynFlags -> Int-oFFSET_StgEntCounter_entry_count dflags = pc_OFFSET_StgEntCounter_entry_count (platformConstants dflags)-sIZEOF_StgUpdateFrame_NoHdr :: DynFlags -> Int-sIZEOF_StgUpdateFrame_NoHdr dflags = pc_SIZEOF_StgUpdateFrame_NoHdr (platformConstants dflags)-sIZEOF_StgMutArrPtrs_NoHdr :: DynFlags -> Int-sIZEOF_StgMutArrPtrs_NoHdr dflags = pc_SIZEOF_StgMutArrPtrs_NoHdr (platformConstants dflags)-oFFSET_StgMutArrPtrs_ptrs :: DynFlags -> Int-oFFSET_StgMutArrPtrs_ptrs dflags = pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants dflags)-oFFSET_StgMutArrPtrs_size :: DynFlags -> Int-oFFSET_StgMutArrPtrs_size dflags = pc_OFFSET_StgMutArrPtrs_size (platformConstants dflags)-sIZEOF_StgSmallMutArrPtrs_NoHdr :: DynFlags -> Int-sIZEOF_StgSmallMutArrPtrs_NoHdr dflags = pc_SIZEOF_StgSmallMutArrPtrs_NoHdr (platformConstants dflags)-oFFSET_StgSmallMutArrPtrs_ptrs :: DynFlags -> Int-oFFSET_StgSmallMutArrPtrs_ptrs dflags = pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants dflags)-sIZEOF_StgArrBytes_NoHdr :: DynFlags -> Int-sIZEOF_StgArrBytes_NoHdr dflags = pc_SIZEOF_StgArrBytes_NoHdr (platformConstants dflags)-oFFSET_StgArrBytes_bytes :: DynFlags -> Int-oFFSET_StgArrBytes_bytes dflags = pc_OFFSET_StgArrBytes_bytes (platformConstants dflags)-oFFSET_StgTSO_alloc_limit :: DynFlags -> Int-oFFSET_StgTSO_alloc_limit dflags = pc_OFFSET_StgTSO_alloc_limit (platformConstants dflags)-oFFSET_StgTSO_cccs :: DynFlags -> Int-oFFSET_StgTSO_cccs dflags = pc_OFFSET_StgTSO_cccs (platformConstants dflags)-oFFSET_StgTSO_stackobj :: DynFlags -> Int-oFFSET_StgTSO_stackobj dflags = pc_OFFSET_StgTSO_stackobj (platformConstants dflags)-oFFSET_StgStack_sp :: DynFlags -> Int-oFFSET_StgStack_sp dflags = pc_OFFSET_StgStack_sp (platformConstants dflags)-oFFSET_StgStack_stack :: DynFlags -> Int-oFFSET_StgStack_stack dflags = pc_OFFSET_StgStack_stack (platformConstants dflags)-oFFSET_StgUpdateFrame_updatee :: DynFlags -> Int-oFFSET_StgUpdateFrame_updatee dflags = pc_OFFSET_StgUpdateFrame_updatee (platformConstants dflags)-oFFSET_StgFunInfoExtraFwd_arity :: DynFlags -> Int-oFFSET_StgFunInfoExtraFwd_arity dflags = pc_OFFSET_StgFunInfoExtraFwd_arity (platformConstants dflags)-sIZEOF_StgFunInfoExtraRev :: DynFlags -> Int-sIZEOF_StgFunInfoExtraRev dflags = pc_SIZEOF_StgFunInfoExtraRev (platformConstants dflags)-oFFSET_StgFunInfoExtraRev_arity :: DynFlags -> Int-oFFSET_StgFunInfoExtraRev_arity dflags = pc_OFFSET_StgFunInfoExtraRev_arity (platformConstants dflags)-mAX_SPEC_SELECTEE_SIZE :: DynFlags -> Int-mAX_SPEC_SELECTEE_SIZE dflags = pc_MAX_SPEC_SELECTEE_SIZE (platformConstants dflags)-mAX_SPEC_AP_SIZE :: DynFlags -> Int-mAX_SPEC_AP_SIZE dflags = pc_MAX_SPEC_AP_SIZE (platformConstants dflags)-mIN_PAYLOAD_SIZE :: DynFlags -> Int-mIN_PAYLOAD_SIZE dflags = pc_MIN_PAYLOAD_SIZE (platformConstants dflags)-mIN_INTLIKE :: DynFlags -> Int-mIN_INTLIKE dflags = pc_MIN_INTLIKE (platformConstants dflags)-mAX_INTLIKE :: DynFlags -> Int-mAX_INTLIKE dflags = pc_MAX_INTLIKE (platformConstants dflags)-mIN_CHARLIKE :: DynFlags -> Int-mIN_CHARLIKE dflags = pc_MIN_CHARLIKE (platformConstants dflags)-mAX_CHARLIKE :: DynFlags -> Int-mAX_CHARLIKE dflags = pc_MAX_CHARLIKE (platformConstants dflags)-mUT_ARR_PTRS_CARD_BITS :: DynFlags -> Int-mUT_ARR_PTRS_CARD_BITS dflags = pc_MUT_ARR_PTRS_CARD_BITS (platformConstants dflags)-mAX_Vanilla_REG :: DynFlags -> Int-mAX_Vanilla_REG dflags = pc_MAX_Vanilla_REG (platformConstants dflags)-mAX_Float_REG :: DynFlags -> Int-mAX_Float_REG dflags = pc_MAX_Float_REG (platformConstants dflags)-mAX_Double_REG :: DynFlags -> Int-mAX_Double_REG dflags = pc_MAX_Double_REG (platformConstants dflags)-mAX_Long_REG :: DynFlags -> Int-mAX_Long_REG dflags = pc_MAX_Long_REG (platformConstants dflags)-mAX_XMM_REG :: DynFlags -> Int-mAX_XMM_REG dflags = pc_MAX_XMM_REG (platformConstants dflags)-mAX_Real_Vanilla_REG :: DynFlags -> Int-mAX_Real_Vanilla_REG dflags = pc_MAX_Real_Vanilla_REG (platformConstants dflags)-mAX_Real_Float_REG :: DynFlags -> Int-mAX_Real_Float_REG dflags = pc_MAX_Real_Float_REG (platformConstants dflags)-mAX_Real_Double_REG :: DynFlags -> Int-mAX_Real_Double_REG dflags = pc_MAX_Real_Double_REG (platformConstants dflags)-mAX_Real_XMM_REG :: DynFlags -> Int-mAX_Real_XMM_REG dflags = pc_MAX_Real_XMM_REG (platformConstants dflags)-mAX_Real_Long_REG :: DynFlags -> Int-mAX_Real_Long_REG dflags = pc_MAX_Real_Long_REG (platformConstants dflags)-rESERVED_C_STACK_BYTES :: DynFlags -> Int-rESERVED_C_STACK_BYTES dflags = pc_RESERVED_C_STACK_BYTES (platformConstants dflags)-rESERVED_STACK_WORDS :: DynFlags -> Int-rESERVED_STACK_WORDS dflags = pc_RESERVED_STACK_WORDS (platformConstants dflags)-aP_STACK_SPLIM :: DynFlags -> Int-aP_STACK_SPLIM dflags = pc_AP_STACK_SPLIM (platformConstants dflags)-wORD_SIZE :: DynFlags -> Int-wORD_SIZE dflags = pc_WORD_SIZE (platformConstants dflags)-cINT_SIZE :: DynFlags -> Int-cINT_SIZE dflags = pc_CINT_SIZE (platformConstants dflags)-cLONG_SIZE :: DynFlags -> Int-cLONG_SIZE dflags = pc_CLONG_SIZE (platformConstants dflags)-cLONG_LONG_SIZE :: DynFlags -> Int-cLONG_LONG_SIZE dflags = pc_CLONG_LONG_SIZE (platformConstants dflags)-bITMAP_BITS_SHIFT :: DynFlags -> Int-bITMAP_BITS_SHIFT dflags = pc_BITMAP_BITS_SHIFT (platformConstants dflags)-tAG_BITS :: DynFlags -> Int-tAG_BITS dflags = pc_TAG_BITS (platformConstants dflags)-dYNAMIC_BY_DEFAULT :: DynFlags -> Bool-dYNAMIC_BY_DEFAULT dflags = pc_DYNAMIC_BY_DEFAULT (platformConstants dflags)-lDV_SHIFT :: DynFlags -> Int-lDV_SHIFT dflags = pc_LDV_SHIFT (platformConstants dflags)-iLDV_CREATE_MASK :: DynFlags -> Integer-iLDV_CREATE_MASK dflags = pc_ILDV_CREATE_MASK (platformConstants dflags)-iLDV_STATE_CREATE :: DynFlags -> Integer-iLDV_STATE_CREATE dflags = pc_ILDV_STATE_CREATE (platformConstants dflags)-iLDV_STATE_USE :: DynFlags -> Integer-iLDV_STATE_USE dflags = pc_ILDV_STATE_USE (platformConstants dflags)
ghc-lib/stage0/lib/ghcautoconf.h view
@@ -83,6 +83,9 @@ /* Define to 1 if using `alloca.c'. */ /* #undef C_ALLOCA */ +/* Enable Native I/O manager as default. */+/* #undef DEFAULT_NATIVE_IO_MANAGER */+ /* Define to 1 if your processor stores words of floats with the most significant byte first */ /* #undef FLOAT_WORDS_BIGENDIAN */
ghc-lib/stage0/lib/ghcversion.h view
@@ -5,11 +5,11 @@ #define __GLASGOW_HASKELL__ 811 #endif #if !defined(__GLASGOW_HASKELL_FULL_VERSION__)-#define __GLASGOW_HASKELL_FULL_VERSION__ 8.11.0.20200703+#define __GLASGOW_HASKELL_FULL_VERSION__ "8.11.0.20200801" #endif #define __GLASGOW_HASKELL_PATCHLEVEL1__ 0-#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20200703+#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20200801 #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\ ((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \
ghc-lib/stage0/lib/settings view
@@ -38,7 +38,6 @@ ,("LLVM clang command", "clang") ,("BigNum backend", "native") ,("Use interpreter", "YES")-,("Use native code generator", "YES") ,("Support SMP", "YES") ,("RTS ways", "v thr") ,("Tables next to code", "YES")
ghc-lib/stage0/libraries/ghc-boot/build/GHC/Platform/Host.hs view
@@ -1,15 +1,12 @@ module GHC.Platform.Host where -import GHC.Platform+import GHC.Platform.ArchOS -cHostPlatformArch :: Arch-cHostPlatformArch = ArchX86_64+hostPlatformArch :: Arch+hostPlatformArch = ArchX86_64 -cHostPlatformOS :: OS-cHostPlatformOS = OSDarwin+hostPlatformOS :: OS+hostPlatformOS = OSDarwin -cHostPlatformMini :: PlatformMini-cHostPlatformMini = PlatformMini- { platformMini_arch = cHostPlatformArch- , platformMini_os = cHostPlatformOS- }+hostPlatformArchOS :: ArchOS+hostPlatformArchOS = ArchOS hostPlatformArch hostPlatformOS
− libraries/ghc-boot/GHC/Settings/Platform.hs
@@ -1,99 +0,0 @@--- Note [Settings file]--- ~~~~~~~~~~~~~~~~~~~~------ GHC has a file, `${top_dir}/settings`, which is the main source of run-time--- configuration. ghc-pkg needs just a little bit of it: the target platform CPU--- arch and OS. It uses that to figure out what subdirectory of `~/.ghc` is--- associated with the current version/target.------ This module has just enough code to read key value pairs from the settings--- file, and read the target platform from those pairs.------ The "0" suffix is because the caller will partially apply it, and that will--- in turn be used a few more times.-module GHC.Settings.Platform where--import Prelude -- See Note [Why do we import Prelude here?]--import GHC.BaseDir-import GHC.Platform-import GHC.Settings.Utils--import Data.Map (Map)-import qualified Data.Map as Map---------------------------------------------------------------------------------- parts of settings file--getTargetPlatform- :: FilePath -> RawSettings -> Either String Platform-getTargetPlatform settingsFile mySettings = do- let- getBooleanSetting = getBooleanSetting0 settingsFile mySettings- readSetting :: (Show a, Read a) => String -> Either String a- readSetting = readSetting0 settingsFile mySettings-- targetArch <- readSetting "target arch"- targetOS <- readSetting "target os"- targetWordSize <- readSetting "target word size"- targetWordBigEndian <- getBooleanSetting "target word big endian"- targetLeadingUnderscore <- getBooleanSetting "Leading underscore"- targetUnregisterised <- getBooleanSetting "Unregisterised"- targetHasGnuNonexecStack <- getBooleanSetting "target has GNU nonexec stack"- targetHasIdentDirective <- getBooleanSetting "target has .ident directive"- targetHasSubsectionsViaSymbols <- getBooleanSetting "target has subsections via symbols"- crossCompiling <- getBooleanSetting "cross compiling"- tablesNextToCode <- getBooleanSetting "Tables next to code"-- pure $ Platform- { platformMini = PlatformMini- { platformMini_arch = targetArch- , platformMini_os = targetOS- }- , platformWordSize = targetWordSize- , platformByteOrder = if targetWordBigEndian then BigEndian else LittleEndian- , platformUnregisterised = targetUnregisterised- , platformHasGnuNonexecStack = targetHasGnuNonexecStack- , platformHasIdentDirective = targetHasIdentDirective- , platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols- , platformIsCrossCompiling = crossCompiling- , platformLeadingUnderscore = targetLeadingUnderscore- , platformTablesNextToCode = tablesNextToCode- }---------------------------------------------------------------------------------- settings file helpers--type RawSettings = Map String String---- | See Note [Settings file] for "0" suffix-getSetting0- :: FilePath -> RawSettings -> String -> Either String String-getSetting0 settingsFile mySettings key = case Map.lookup key mySettings of- Just xs -> Right xs- Nothing -> Left $ "No entry for " ++ show key ++ " in " ++ show settingsFile---- | See Note [Settings file] for "0" suffix-getFilePathSetting0- :: FilePath -> FilePath -> RawSettings -> String -> Either String String-getFilePathSetting0 top_dir settingsFile mySettings key =- expandTopDir top_dir <$> getSetting0 settingsFile mySettings key---- | See Note [Settings file] for "0" suffix-getBooleanSetting0- :: FilePath -> RawSettings -> String -> Either String Bool-getBooleanSetting0 settingsFile mySettings key = do- rawValue <- getSetting0 settingsFile mySettings key- case rawValue of- "YES" -> Right True- "NO" -> Right False- xs -> Left $ "Bad value for " ++ show key ++ ": " ++ show xs---- | See Note [Settings file] for "0" suffix-readSetting0- :: (Show a, Read a) => FilePath -> RawSettings -> String -> Either String a-readSetting0 settingsFile mySettings key = case Map.lookup key mySettings of- Just xs -> case maybeRead xs of- Just v -> Right v- Nothing -> Left $ "Failed to read " ++ show key ++ " value " ++ show xs- Nothing -> Left $ "No entry for " ++ show key ++ " in " ++ show settingsFile
libraries/ghc-boot/GHC/Settings/Utils.hs view
@@ -3,7 +3,12 @@ import Prelude -- See Note [Why do we import Prelude here?] import Data.Char (isSpace)+import Data.Map (Map)+import qualified Data.Map as Map +import GHC.BaseDir+import GHC.Platform.ArchOS+ maybeRead :: Read a => String -> Maybe a maybeRead str = case reads str of [(x, "")] -> Just x@@ -13,3 +18,55 @@ maybeReadFuzzy str = case reads str of [(x, s)] | all isSpace s -> Just x _ -> Nothing+++-- Note [Settings file]+-- ~~~~~~~~~~~~~~~~~~~~+--+-- GHC has a file, `${top_dir}/settings`, which is the main source of run-time+-- configuration. ghc-pkg needs just a little bit of it: the target platform CPU+-- arch and OS. It uses that to figure out what subdirectory of `~/.ghc` is+-- associated with the current version/target platform.+--+-- This module has just enough code to read key value pairs from the settings+-- file, and read the target platform from those pairs.++type RawSettings = Map String String++-- | Read target Arch/OS from the settings+getTargetArchOS+ :: FilePath -- ^ Settings filepath (for error messages)+ -> RawSettings -- ^ Raw settings file contents+ -> Either String ArchOS+getTargetArchOS settingsFile settings =+ ArchOS <$> readRawSetting settingsFile settings "target arch"+ <*> readRawSetting settingsFile settings "target os"+++getRawSetting+ :: FilePath -> RawSettings -> String -> Either String String+getRawSetting settingsFile settings key = case Map.lookup key settings of+ Just xs -> Right xs+ Nothing -> Left $ "No entry for " ++ show key ++ " in " ++ show settingsFile++getRawFilePathSetting+ :: FilePath -> FilePath -> RawSettings -> String -> Either String String+getRawFilePathSetting top_dir settingsFile settings key =+ expandTopDir top_dir <$> getRawSetting settingsFile settings key++getRawBooleanSetting+ :: FilePath -> RawSettings -> String -> Either String Bool+getRawBooleanSetting settingsFile settings key = do+ rawValue <- getRawSetting settingsFile settings key+ case rawValue of+ "YES" -> Right True+ "NO" -> Right False+ xs -> Left $ "Bad value for " ++ show key ++ ": " ++ show xs++readRawSetting+ :: (Show a, Read a) => FilePath -> RawSettings -> String -> Either String a+readRawSetting settingsFile settings key = case Map.lookup key settings of+ Just xs -> case maybeRead xs of+ Just v -> Right v+ Nothing -> Left $ "Failed to read " ++ show key ++ " value " ++ show xs+ Nothing -> Left $ "No entry for " ++ show key ++ " in " ++ show settingsFile
libraries/ghci/GHCi/ResolvedBCO.hs view
@@ -21,9 +21,9 @@ isLittleEndian :: Bool #if defined(WORDS_BIGENDIAN)-isLittleEndian = True-#else isLittleEndian = False+#else+isLittleEndian = True #endif -- -----------------------------------------------------------------------------
+ libraries/template-haskell/Language/Haskell/TH/CodeDo.hs view
@@ -0,0 +1,20 @@+-- | This module exists to work nicely with the QualifiedDo+-- extension.+-- @+-- import qualified Language.Haskell.TH.CodeDo as Code+-- myExample :: Monad m => Code m a -> Code m a -> Code m a+-- myExample opt1 opt2 =+-- Code.do+-- x <- someSideEffect -- This one is of type `M Bool`+-- if x then opt1 else opt2+-- @+module Language.Haskell.TH.CodeDo((>>=), (>>)) where++import Language.Haskell.TH.Syntax+import Prelude(Monad)++-- | Module over monad operator for 'Code'+(>>=) :: Monad m => m a -> (a -> Code m b) -> Code m b+(>>=) = bindCode+(>>) :: Monad m => m a -> Code m b -> Code m b+(>>) = bindCode_