ghc-lib 0.20190703 → 0.20190806
raw patch · 184 files changed
+3342/−17821 lines, 184 filesdep −ghc-libdep −haskelinedep ~arraydep ~basedep ~bytestringsetup-changedPVP ok
version bump matches the API change (PVP)
Dependencies removed: ghc-lib, haskeline
Dependency ranges changed: array, base, bytestring, containers, deepseq, directory, filepath, ghc-lib-parser, ghc-prim, process, time, transformers
API changes (from Hackage documentation)
- CmmExpr: Float :: GlobalVecRegTy
- CmmExpr: Integer :: GlobalVecRegTy
- CmmExpr: data GlobalVecRegTy
- CmmExpr: instance GHC.Classes.Eq CmmExpr.GlobalVecRegTy
- CmmExpr: instance GHC.Classes.Ord CmmExpr.GlobalVecRegTy
- CmmExpr: instance GHC.Show.Show CmmExpr.GlobalVecRegTy
- CmmMachOp: MO_VF_Broadcast :: Length -> Width -> MachOp
- Format: FmtDouble :: ScalarFormat
- Format: FmtFloat :: ScalarFormat
- Format: FmtInt16 :: ScalarFormat
- Format: FmtInt32 :: ScalarFormat
- Format: FmtInt64 :: ScalarFormat
- Format: FmtInt8 :: ScalarFormat
- Format: VecFormat :: !Length -> !ScalarFormat -> !Width -> Format
- Format: data ScalarFormat
- Format: instance GHC.Classes.Eq Format.ScalarFormat
- Format: instance GHC.Show.Show Format.ScalarFormat
- Format: isVecFormat :: Format -> Bool
- HieAst: instance HieAst.ToHie (HieAst.Context (SrcLoc.Located HsExtension.NoExt))
- HieAst: instance HieAst.ToHie (HieAst.TScoped HsExtension.NoExt)
- Reg: VirtualRegVec :: {-# UNPACK #-} !Unique -> VirtualReg
- RegAlloc.Linear.FreeRegs: allFreeRegs :: FR freeRegs => Platform -> freeRegs -> [RealReg]
- RegClass: allRegClasses :: [RegClass]
- RegClass: instance GHC.Show.Show RegClass.RegClass
- StgSyn: data NoExtSilent
- StgSyn: instance Data.Data.Data StgSyn.NoExtSilent
- StgSyn: instance GHC.Classes.Eq StgSyn.NoExtSilent
- StgSyn: instance GHC.Classes.Ord StgSyn.NoExtSilent
- StgSyn: instance Outputable.Outputable StgSyn.NoExtSilent
- StgSyn: noExtSilent :: NoExtSilent
- TcDeriv: mkDerivInfos :: [LTyClDecl GhcRn] -> TcM [DerivInfo]
- TcTyClsDecls: kcConDecl :: NewOrData -> Kind -> ConDecl GhcRn -> TcM ()
- X86.Instr: INSERTPS :: Format -> Operand -> Operand -> Reg -> Instr
- X86.Instr: MOVH :: Format -> Operand -> Operand -> Instr
- X86.Instr: MOVL :: Format -> Operand -> Operand -> Instr
- X86.Instr: MOVU :: Format -> Operand -> Operand -> Instr
- X86.Instr: PSHUFD :: Format -> Operand -> Operand -> Reg -> Instr
- X86.Instr: PSLLDQ :: Format -> Operand -> Reg -> Instr
- X86.Instr: PSRLDQ :: Format -> Operand -> Reg -> Instr
- X86.Instr: VADD :: Format -> Operand -> Reg -> Reg -> Instr
- X86.Instr: VBROADCAST :: Format -> AddrMode -> Reg -> Instr
- X86.Instr: VDIV :: Format -> Operand -> Reg -> Reg -> Instr
- X86.Instr: VEXTRACT :: Format -> Operand -> Reg -> Operand -> Instr
- X86.Instr: VMOVU :: Format -> Operand -> Operand -> Instr
- X86.Instr: VMUL :: Format -> Operand -> Reg -> Reg -> Instr
- X86.Instr: VPSHUFD :: Format -> Operand -> Operand -> Reg -> Instr
- X86.Instr: VPXOR :: Format -> Reg -> Reg -> Reg -> Instr
- X86.Instr: VSUB :: Format -> Operand -> Reg -> Reg -> Instr
+ CmmUtils: cmmMkAssign :: DynFlags -> CmmExpr -> Unique -> (CmmNode O O, CmmExpr)
+ GhcPlugins: debugPprType :: Type -> SDoc
+ GhcPlugins: tyConAppNeedsKindSig :: Bool -> TyCon -> Int -> Bool
+ HieAst: instance HieAst.ToHie (HieAst.Context (SrcLoc.Located HsExtension.NoExtField))
+ HieAst: instance HieAst.ToHie (HieAst.TScoped HsExtension.NoExtField)
+ StgSyn: data NoExtFieldSilent
+ StgSyn: instance Data.Data.Data StgSyn.NoExtFieldSilent
+ StgSyn: instance GHC.Classes.Eq StgSyn.NoExtFieldSilent
+ StgSyn: instance GHC.Classes.Ord StgSyn.NoExtFieldSilent
+ StgSyn: instance Outputable.Outputable StgSyn.NoExtFieldSilent
+ StgSyn: noExtFieldSilent :: NoExtFieldSilent
+ StgSyn: stripStgTicksTopE :: (Tickish Id -> Bool) -> GenStgExpr p -> GenStgExpr p
+ SysTools.Tasks: traceToolCommand :: DynFlags -> String -> IO a -> IO a
+ TcTyClsDecls: kcConDecls :: NewOrData -> Kind -> [LConDecl GhcRn] -> TcM ()
- CmmExpr: XmmReg :: {-# UNPACK #-} !Int -> !Length -> !Width -> !GlobalVecRegTy -> GlobalReg
+ CmmExpr: XmmReg :: {-# UNPACK #-} !Int -> GlobalReg
- CmmExpr: YmmReg :: {-# UNPACK #-} !Int -> !Length -> !Width -> !GlobalVecRegTy -> GlobalReg
+ CmmExpr: YmmReg :: {-# UNPACK #-} !Int -> GlobalReg
- CmmExpr: ZmmReg :: {-# UNPACK #-} !Int -> !Length -> !Width -> !GlobalVecRegTy -> GlobalReg
+ CmmExpr: ZmmReg :: {-# UNPACK #-} !Int -> GlobalReg
- TcHsType: tcDerivStrategy :: forall a. Maybe (DerivStrategy GhcRn) -> TcM ([TyVar], a) -> TcM (Maybe (DerivStrategy GhcTc), [TyVar], a)
+ TcHsType: tcDerivStrategy :: Maybe (LDerivStrategy GhcRn) -> TcM (Maybe (LDerivStrategy GhcTc), [TyVar])
- TcHsType: tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], (Class, [Type], [Kind]))
+ TcHsType: tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind])
- TcInstDcls: tcInstDeclsDeriv :: [DerivInfo] -> [LTyClDecl GhcRn] -> [LDerivDecl GhcRn] -> TcM (TcGblEnv, [InstInfo GhcRn], HsValBinds GhcRn)
+ TcInstDcls: tcInstDeclsDeriv :: [DerivInfo] -> [LDerivDecl GhcRn] -> TcM (TcGblEnv, [InstInfo GhcRn], HsValBinds GhcRn)
Files
- Setup.hs +0/−2
- compiler/HsVersions.h +1/−1
- compiler/cmm/CmmBuildInfoTables.hs +3/−5
- compiler/cmm/CmmCallConv.hs +15/−25
- compiler/cmm/CmmContFlowOpt.hs +8/−1
- compiler/cmm/CmmExpr.hs +21/−62
- compiler/cmm/CmmImplementSwitchPlans.hs +27/−3
- compiler/cmm/CmmInfo.hs +9/−4
- compiler/cmm/CmmLint.hs +3/−7
- compiler/cmm/CmmMachOp.hs +9/−16
- compiler/cmm/CmmPipeline.hs +13/−7
- compiler/cmm/CmmUtils.hs +15/−0
- compiler/cmm/PprC.hs +0/−4
- compiler/cmm/PprCmmExpr.hs +3/−3
- compiler/cmm/SMRep.hs +2/−2
- compiler/codeGen/CgUtils.hs +21/−21
- compiler/codeGen/StgCmm.hs +2/−1
- compiler/codeGen/StgCmmArgRep.hs +2/−0
- compiler/codeGen/StgCmmBind.hs +1/−1
- compiler/codeGen/StgCmmClosure.hs +1/−0
- compiler/codeGen/StgCmmLayout.hs +1/−1
- compiler/codeGen/StgCmmPrim.hs +12/−43
- compiler/coreSyn/CoreLint.hs +12/−10
- compiler/deSugar/Check.hs +7/−7
- compiler/deSugar/Coverage.hs +23/−23
- compiler/deSugar/Desugar.hs +1/−1
- compiler/deSugar/DsArrows.hs +6/−6
- compiler/deSugar/DsBinds.hs +4/−4
- compiler/deSugar/DsExpr.hs +9/−9
- compiler/deSugar/DsForeign.hs +1/−1
- compiler/deSugar/DsGRHSs.hs +4/−4
- compiler/deSugar/DsListComp.hs +8/−8
- compiler/deSugar/DsMeta.hs +31/−31
- compiler/deSugar/DsUtils.hs +3/−3
- compiler/deSugar/ExtractDocs.hs +13/−13
- compiler/deSugar/Match.hs +8/−8
- compiler/deSugar/MatchLit.hs +4/−4
- compiler/ghci/ByteCodeGen.hs +2/−2
- compiler/hieFile/HieAst.hs +4/−4
- compiler/hsSyn/Convert.hs +215/−193
- compiler/iface/MkIface.hs +91/−9
- compiler/iface/TcIface.hs +1/−0
- compiler/llvmGen/LlvmCodeGen.hs +1/−1
- compiler/llvmGen/LlvmCodeGen/Base.hs +6/−6
- compiler/llvmGen/LlvmCodeGen/CodeGen.hs +3/−5
- compiler/llvmGen/LlvmCodeGen/Regs.hs +18/−18
- compiler/main/CodeOutput.hs +21/−20
- compiler/main/DriverPipeline.hs +5/−3
- compiler/main/GhcMake.hs +7/−27
- compiler/main/HscMain.hs +4/−2
- compiler/main/HscStats.hs +3/−3
- compiler/main/InteractiveEval.hs +60/−13
- compiler/main/SysTools.hs +3/−0
- compiler/main/SysTools/Tasks.hs +31/−18
- compiler/nativeGen/AsmCodeGen.hs +22/−17
- compiler/nativeGen/Format.hs +1/−54
- compiler/nativeGen/NCGMonad.hs +1/−0
- compiler/nativeGen/PPC/CodeGen.hs +0/−6
- compiler/nativeGen/PPC/Ppr.hs +6/−6
- compiler/nativeGen/Reg.hs +3/−11
- compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs +1/−0
- compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs +0/−5
- compiler/nativeGen/RegAlloc/Linear/Main.hs +2/−4
- compiler/nativeGen/RegClass.hs +8/−11
- compiler/nativeGen/SPARC/Ppr.hs +9/−5
- compiler/nativeGen/SPARC/Regs.hs +2/−0
- compiler/nativeGen/X86/CodeGen.hs +57/−467
- compiler/nativeGen/X86/Instr.hs +0/−81
- compiler/nativeGen/X86/Ppr.hs +6/−144
- compiler/nativeGen/X86/RegInfo.hs +0/−3
- compiler/nativeGen/X86/Regs.hs +0/−1
- compiler/rename/RnBinds.hs +36/−35
- compiler/rename/RnEnv.hs +2/−2
- compiler/rename/RnExpr.hs +62/−62
- compiler/rename/RnFixity.hs +1/−1
- compiler/rename/RnNames.hs +25/−25
- compiler/rename/RnPat.hs +7/−7
- compiler/rename/RnSource.hs +96/−180
- compiler/rename/RnSplice.hs +26/−25
- compiler/rename/RnTypes.hs +43/−43
- compiler/simplCore/SetLevels.hs +11/−2
- compiler/simplCore/SimplEnv.hs +3/−1
- compiler/simplCore/Simplify.hs +35/−0
- compiler/simplStg/StgLiftLams/Transformation.hs +4/−4
- compiler/stgSyn/CoreToStg.hs +10/−10
- compiler/stgSyn/StgSubst.hs +1/−1
- compiler/stgSyn/StgSyn.hs +22/−16
- compiler/typecheck/Inst.hs +3/−3
- compiler/typecheck/TcAnnotations.hs +1/−1
- compiler/typecheck/TcArrows.hs +5/−5
- compiler/typecheck/TcBinds.hs +21/−15
- compiler/typecheck/TcClassDcl.hs +2/−2
- compiler/typecheck/TcDefaults.hs +3/−3
- compiler/typecheck/TcDeriv.hs +286/−169
- compiler/typecheck/TcEnv.hs +6/−6
- compiler/typecheck/TcExpr.hs +29/−28
- compiler/typecheck/TcGenDeriv.hs +15/−15
- compiler/typecheck/TcHsSyn.hs +34/−34
- compiler/typecheck/TcHsType.hs +39/−79
- compiler/typecheck/TcInstDcls.hs +38/−37
- compiler/typecheck/TcMatches.hs +12/−12
- compiler/typecheck/TcPat.hs +1/−1
- compiler/typecheck/TcPatSyn.hs +23/−23
- compiler/typecheck/TcRnDriver.hs +18/−19
- compiler/typecheck/TcRnExports.hs +9/−9
- compiler/typecheck/TcRules.hs +6/−5
- compiler/typecheck/TcSigs.hs +4/−4
- compiler/typecheck/TcSplice.hs +27/−8
- compiler/typecheck/TcTyClsDecls.hs +127/−62
- compiler/typecheck/TcTyDecls.hs +7/−7
- compiler/typecheck/TcUnify.hs +29/−10
- compiler/typecheck/TcValidity.hs +61/−16
- ghc-lib.cabal +13/−47
- ghc-lib/generated/ghcplatform.h +0/−8
- ghc-lib/generated/ghcversion.h +1/−1
- ghc-lib/stage1/compiler/build/ghc_boot_platform.h +0/−8
- ghc-lib/stage1/compiler/build/primop-data-decl.hs-incl +0/−1
- ghc-lib/stage1/compiler/build/primop-has-side-effects.hs-incl +0/−1
- ghc-lib/stage1/compiler/build/primop-list.hs-incl +0/−1
- ghc-lib/stage1/compiler/build/primop-out-of-line.hs-incl +0/−1
- ghc-lib/stage1/compiler/build/primop-primop-info.hs-incl +0/−1
- ghc-lib/stage1/compiler/build/primop-tag.hs-incl +1203/−1204
- ghc-lib/stage1/lib/platformConstants +1/−1
- ghc-lib/stage1/lib/settings +1/−0
- ghc/GHCi/Leak.hs +0/−74
- ghc/GHCi/UI.hs +0/−4134
- ghc/GHCi/UI/Info.hs +0/−382
- ghc/GHCi/UI/Monad.hs +0/−553
- ghc/GHCi/UI/Tags.hs +0/−216
- ghc/GHCi/Util.hs +0/−16
- ghc/Main.hs +0/−966
- includes/Cmm.h +0/−946
- includes/CodeGen.Platform.hs +36/−36
- includes/HsFFI.h +0/−141
- includes/Rts.h +0/−325
- includes/RtsAPI.h +0/−487
- includes/Stg.h +0/−599
- includes/rts/Adjustor.h +0/−22
- includes/rts/BlockSignals.h +0/−34
- includes/rts/Bytecodes.h +0/−106
- includes/rts/Config.h +0/−52
- includes/rts/Constants.h +0/−332
- includes/rts/EventLogFormat.h +0/−265
- includes/rts/EventLogWriter.h +0/−40
- includes/rts/FileLock.h +0/−19
- includes/rts/Flags.h +0/−301
- includes/rts/GetTime.h +0/−16
- includes/rts/Globals.h +0/−36
- includes/rts/Hpc.h +0/−34
- includes/rts/IOManager.h +0/−43
- includes/rts/Libdw.h +0/−97
- includes/rts/LibdwPool.h +0/−19
- includes/rts/Linker.h +0/−101
- includes/rts/Main.h +0/−18
- includes/rts/Messages.h +0/−104
- includes/rts/OSThreads.h +0/−258
- includes/rts/Parallel.h +0/−16
- includes/rts/PrimFloat.h +0/−17
- includes/rts/Profiling.h +0/−17
- includes/rts/Signals.h +0/−23
- includes/rts/SpinLock.h +0/−116
- includes/rts/StableName.h +0/−32
- includes/rts/StablePtr.h +0/−35
- includes/rts/StaticPtrTable.h +0/−44
- includes/rts/TTY.h +0/−17
- includes/rts/Threads.h +0/−74
- includes/rts/Ticky.h +0/−32
- includes/rts/Time.h +0/−44
- includes/rts/Timer.h +0/−18
- includes/rts/Types.h +0/−31
- includes/rts/Utils.h +0/−16
- includes/rts/prof/CCS.h +0/−226
- includes/rts/prof/LDV.h +0/−44
- includes/rts/storage/Block.h +0/−341
- includes/rts/storage/ClosureMacros.h +0/−591
- includes/rts/storage/ClosureTypes.h +0/−86
- includes/rts/storage/Closures.h +0/−470
- includes/rts/storage/FunTypes.h +0/−54
- includes/rts/storage/GC.h +0/−248
- includes/rts/storage/Heap.h +0/−18
- includes/rts/storage/InfoTables.h +0/−405
- includes/rts/storage/MBlock.h +0/−32
- includes/rts/storage/TSO.h +0/−261
- libraries/ghci/GHCi/TH.hs +1/−0
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
compiler/HsVersions.h view
@@ -12,7 +12,7 @@ /* Useful in the headers that we share with the RTS */ #define COMPILING_GHC 1 -/* Pull in all the platform defines for this build (foo_TARGET_ARCH etc.) */+/* Pull in all the platform defines for this build (foo_HOST_ARCH etc.) */ #include "ghc_boot_platform.h" /* Pull in the autoconf defines (HAVE_FOO), but don't include
compiler/cmm/CmmBuildInfoTables.hs view
@@ -707,18 +707,16 @@ -- First resolve all the CAFLabels to SRTEntries -- Implements the [Inline] optimisation.- resolved =- Set.fromList $- catMaybes (map (resolveCAF srtMap) (Set.toList nonRec))+ resolved = mapMaybe (resolveCAF srtMap) (Set.toList nonRec) -- The set of all SRTEntries in SRTs that we refer to from here. allBelow =- Set.unions [ lbls | caf <- Set.toList resolved+ Set.unions [ lbls | caf <- resolved , Just lbls <- [Map.lookup caf (flatSRTs topSRT)] ] -- Remove SRTEntries that are also in an SRT that we refer to. -- Implements the [Filter] optimisation.- filtered = Set.difference resolved allBelow+ filtered = Set.difference (Set.fromList resolved) allBelow srtTrace "oneSRT:" (ppr cafs <+> ppr resolved <+> ppr allBelow <+> ppr filtered) $ return ()
compiler/cmm/CmmCallConv.hs view
@@ -64,20 +64,13 @@ assign_regs assts (r:rs) regs | isVecType ty = vec | isFloatType ty = float | otherwise = int- where vec = case regs of- (vs, fs, ds, ls, s:ss)- | passVectorInReg w dflags- -> let elt_ty = vecElemType ty- reg_ty = if isFloatType elt_ty- then Float else Integer- reg_class = case w of- W128 -> XmmReg- W256 -> YmmReg- W512 -> ZmmReg- _ -> panic "CmmCallConv.assignArgumentsPos: Invalid vector width"- in k (RegisterParam- (reg_class s (vecLength ty) (typeWidth elt_ty) reg_ty),- (vs, fs, ds, ls, ss))+ 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))+ (W256, (vs, fs, ds, ls, s:ss))+ | passVectorInReg W256 dflags -> 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)) _ -> (assts, (r:rs)) float = case (w, regs) of (W32, (vs, fs, ds, ls, s:ss))@@ -96,7 +89,6 @@ (_, (vs, fs, ds, l:ls, ss)) | widthInBits w > widthInBits (wordWidth dflags) -> k (RegisterParam l, (vs, fs, ds, ls, ss)) _ -> (assts, (r:rs))- k (asst, regs') = assign_regs ((r, asst) : assts) rs regs' ty = arg_ty r w = typeWidth ty@@ -210,13 +202,11 @@ -- only use this functionality in hand-written C-- code in the RTS. realArgRegsCover :: DynFlags -> [GlobalReg] realArgRegsCover dflags- | passFloatArgsInXmm dflags- = map ($VGcPtr) (realVanillaRegs dflags) ++- realLongRegs dflags ++- map (\x -> XmmReg x 2 W64 Integer) (realXmmRegNos dflags)- | otherwise- = map ($VGcPtr) (realVanillaRegs dflags) ++- realFloatRegs dflags ++- realDoubleRegs dflags ++- realLongRegs dflags ++- map (\x -> XmmReg x 2 W64 Integer) (realXmmRegNos dflags)+ | passFloatArgsInXmm dflags = map ($VGcPtr) (realVanillaRegs dflags) +++ realLongRegs dflags +++ map XmmReg (realXmmRegNos dflags)+ | otherwise = map ($VGcPtr) (realVanillaRegs dflags) +++ realFloatRegs dflags +++ realDoubleRegs dflags +++ realLongRegs dflags +++ map XmmReg (realXmmRegNos dflags)
compiler/cmm/CmmContFlowOpt.hs view
@@ -18,7 +18,7 @@ import BlockId import Cmm import CmmUtils-import CmmSwitch (mapSwitchTargets)+import CmmSwitch (mapSwitchTargets, switchTargetsToList) import Maybes import Panic import Util@@ -294,6 +294,13 @@ , likelyTrue l || (numPreds f > 1) , Just cond' <- maybeInvertCmmExpr cond = CmmCondBranch cond' f t (invertLikeliness l)++ -- If all jump destinations of a switch go to the+ -- same target eliminate the switch.+ | CmmSwitch _expr targets <- shortcut_last+ , (t:ts) <- switchTargetsToList targets+ , all (== t) ts+ = CmmBranch t | otherwise = shortcut_last
compiler/cmm/CmmExpr.hs view
@@ -14,7 +14,6 @@ , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg , node, baseReg , VGcPtr(..)- , GlobalVecRegTy(..) , DefinerOfRegs, UserOfRegs , foldRegsDefd, foldRegsUsed@@ -42,7 +41,6 @@ import Unique import Data.Set (Set)-import Data.Monoid ((<>)) import qualified Data.Set as Set import BasicTypes (Alignment, mkAlignment, alignmentOf)@@ -394,7 +392,6 @@ ----------------------------------------------------------------------------- {- Note [Overlapping global registers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The backend might not faithfully implement the abstraction of the STG machine with independent registers for different values of type@@ -416,26 +413,6 @@ equality of STG registers and does not take overlap into account. However it is still used in UserOfRegs/DefinerOfRegs and there are likely still bugs there, beware!---Note [SIMD registers]-~~~~~~~~~~~~~~~~~~~~~--GHC's treatment of SIMD registers is heavily modelled after the x86_64-architecture. Namely we have 128- (XMM), 256- (YMM), and 512-bit (ZMM)-registers. Furthermore, we treat each possible format in these registers as a-distinct register which overlaps with the others. For instance, we XMM1 as a-2xI64 register is distinct from but overlaps with (in the sense defined in Note-[Overlapping global registers]) its use as a 4xI32 register.--This model makes it easier to fit SIMD registers into the NCG, which generally-expects that each global register has a single, known CmmType.--In the future we could consider further refactoring this to eliminate the-XMM, YMM, and ZMM register names (which are quite x86-specific) and instead just-having a set of NxM-bit vector registers (e.g. Vec2x64A, Vec2x64B, ...,-Vec4x32A, ..., Vec4x64A).- -} data GlobalReg@@ -455,15 +432,12 @@ | XmmReg -- 128-bit SIMD vector register {-# UNPACK #-} !Int -- its number- !Length !Width !GlobalVecRegTy | YmmReg -- 256-bit SIMD vector register {-# UNPACK #-} !Int -- its number- !Length !Width !GlobalVecRegTy | ZmmReg -- 512-bit SIMD vector register {-# UNPACK #-} !Int -- its number- !Length !Width !GlobalVecRegTy -- STG registers | Sp -- Stack ptr; points to last occupied stack location.@@ -504,17 +478,17 @@ deriving( Show ) -data GlobalVecRegTy = Integer | Float- deriving (Show, Eq, Ord)- instance Eq GlobalReg where VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes FloatReg i == FloatReg j = i==j DoubleReg i == DoubleReg j = i==j LongReg i == LongReg j = i==j- XmmReg i l w grt == XmmReg j l' w' grt' = i==j && l == l' && w == w' && grt == grt'- YmmReg i l w grt == YmmReg j l' w' grt' = i==j && l == l' && w == w' && grt == grt'- ZmmReg i l w grt == ZmmReg j l' w' grt' = i==j && l == l' && w == w' && grt == grt'+ -- NOTE: XMM, YMM, ZMM registers actually are the same registers+ -- at least with respect to store at YMM i and then read from XMM i+ -- and similarly for ZMM etc.+ XmmReg i == XmmReg j = i==j+ YmmReg i == YmmReg j = i==j+ ZmmReg i == ZmmReg j = i==j Sp == Sp = True SpLim == SpLim = True Hp == Hp = True@@ -538,21 +512,9 @@ compare (FloatReg i) (FloatReg j) = compare i j compare (DoubleReg i) (DoubleReg j) = compare i j compare (LongReg i) (LongReg j) = compare i j- compare (XmmReg i l w grt)- (XmmReg j l' w' grt') = compare i j- <> compare l l'- <> compare w w'- <> compare grt grt'- compare (YmmReg i l w grt)- (YmmReg j l' w' grt') = compare i j- <> compare l l'- <> compare w w'- <> compare grt grt'- compare (ZmmReg i l w grt)- (ZmmReg j l' w' grt') = compare i j- <> compare l l'- <> compare w w'- <> compare grt grt'+ compare (XmmReg i) (XmmReg j) = compare i j+ compare (YmmReg i) (YmmReg j) = compare i j+ compare (ZmmReg i) (ZmmReg j) = compare i j compare Sp Sp = EQ compare SpLim SpLim = EQ compare Hp Hp = EQ@@ -576,12 +538,12 @@ compare _ (DoubleReg _) = GT compare (LongReg _) _ = LT compare _ (LongReg _) = GT- compare (XmmReg _ _ _ _) _ = LT- compare _ (XmmReg _ _ _ _) = GT- compare (YmmReg _ _ _ _) _ = LT- compare _ (YmmReg _ _ _ _) = GT- compare (ZmmReg _ _ _ _) _ = LT- compare _ (ZmmReg _ _ _ _) = GT+ compare (XmmReg _) _ = LT+ compare _ (XmmReg _) = GT+ compare (YmmReg _) _ = LT+ compare _ (YmmReg _) = GT+ compare (ZmmReg _) _ = LT+ compare _ (ZmmReg _) = GT compare Sp _ = LT compare _ Sp = GT compare SpLim _ = LT@@ -634,15 +596,12 @@ globalRegType _ (FloatReg _) = cmmFloat W32 globalRegType _ (DoubleReg _) = cmmFloat W64 globalRegType _ (LongReg _) = cmmBits W64-globalRegType _ (XmmReg _ l w ty) = case ty of- Integer -> cmmVec l (cmmBits w)- Float -> cmmVec l (cmmFloat w)-globalRegType _ (YmmReg _ l w ty) = case ty of- Integer -> cmmVec l (cmmBits w)- Float -> cmmVec l (cmmFloat w)-globalRegType _ (ZmmReg _ l w ty) = case ty of- Integer -> cmmVec l (cmmBits w)- Float -> cmmVec l (cmmFloat w)+-- TODO: improve the internal model of SIMD/vectorized registers+-- the right design SHOULd improve handling of float and double code too.+-- see remarks in "NOTE [SIMD Design for the future]"" in StgCmmPrim+globalRegType _ (XmmReg _) = cmmVec 4 (cmmBits W32)+globalRegType _ (YmmReg _) = cmmVec 8 (cmmBits W32)+globalRegType _ (ZmmReg _) = cmmVec 16 (cmmBits W32) globalRegType dflags Hp = gcWord dflags -- The initialiser for all
compiler/cmm/CmmImplementSwitchPlans.hs view
@@ -32,6 +32,7 @@ -- code generation. cmmImplementSwitchPlans :: DynFlags -> CmmGraph -> UniqSM CmmGraph cmmImplementSwitchPlans dflags g+ -- Switch generation done by backend (LLVM/C) | targetSupportsSwitch (hscTarget dflags) = return g | otherwise = do blocks' <- concat `fmap` mapM (visitSwitches dflags) (toBlockList g)@@ -39,18 +40,41 @@ visitSwitches :: DynFlags -> CmmBlock -> UniqSM [CmmBlock] visitSwitches dflags block- | (entry@(CmmEntry _ scope), middle, CmmSwitch expr ids) <- blockSplit block+ | (entry@(CmmEntry _ scope), middle, CmmSwitch vanillaExpr ids) <- blockSplit block = do let plan = createSwitchPlan ids+ -- See Note [Floating switch expressions]+ (assignSimple, simpleExpr) <- floatSwitchExpr dflags vanillaExpr - (newTail, newBlocks) <- implementSwitchPlan dflags scope expr plan+ (newTail, newBlocks) <- implementSwitchPlan dflags scope simpleExpr plan - let block' = entry `blockJoinHead` middle `blockAppend` newTail+ let block' = entry `blockJoinHead` middle `blockAppend` assignSimple `blockAppend` newTail return $ block' : newBlocks | otherwise = return [block]++-- Note [Floating switch expressions]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++-- When we translate a sparse switch into a search tree we would like+-- to compute the value we compare against only once.++-- For this purpose we assign the switch expression to a local register+-- and then use this register when constructing the actual binary tree.++-- This is important as the expression could contain expensive code like+-- memory loads or divisions which we REALLY don't want to duplicate.++-- This happend in parts of the handwritten RTS Cmm code. See also #16933++-- See Note [Floating switch expressions]+floatSwitchExpr :: DynFlags -> CmmExpr -> UniqSM (Block CmmNode O O, CmmExpr)+floatSwitchExpr _ reg@(CmmReg {}) = return (emptyBlock, reg)+floatSwitchExpr dflags expr = do+ (assign, expr') <- cmmMkAssign dflags expr <$> getUniqueM+ return (BMiddle assign, expr') -- Implementing a switch plan (returning a tail block)
compiler/cmm/CmmInfo.hs view
@@ -48,6 +48,7 @@ import GHC.Platform import Maybes import DynFlags+import ErrUtils (withTiming) import Panic import UniqSupply import MonadUtils@@ -70,12 +71,16 @@ -> IO (Stream IO RawCmmGroup ()) cmmToRawCmm dflags cmms = do { uniqs <- mkSplitUniqSupply 'i'- ; let do_one uniqs cmm = do- case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of- (b,uniqs') -> return (uniqs',b)- -- NB. strictness fixes a space leak. DO NOT REMOVE.+ ; let do_one uniqs cmm =+ -- NB. strictness fixes a space leak. DO NOT REMOVE.+ withTiming (return dflags) (text "Cmm -> Raw Cmm") forceRes $+ case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of+ (b,uniqs') -> return (uniqs',b) ; return (Stream.mapAccumL do_one uniqs cmms >> return ()) }++ where forceRes (uniqs, rawcmms) =+ uniqs `seq` foldr (\decl r -> decl `seq` r) () rawcmms -- Make a concrete info table, represented as a list of CmmStatic -- (it can't be simply a list of Word, because the SRT field is
compiler/cmm/CmmLint.hs view
@@ -148,13 +148,9 @@ dflags <- getDynFlags erep <- lintCmmExpr expr let reg_ty = cmmRegType dflags reg- case isVecCatType reg_ty of- True -> if ((typeWidth reg_ty) == (typeWidth erep))- then return ()- else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty- _ -> if (erep `cmmEqType_ignoring_ptrhood` reg_ty)- then return ()- else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty+ if (erep `cmmEqType_ignoring_ptrhood` reg_ty)+ then return ()+ else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty CmmStore l r -> do _ <- lintCmmExpr l
compiler/cmm/CmmMachOp.hs view
@@ -136,9 +136,8 @@ | MO_VU_Rem Length Width -- Floting point vector element insertion and extraction operations- | MO_VF_Broadcast Length Width -- Broadcast a scalar into a vector- | MO_VF_Insert Length Width -- Insert scalar into vector- | MO_VF_Extract Length Width -- Extract scalar from vector+ | MO_VF_Insert Length Width -- Insert scalar into vector+ | MO_VF_Extract Length Width -- Extract scalar from vector -- Floating point vector operations | MO_VF_Add Length Width@@ -431,7 +430,6 @@ MO_VU_Quot l w -> cmmVec l (cmmBits w) MO_VU_Rem l w -> cmmVec l (cmmBits w) - MO_VF_Broadcast l w -> cmmVec l (cmmFloat w) MO_VF_Insert l w -> cmmVec l (cmmFloat w) MO_VF_Extract _ w -> cmmFloat w @@ -524,21 +522,16 @@ MO_VU_Quot _ r -> [r,r] MO_VU_Rem _ r -> [r,r] - -- offset is always W32 as mentioned in StgCmmPrim.hs- MO_VF_Broadcast l r -> [vecwidth l r, r]- MO_VF_Insert l r -> [vecwidth l r, r, W32]- MO_VF_Extract l r -> [vecwidth l r, W32]+ MO_VF_Insert l r -> [typeWidth (vec l (cmmFloat r)),r,wordWidth dflags]+ MO_VF_Extract l r -> [typeWidth (vec l (cmmFloat r)),wordWidth dflags] - -- NOTE: The below is owing to the fact that floats use the SSE registers- MO_VF_Add l w -> [vecwidth l w, vecwidth l w]- MO_VF_Sub l w -> [vecwidth l w, vecwidth l w]- MO_VF_Mul l w -> [vecwidth l w, vecwidth l w]- MO_VF_Quot l w -> [vecwidth l w, vecwidth l w]- MO_VF_Neg l w -> [vecwidth l w]+ MO_VF_Add _ r -> [r,r]+ MO_VF_Sub _ r -> [r,r]+ MO_VF_Mul _ r -> [r,r]+ MO_VF_Quot _ r -> [r,r]+ MO_VF_Neg _ r -> [r] MO_AlignmentCheck _ r -> [r]- where- vecwidth l w = widthFromBytes (l*widthInBytes w) ----------------------------------------------------------------------------- -- CallishMachOp
compiler/cmm/CmmPipeline.hs view
@@ -39,7 +39,7 @@ -> CmmGroup -- Input C-- with Procedures -> IO (ModuleSRTInfo, CmmGroup) -- Output CPS transformed C-- -cmmPipeline hsc_env srtInfo prog =+cmmPipeline hsc_env srtInfo prog = withTiming (return dflags) (text "Cmm pipeline") forceRes $ do let dflags = hsc_dflags hsc_env tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog@@ -49,7 +49,11 @@ return (srtInfo, cmms) + where forceRes (info, group) =+ info `seq` foldr (\decl r -> decl `seq` r) () group + dflags = hsc_dflags hsc_env+ cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl]) cpsTop _ p@(CmmData {}) = return (mapEmpty, [p]) cpsTop hsc_env proc =@@ -75,6 +79,7 @@ -- Any work storing block Labels must be performed _after_ -- elimCommonBlocks + ----------- Implement switches ------------------------------------------ g <- {-# SCC "createSwitchPlans" #-} runUniqSM $ cmmImplementSwitchPlans dflags g dump Opt_D_dump_cmm_switch "Post switch plan" g@@ -352,9 +357,10 @@ dumpWith :: DynFlags -> DumpFlag -> String -> SDoc -> IO () dumpWith dflags flag txt sdoc = do- -- ToDo: No easy way of say "dump all the cmm, *and* split- -- them into files." Also, -ddump-cmm-verbose doesn't play- -- nicely with -ddump-to-file, since the headers get omitted.- dumpIfSet_dyn dflags flag txt sdoc- when (not (dopt flag dflags)) $- dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose txt sdoc+ dumpIfSet_dyn dflags flag txt sdoc+ when (not (dopt flag dflags)) $+ -- If `-ddump-cmm-verbose -ddump-to-file` is specified,+ -- dump each Cmm pipeline stage output to a separate file. #16930+ when (dopt Opt_D_dump_cmm_verbose dflags)+ $ dumpSDoc dflags alwaysQualify flag txt sdoc+ dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc txt sdoc
compiler/cmm/CmmUtils.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE GADTs, RankNTypes #-}+{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- --@@ -35,6 +36,8 @@ cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord, cmmToWord, + cmmMkAssign,+ isTrivialCmmExpr, hasNoGlobalRegs, isLit, isComparisonExpr, baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr,@@ -76,6 +79,7 @@ import CLabel import Outputable import DynFlags+import Unique import CodeGen.Platform import Data.ByteString (ByteString)@@ -102,6 +106,8 @@ primRepCmmType _ Word8Rep = b8 primRepCmmType _ Int16Rep = b16 primRepCmmType _ Word16Rep = b16+primRepCmmType _ Int32Rep = b32+primRepCmmType _ Word32Rep = b32 primRepCmmType _ Int64Rep = b64 primRepCmmType _ Word64Rep = b64 primRepCmmType dflags AddrRep = bWord dflags@@ -138,10 +144,12 @@ primRepForeignHint IntRep = SignedHint primRepForeignHint Int8Rep = SignedHint primRepForeignHint Int16Rep = SignedHint+primRepForeignHint Int32Rep = SignedHint primRepForeignHint Int64Rep = SignedHint primRepForeignHint WordRep = NoHint primRepForeignHint Word8Rep = NoHint primRepForeignHint Word16Rep = NoHint+primRepForeignHint Word32Rep = NoHint primRepForeignHint Word64Rep = NoHint primRepForeignHint AddrRep = AddrHint -- NB! AddrHint, but NonPtrArg primRepForeignHint FloatRep = NoHint@@ -371,6 +379,13 @@ where w = cmmExprWidth dflags e word = wordWidth dflags++cmmMkAssign :: DynFlags -> CmmExpr -> Unique -> (CmmNode O O, CmmExpr)+cmmMkAssign dflags expr uq =+ let !ty = cmmExprType dflags expr+ reg = (CmmLocal (LocalReg uq ty))+ in (CmmAssign reg expr, CmmReg reg)+ --------------------------------------------------- --
compiler/cmm/PprC.hs view
@@ -713,10 +713,6 @@ (panic $ "PprC.pprMachOp_for_C: MO_VU_Rem" ++ " should have been handled earlier!") - MO_VF_Broadcast {} -> pprTrace "offending mop:"- (text "MO_VF_Broadcast")- (panic $ "PprC.pprMachOp_for_C: MO_VF_Broadcast"- ++ " should have been handled earlier!") MO_VF_Insert {} -> pprTrace "offending mop:" (text "MO_VF_Insert") (panic $ "PprC.pprMachOp_for_C: MO_VF_Insert"
compiler/cmm/PprCmmExpr.hs view
@@ -261,9 +261,9 @@ FloatReg n -> char 'F' <> int n DoubleReg n -> char 'D' <> int n LongReg n -> char 'L' <> int n- XmmReg n _ _ _ -> text "XMM" <> int n- YmmReg n _ _ _ -> text "YMM" <> int n- ZmmReg n _ _ _ -> text "ZMM" <> int n+ XmmReg n -> text "XMM" <> int n+ YmmReg n -> text "YMM" <> int n+ ZmmReg n -> text "ZMM" <> int n Sp -> text "Sp" SpLim -> text "SpLim" Hp -> text "Hp"
compiler/cmm/SMRep.hs view
@@ -418,8 +418,8 @@ ----------------------------------------------------------------------------- -- deriving the RTS closure type from an SMRep -#include "../includes/rts/storage/ClosureTypes.h"-#include "../includes/rts/storage/FunTypes.h"+#include "rts/storage/ClosureTypes.h"+#include "rts/storage/FunTypes.h" -- Defines CONSTR, CONSTR_1_0 etc -- | Derives the RTS closure type from an 'SMRep'
compiler/codeGen/CgUtils.hs view
@@ -57,27 +57,27 @@ 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 (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
compiler/codeGen/StgCmm.hs view
@@ -32,6 +32,7 @@ import StgSyn import DynFlags+import ErrUtils import HscTypes import CostCentre@@ -70,7 +71,7 @@ ; cgref <- liftIO $ newIORef =<< initC ; let cg :: FCode () -> Stream IO CmmGroup () cg fcode = do- cmm <- liftIO $ do+ cmm <- liftIO . withTiming (return dflags) (text "STG -> Cmm") (`seq` ()) $ do st <- readIORef cgref let (a,st') = runC dflags this_mod st (getCmm fcode)
compiler/codeGen/StgCmmArgRep.hs view
@@ -74,6 +74,8 @@ toArgRep Word8Rep = N -- Gets widened to native word width for calls toArgRep Int16Rep = N -- Gets widened to native word width for calls toArgRep Word16Rep = N -- Gets widened to native word width for calls+toArgRep Int32Rep = N -- Gets widened to native word width for calls+toArgRep Word32Rep = N -- Gets widened to native word width for calls toArgRep AddrRep = N toArgRep Int64Rep = L toArgRep Word64Rep = L
compiler/codeGen/StgCmmBind.hs view
@@ -265,7 +265,7 @@ upd_flag -- Updatable thunk [] -- A thunk expr- | let strip = snd . stripStgTicksTop (not . tickishIsCode)+ | let strip = stripStgTicksTopE (not . tickishIsCode) , StgCase (StgApp scrutinee [{-no args-}]) _ -- ignore bndr (AlgAlt _)
compiler/codeGen/StgCmmClosure.hs view
@@ -170,6 +170,7 @@ idPrimRep id = typePrimRep1 (idType id) -- NB: typePrimRep1 fails on unboxed tuples, -- but by StgCmm no Ids have unboxed tuple type+ -- See also Note [VoidRep] in RepType addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)] addIdReps = map (\id -> let id' = fromNonVoid id
compiler/codeGen/StgCmmLayout.hs view
@@ -526,7 +526,7 @@ ------------------------------------------------------------------------- -- bring in ARG_P, ARG_N, etc.-#include "../includes/rts/storage/FunTypes.h"+#include "rts/storage/FunTypes.h" mkArgDescr :: DynFlags -> [Id] -> ArgDescr mkArgDescr dflags args
compiler/codeGen/StgCmmPrim.hs view
@@ -669,7 +669,7 @@ -- SIMD primops emitPrimOp dflags [res] (VecBroadcastOp vcat n w) [e] = do checkVecCompatibility dflags vcat n w- doVecBroadcastOp (vecElemInjectCast dflags vcat w) ty zeros e res+ doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros (replicate n e) res where zeros :: CmmExpr zeros = CmmLit $ CmmVec (replicate n zero)@@ -1765,8 +1765,9 @@ checkVecCompatibility :: DynFlags -> PrimOpVecCat -> Length -> Width -> FCode () checkVecCompatibility dflags vcat l w = do- when (hscTarget dflags /= HscLlvm && hscTarget dflags /= HscAsm) $ do- sorry "SIMD vector instructions not supported for the C backend or GHCi"+ when (hscTarget dflags /= HscLlvm) $ do+ sorry $ unlines ["SIMD vector instructions require the LLVM back-end."+ ,"Please use -fllvm."] check vecWidth vcat l w where check :: Width -> PrimOpVecCat -> Length -> Width -> FCode ()@@ -1791,39 +1792,7 @@ ------------------------------------------------------------------------------ -- Helpers for translating vector packing and unpacking.-doVecBroadcastOp :: Maybe MachOp -- Cast from element to vector component- -> CmmType -- Type of vector- -> CmmExpr -- Initial vector- -> CmmExpr -- Elements- -> CmmFormal -- Destination for result- -> FCode ()-doVecBroadcastOp maybe_pre_write_cast ty z es res = do- dst <- newTemp ty- emitAssign (CmmLocal dst) z- vecBroadcast dst es 0- where- vecBroadcast :: CmmFormal -> CmmExpr -> Int -> FCode ()- vecBroadcast src e _ = do- dst <- newTemp ty- if isFloatType (vecElemType ty)- then emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Broadcast len wid)- [CmmReg (CmmLocal src), cast e])- --TODO : Add the MachOp MO_V_Broadcast- else emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Insert len wid)- [CmmReg (CmmLocal src), cast e])- emitAssign (CmmLocal res) (CmmReg (CmmLocal dst)) - cast :: CmmExpr -> CmmExpr- cast val = case maybe_pre_write_cast of- Nothing -> val- Just cast -> CmmMachOp cast [val]-- len :: Length- len = vecLength ty-- wid :: Width- wid = typeWidth (vecElemType ty)- doVecPackOp :: Maybe MachOp -- Cast from element to vector component -> CmmType -- Type of vector -> CmmExpr -- Initial vector@@ -1840,16 +1809,16 @@ emitAssign (CmmLocal res) (CmmReg (CmmLocal src)) vecPack src (e : es) i = do- dst <- newTemp ty- if isFloatType (vecElemType ty)- then emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Insert len wid)- [CmmReg (CmmLocal src), cast e, iLit])- else emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Insert len wid)- [CmmReg (CmmLocal src), cast e, iLit])- vecPack dst es (i + 1)+ dst <- newTemp ty+ if isFloatType (vecElemType ty)+ then emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Insert len wid)+ [CmmReg (CmmLocal src), cast e, iLit])+ else emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Insert len wid)+ [CmmReg (CmmLocal src), cast e, iLit])+ vecPack dst es (i + 1) where -- vector indices are always 32-bits- iLit = CmmLit (CmmInt ((toInteger i) * 16) W32)+ iLit = CmmLit (CmmInt (toInteger i) W32) cast :: CmmExpr -> CmmExpr cast val = case maybe_pre_write_cast of
compiler/coreSyn/CoreLint.hs view
@@ -49,6 +49,8 @@ import Type import RepType import TyCoRep -- checks validity of types/coercions+import TyCoSubst+import TyCoFVs import TyCon import CoAxiom import BasicTypes@@ -786,8 +788,10 @@ lintCoreExpr e@(Case scrut var alt_ty alts) = -- Check the scrutinee- do { let scrut_diverges = exprIsBottom scrut- ; scrut_ty <- markAllJoinsBad $ lintCoreExpr scrut+ do { scrut_ty <- markAllJoinsBad $ lintCoreExpr scrut+ -- See Note [Join points are less general than the paper]+ -- in CoreSyn+ ; (alt_ty, _) <- lintInTy alt_ty ; (var_ty, _) <- lintInTy (idType var) @@ -810,7 +814,7 @@ , isAlgTyCon tycon , not (isAbstractTyCon tycon) , null (tyConDataCons tycon)- , not scrut_diverges+ , not (exprIsBottom scrut) -> pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var)) -- This can legitimately happen for type families $ return ()@@ -880,6 +884,7 @@ lintCoreFun expr nargs = markAllJoinsBadIf (nargs /= 0) $+ -- See Note [Join points are less general than the paper] lintCoreExpr expr ------------------@@ -1048,7 +1053,7 @@ ; in_scope <- getInScope -- substTy needs the set of tyvars in scope to avoid generating -- uniques that are already in scope.- -- See Note [The substitution invariant] in TyCoRep+ -- See Note [The substitution invariant] in TyCoSubst ; return (substTyWithInScope in_scope [tv] [arg_ty] body_ty) } | otherwise@@ -1492,7 +1497,7 @@ lint_app doc kfn kas = do { in_scope <- getInScope -- We need the in_scope set to satisfy the invariant in- -- Note [The substitution invariant] in TyCoRep+ -- Note [The substitution invariant] in TyCoSubst ; foldlM (go_app in_scope) kfn kas } where fail_msg extra = vcat [ hang (text "Kind application error in") 2 doc@@ -1714,7 +1719,7 @@ -- scope. All the free vars of `t2` and `kind_co` should -- already be in `in_scope`, because they've been -- linted and `tv2` has the same unique as `tv1`.- -- See Note [The substitution invariant]+ -- See Note [The substitution invariant] in TyCoSubst. unitVarEnv tv1 (TyVarTy tv2 `mkCastTy` mkSymCo kind_co) tyr = mkInvForAllTy tv2 $ substTy subst t2@@ -1745,7 +1750,7 @@ -- scope. All the free vars of `t2` and `kind_co` should -- already be in `in_scope`, because they've been -- linted and `cv2` has the same unique as `cv1`.- -- See Note [The substitution invariant]+ -- See Note [The substitution invariant] in TyCoSubst. unitVarEnv cv1 (eta1 `mkTransCo` (mkCoVarCo cv2) `mkTransCo` (mkSymCo eta2)) tyr = mkTyCoInvForAllTy cv2 $@@ -2281,9 +2286,6 @@ addGoodJoins :: [Var] -> LintM a -> LintM a addGoodJoins vars thing_inside- | null join_ids- = thing_inside- | otherwise = LintM $ \ env errs -> unLintM thing_inside (add_joins env) errs where add_joins env = env { le_joins = le_joins env `extendVarSetList` join_ids }
compiler/deSugar/Check.hs view
@@ -375,12 +375,12 @@ let combinedLoc = foldl1 combineSrcSpans (map getLoc grhss) dsMatchContext = DsMatchContext hs_ctx combinedLoc match = cL combinedLoc $- Match { m_ext = noExt+ Match { m_ext = noExtField , m_ctxt = hs_ctx , m_pats = [] , m_grhss = guards } checkMatches dflags dsMatchContext [] [match]-checkGuardMatches _ (XGRHSs _) = panic "checkGuardMatches"+checkGuardMatches _ (XGRHSs nec) = noExtCon nec -- | Check a matchgroup (case, functions, etc.) checkMatches :: DynFlags -> DsMatchContext@@ -1008,7 +1008,7 @@ case res of True -> do (xp,xe) <- mkPmId2Forms arg_ty- g <- mkGuard ps (HsApp noExt lexpr xe)+ g <- mkGuard ps (HsApp noExtField lexpr xe) return [xp,g] False -> mkCanFailPmPat arg_ty @@ -1066,7 +1066,7 @@ , isStringTy ty -> foldr (mkListPatVec charTy) [nilPattern charTy] <$> translatePatVec fam_insts- (map (LitPat noExt . HsChar src) (unpackFS s))+ (map (LitPat noExtField . HsChar src) (unpackFS s)) | otherwise -> return [PmLit { pm_lit_lit = PmOLit (isJust mb_neg) olit }] -- See Note [Translate Overloaded Literal for Exhaustiveness Checking]@@ -1074,7 +1074,7 @@ | HsString src s <- lit -> foldr (mkListPatVec charTy) [nilPattern charTy] <$> translatePatVec fam_insts- (map (LitPat noExt . HsChar src) (unpackFS s))+ (map (LitPat noExtField . HsChar src) (unpackFS s)) | otherwise -> return [mkLitPattern lit] TuplePat tys ps boxity -> do@@ -1312,7 +1312,7 @@ TransStmt {} -> panic "translateGuard TransStmt" RecStmt {} -> panic "translateGuard RecStmt" ApplicativeStmt {} -> panic "translateGuard ApplicativeLastStmt"- XStmtLR {} -> panic "translateGuard RecStmt"+ XStmtLR nec -> noExtCon nec -- | Translate let-bindings translateLet :: HsLocalBinds GhcTc -> DsM PatVec@@ -1713,7 +1713,7 @@ mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr GhcTc) mkPmId2Forms ty = do x <- mkPmId ty- return (PmVar x, noLoc (HsVar noExt (noLoc x)))+ return (PmVar x, noLoc (HsVar noExtField (noLoc x))) -- ---------------------------------------------------------------------------- -- * Converting between Value Abstractions, Patterns and PmExpr
compiler/deSugar/Coverage.hs view
@@ -327,7 +327,7 @@ where -- a binding is a simple pattern binding if it is a funbind with -- zero patterns- isSimplePatBind :: HsBind a -> Bool+ isSimplePatBind :: HsBind GhcTc -> Bool isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0 -- TODO: Revisit this@@ -640,7 +640,7 @@ addTickTupArg (dL->L l (Present x e)) = do { e' <- addTickLHsExpr e ; return (cL l (Present x e')) } addTickTupArg (dL->L l (Missing ty)) = return (cL l (Missing ty))-addTickTupArg (dL->L _ (XTupArg _)) = panic "addTickTupArg"+addTickTupArg (dL->L _ (XTupArg nec)) = noExtCon nec addTickTupArg _ = panic "addTickTupArg: Impossible Match" -- due to #15884 @@ -650,7 +650,7 @@ let isOneOfMany = matchesOneOfMany matches matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches return $ mg { mg_alts = cL l matches' }-addTickMatchGroup _ (XMatchGroup _) = panic "addTickMatchGroup"+addTickMatchGroup _ (XMatchGroup nec) = noExtCon nec addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc) -> TM (Match GhcTc (LHsExpr GhcTc))@@ -659,7 +659,7 @@ bindLocals (collectPatsBinders pats) $ do gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs return $ match { m_grhss = gRHSs' }-addTickMatch _ _ (XMatch _) = panic "addTickMatch"+addTickMatch _ _ (XMatch nec) = noExtCon nec addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc) -> TM (GRHSs GhcTc (LHsExpr GhcTc))@@ -670,7 +670,7 @@ return $ GRHSs x guarded' (cL l local_binds') where binders = collectLocalBinders local_binds-addTickGRHSs _ _ (XGRHSs _) = panic "addTickGRHSs"+addTickGRHSs _ _ (XGRHSs nec) = noExtCon nec addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc) -> TM (GRHS GhcTc (LHsExpr GhcTc))@@ -678,7 +678,7 @@ (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts (addTickGRHSBody isOneOfMany isLambda expr) return $ GRHS x stmts' expr'-addTickGRHS _ _ (XGRHS _) = panic "addTickGRHS"+addTickGRHS _ _ (XGRHS nec) = noExtCon nec addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) addTickGRHSBody isOneOfMany isLambda expr@(dL->L pos e0) = do@@ -757,7 +757,7 @@ ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret' , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } -addTickStmt _ (XStmtLR _) = panic "addTickStmt"+addTickStmt _ (XStmtLR nec) = noExtCon nec addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e@@ -779,7 +779,7 @@ <$> addTickLStmts isGuard stmts <*> (unLoc <$> addTickLHsExpr (cL hpcSrcSpan ret)) <*> addTickLPat pat- addTickArg (XApplicativeArg _) = panic "addTickApplicativeArg"+ addTickArg (XApplicativeArg nec) = noExtCon nec addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc -> TM (ParStmtBlock GhcTc GhcTc)@@ -788,7 +788,7 @@ (addTickLStmts isGuard stmts) (return ids) (addTickSyntaxExpr hpcSrcSpan returnExpr)-addTickStmtAndBinders _ (XParStmtBlock{}) = panic "addTickStmtAndBinders"+addTickStmtAndBinders _ (XParStmtBlock nec) = noExtCon nec addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc) addTickHsLocalBinds (HsValBinds x binds) =@@ -841,7 +841,7 @@ liftM2 HsCmdTop (return x) (addTickLHsCmd cmd)-addTickHsCmdTop (XCmdTop{}) = panic "addTickHsCmdTop"+addTickHsCmdTop (XCmdTop nec) = noExtCon nec addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc) addTickLHsCmd (dL->L pos c0) = do@@ -897,7 +897,7 @@ addTickHsCmd (HsCmdWrap x w cmd) = liftM2 (HsCmdWrap x) (return w) (addTickHsCmd cmd) -addTickHsCmd e@(XCmd {}) = pprPanic "addTickHsCmd" (ppr e)+addTickHsCmd (XCmd nec) = noExtCon nec -- Others should never happen in a command context. --addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e)@@ -907,14 +907,14 @@ addTickCmdMatchGroup mg@(MG { mg_alts = (dL->L l matches) }) = do matches' <- mapM (liftL addTickCmdMatch) matches return $ mg { mg_alts = cL l matches' }-addTickCmdMatchGroup (XMatchGroup _) = panic "addTickCmdMatchGroup"+addTickCmdMatchGroup (XMatchGroup nec) = noExtCon nec addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc)) addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) = bindLocals (collectPatsBinders pats) $ do gRHSs' <- addTickCmdGRHSs gRHSs return $ match { m_grhss = gRHSs' }-addTickCmdMatch (XMatch _) = panic "addTickCmdMatch"+addTickCmdMatch (XMatch nec) = noExtCon nec addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc)) addTickCmdGRHSs (GRHSs x guarded (dL->L l local_binds)) = do@@ -924,7 +924,7 @@ return $ GRHSs x guarded' (cL l local_binds') where binders = collectLocalBinders local_binds-addTickCmdGRHSs (XGRHSs _) = panic "addTickCmdGRHSs"+addTickCmdGRHSs (XGRHSs nec) = noExtCon nec addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc)) -- The *guards* are *not* Cmds, although the body is@@ -933,7 +933,7 @@ = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts (addTickLHsCmd cmd) ; return $ GRHS x stmts' expr' }-addTickCmdGRHS (XGRHS _) = panic "addTickCmdGRHS"+addTickCmdGRHS (XGRHS nec) = noExtCon nec addTickLCmdStmts :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM [LStmt GhcTc (LHsCmd GhcTc)]@@ -980,8 +980,8 @@ , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } addTickCmdStmt ApplicativeStmt{} = panic "ToDo: addTickCmdStmt ApplicativeLastStmt"-addTickCmdStmt XStmtLR{} =- panic "addTickCmdStmt XStmtLR"+addTickCmdStmt (XStmtLR nec) =+ noExtCon nec -- Others should never happen in a command context. addTickCmdStmt stmt = pprPanic "addTickHsCmd" (ppr stmt)@@ -1175,7 +1175,7 @@ (fvs, e) <- getFreeVars m env <- getEnv tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)- return (cL pos (HsTick noExt tickish (cL pos e)))+ return (cL pos (HsTick noExtField tickish (cL pos e))) ) (do e <- m return (cL pos e)@@ -1262,8 +1262,8 @@ c = tickBoxCount st mes = mixEntries st in- ( cL pos $ HsTick noExt (HpcTick (this_mod env) c)- $ cL pos $ HsBinTick noExt (c+1) (c+2) e+ ( cL pos $ HsTick noExtField (HpcTick (this_mod env) c)+ $ cL pos $ HsBinTick noExtField (c+1) (c+2) e -- notice that F and T are reversed, -- because we are building the list in -- reverse...@@ -1292,9 +1292,9 @@ where matchCount (dL->L _ (Match { m_grhss = GRHSs _ grhss _ })) = length grhss- matchCount (dL->L _ (Match { m_grhss = XGRHSs _ }))- = panic "matchesOneOfMany"- matchCount (dL->L _ (XMatch _)) = panic "matchesOneOfMany"+ matchCount (dL->L _ (Match { m_grhss = XGRHSs nec }))+ = noExtCon nec+ matchCount (dL->L _ (XMatch nec)) = noExtCon nec matchCount _ = panic "matchCount: Impossible Match" -- due to #15884 type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
compiler/deSugar/Desugar.hs view
@@ -412,7 +412,7 @@ ; return (Just rule) } } }-dsRule (dL->L _ (XRuleDecl _)) = panic "dsRule"+dsRule (dL->L _ (XRuleDecl nec)) = noExtCon nec dsRule _ = panic "dsRule: Impossible Match" -- due to #15884 warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM ()
compiler/deSugar/DsArrows.hs view
@@ -592,11 +592,11 @@ left_con <- dsLookupDataCon leftDataConName right_con <- dsLookupDataCon rightDataConName let- left_id = HsConLikeOut noExt (RealDataCon left_con)- right_id = HsConLikeOut noExt (RealDataCon right_con)- left_expr ty1 ty2 e = noLoc $ HsApp noExt+ left_id = HsConLikeOut noExtField (RealDataCon left_con)+ right_id = HsConLikeOut noExtField (RealDataCon right_con)+ left_expr ty1 ty2 e = noLoc $ HsApp noExtField (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e- right_expr ty1 ty2 e = noLoc $ HsApp noExt+ right_expr ty1 ty2 e = noLoc $ HsApp noExtField (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e -- Prefix each tuple with a distinct series of Left's and Right's,@@ -616,7 +616,7 @@ (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches in_ty = envStackType env_ids stack_ty - core_body <- dsExpr (HsCase noExt exp+ core_body <- dsExpr (HsCase noExtField exp (MG { mg_alts = cL l matches' , mg_ext = MatchGroupTc arg_tys sum_ty , mg_origin = origin }))@@ -1167,7 +1167,7 @@ = let (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss in- (leaves', cL loc (match { m_ext = noExt, m_grhss = GRHSs x grhss' binds }))+ (leaves', cL loc (match { m_ext = noExtField, m_grhss = GRHSs x grhss' binds })) replaceLeavesMatch _ _ _ = panic "replaceLeavesMatch" replaceLeavesGRHS
compiler/deSugar/DsBinds.hs view
@@ -198,7 +198,7 @@ ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig } dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"-dsHsBind _ (XHsBindsLR{}) = panic "dsHsBind: XHsBindsLR"+dsHsBind _ (XHsBindsLR nec) = noExtCon nec -----------------------@@ -258,7 +258,7 @@ ; return (makeCorePair dflags global (isDefaultMethod prags) 0 (core_wrap (Var local))) }- mk_bind (XABExport _) = panic "dsAbsBinds"+ mk_bind (XABExport nec) = noExtCon nec ; main_binds <- mapM mk_bind exports ; return (force_vars, flattenBinds ds_ev_binds ++ bind_prs ++ main_binds) }@@ -303,7 +303,7 @@ -- the user written (local) function. The global -- Id is just the selector. Hmm. ; return ((global', rhs) : fromOL spec_binds) }- mk_bind (XABExport _) = panic "dsAbsBinds"+ mk_bind (XABExport nec) = noExtCon nec ; export_binds_s <- mapM mk_bind (exports ++ extra_exports) @@ -351,7 +351,7 @@ mk_export local = do global <- newSysLocalDs (exprType (mkLams tyvars (mkLams dicts (Var local))))- return (ABE { abe_ext = noExt+ return (ABE { abe_ext = noExtField , abe_poly = global , abe_mono = local , abe_wrap = WpHole
compiler/deSugar/DsExpr.hs view
@@ -98,7 +98,7 @@ = do e' <- dsLExpr e return (Let (NonRec n e') body) ds_ip_bind _ _ = panic "dsIPBinds"-dsIPBinds (XHsIPBinds _) _ = panic "dsIPBinds"+dsIPBinds (XHsIPBinds nec) _ = noExtCon nec ------------------------- -- caller sets location@@ -451,7 +451,7 @@ | otherwise = do { match_result <- liftM (foldr1 combineMatchResults) (mapM (dsGRHS IfAlt res_ty) alts)- ; checkGuardMatches IfAlt (GRHSs noExt alts (noLoc emptyLocalBinds))+ ; checkGuardMatches IfAlt (GRHSs noExtField alts (noLoc emptyLocalBinds)) ; error_expr <- mkErrorExpr ; extractMatchResult match_result error_expr } where@@ -663,7 +663,7 @@ mk_val_arg fl pat_arg_id = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id) - inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut noExt con)+ inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut noExtField con) -- Reconstruct with the WrapId so that unpacking happens wrap = mkWpEvVarApps theta_vars <.> dict_req_wrap <.>@@ -754,7 +754,7 @@ ds_expr _ (HsBracket {}) = panic "dsExpr:HsBracket" ds_expr _ (HsDo {}) = panic "dsExpr:HsDo" ds_expr _ (HsRecFld {}) = panic "dsExpr:HsRecFld"-ds_expr _ (XExpr {}) = panic "dsExpr: XExpr"+ds_expr _ (XExpr nec) = noExtCon nec ------------------------------@@ -927,7 +927,7 @@ (pat, dsLExpr expr) do_arg (ApplicativeArgMany _ stmts ret pat) = (pat, dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))- do_arg (XApplicativeArg _) = panic "dsDo"+ do_arg (XApplicativeArg nec) = noExtCon nec arg_tys = map hsLPatType pats @@ -935,7 +935,7 @@ ; let body' = noLoc $ HsDo body_ty DoExpr (noLoc stmts) - ; let fun = cL noSrcSpan $ HsLam noExt $+ ; let fun = cL noSrcSpan $ HsLam noExtField $ MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr pats body'] , mg_ext = MatchGroupTc arg_tys body_ty@@ -967,13 +967,13 @@ later_pats = rec_tup_pats rets = map noLoc rec_rets mfix_app = nlHsSyntaxApps mfix_op [mfix_arg]- mfix_arg = noLoc $ HsLam noExt+ mfix_arg = noLoc $ HsLam noExtField (MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr [mfix_pat] body] , mg_ext = MatchGroupTc [tup_ty] body_ty , mg_origin = Generated })- mfix_pat = noLoc $ LazyPat noExt $ mkBigLHsPatTupId rec_tup_pats+ mfix_pat = noLoc $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats body = noLoc $ HsDo body_ty DoExpr (noLoc (rec_stmts ++ [ret_stmt])) ret_app = nlHsSyntaxApps return_op [mkBigLHsTupId rets]@@ -984,7 +984,7 @@ go _ (ParStmt {}) _ = panic "dsDo ParStmt" go _ (TransStmt {}) _ = panic "dsDo TransStmt"- go _ (XStmtLR {}) _ = panic "dsDo XStmtLR"+ go _ (XStmtLR nec) _ = noExtCon nec handle_failure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr -- In a do expression, pattern-match failure just calls
compiler/deSugar/DsForeign.hs view
@@ -112,7 +112,7 @@ (dL->L _ (CExportStatic _ ext_nm cconv)) _ }) = do (h, c, _, _) <- dsFExport id co ext_nm cconv False return (h, c, [id], [])- do_decl (XForeignDecl _) = panic "dsForeigns'"+ do_decl (XForeignDecl nec) = noExtCon nec {- ************************************************************************
compiler/deSugar/DsGRHSs.hs view
@@ -64,13 +64,13 @@ match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1 -- NB: nested dsLet inside matchResult ; return match_result2 }-dsGRHSs _ (XGRHSs _) _ = panic "dsGRHSs"+dsGRHSs _ (XGRHSs nec) _ = noExtCon nec dsGRHS :: HsMatchContext Name -> Type -> LGRHS GhcTc (LHsExpr GhcTc) -> DsM MatchResult dsGRHS hs_ctx rhs_ty (dL->L _ (GRHS _ guards rhs)) = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty-dsGRHS _ _ (dL->L _ (XGRHS _)) = panic "dsGRHS"+dsGRHS _ _ (dL->L _ (XGRHS nec)) = noExtCon nec dsGRHS _ _ _ = panic "dsGRHS: Impossible Match" -- due to #15884 {-@@ -138,8 +138,8 @@ matchGuards (RecStmt {} : _) _ _ _ = panic "matchGuards RecStmt" matchGuards (ApplicativeStmt {} : _) _ _ _ = panic "matchGuards ApplicativeLastStmt"-matchGuards (XStmtLR {} : _) _ _ _ =- panic "matchGuards XStmtLR"+matchGuards (XStmtLR nec : _) _ _ _ =+ noExtCon nec {- Should {\em fail} if @e@ returns @D@
compiler/deSugar/DsListComp.hs view
@@ -91,7 +91,7 @@ ; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty ; return (expr, bndrs_tuple_type) }-dsInnerListComp (XParStmtBlock{}) = panic "dsInnerListComp"+dsInnerListComp (XParStmtBlock nec) = noExtCon nec -- This function factors out commonality between the desugaring strategies for GroupStmt. -- Given such a statement it gives you back an expression representing how to compute the transformed@@ -107,7 +107,7 @@ to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders- (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock noExt stmts+ (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock noExtField stmts from_bndrs noSyntaxExpr) -- Work out what arguments should be supplied to that expression: i.e. is an extraction@@ -267,8 +267,8 @@ deListComp (ApplicativeStmt {} : _) _ = panic "deListComp ApplicativeStmt" -deListComp (XStmtLR {} : _) _ =- panic "deListComp XStmtLR"+deListComp (XStmtLR nec : _) _ =+ noExtCon nec deBindComp :: OutPat GhcTc -> CoreExpr@@ -364,8 +364,8 @@ dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt" dfListComp _ _ (ApplicativeStmt {} : _) = panic "dfListComp ApplicativeStmt"-dfListComp _ _ (XStmtLR {} : _) =- panic "dfListComp XStmtLR"+dfListComp _ _ (XStmtLR nec : _) =+ noExtCon nec dfBindComp :: Id -> Id -- 'c' and 'n' -> (LPat GhcTc, CoreExpr)@@ -596,7 +596,7 @@ ds_inner (ParStmtBlock _ stmts bndrs return_op) = do { exp <- dsInnerMonadComp stmts bndrs return_op ; return (exp, mkBigCoreVarTupTy bndrs) }- ds_inner (XParStmtBlock{}) = panic "dsMcStmt"+ ds_inner (XParStmtBlock nec) = noExtCon nec dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt) @@ -655,7 +655,7 @@ -> DsM CoreExpr dsInnerMonadComp stmts bndrs ret_op = dsMcStmts (stmts ++- [noLoc (LastStmt noExt (mkBigLHsVarTupId bndrs) False ret_op)])+ [noLoc (LastStmt noExtField (mkBigLHsVarTupId bndrs) False ret_op)]) -- The `unzip` function for `GroupStmt` in a monad comprehensions
compiler/deSugar/DsMeta.hs view
@@ -84,7 +84,7 @@ do_brack (DecBrG _ gp) = do { MkC ds1 <- repTopDs gp ; return ds1 } do_brack (DecBrL {}) = panic "dsBracket: unexpected DecBrL" do_brack (TExpBr _ e) = do { MkC e1 <- repLE e ; return e1 }- do_brack (XBracket {}) = panic "dsBracket: unexpected XBracket"+ do_brack (XBracket nec) = noExtCon nec {- -------------- Examples -------------------- @@ -178,7 +178,7 @@ no_warn _ = panic "repTopDs" no_doc (dL->L loc _) = notHandledL loc "Haddock documentation" empty-repTopDs (XHsGroup _) = panic "repTopDs"+repTopDs (XHsGroup nec) = noExtCon nec hsScopedTvBinders :: HsValBinds GhcRn -> [Name] -- See Note [Scoped type variables in bindings]@@ -208,8 +208,8 @@ , hsib_body = hs_ty } <- sig , (explicit_vars, _) <- splitLHsForAllTy hs_ty = implicit_vars ++ hsLTyVarNames explicit_vars- get_scoped_tvs_from_sig (XHsImplicitBndrs _)- = panic "get_scoped_tvs_from_sig"+ get_scoped_tvs_from_sig (XHsImplicitBndrs nec)+ = noExtCon nec {- Notes @@ -374,7 +374,7 @@ ; repData cxt1 tc opts ksig' cons1 derivs1 } }-repDataDefn _ _ (XHsDataDefn _) = panic "repDataDefn"+repDataDefn _ _ (XHsDataDefn nec) = noExtCon nec repSynDecl :: Core TH.Name -> Core [TH.TyVarBndrQ] -> LHsType GhcRn@@ -425,7 +425,7 @@ ; repKindSig ki' } repFamilyResultSig (TyVarSig _ bndr) = do { bndr' <- repTyVarBndr bndr ; repTyVarSig bndr' }-repFamilyResultSig (XFamilyResultSig _) = panic "repFamilyResultSig"+repFamilyResultSig (XFamilyResultSig nec) = noExtCon nec -- | Represent result signature using a Maybe Kind. Used with data families, -- where the result signature can be either missing or a kind but never a named@@ -511,7 +511,7 @@ ; wrapGenSyms ss decls2 } where (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty-repClsInstD (XClsInstDecl _) = panic "repClsInstD"+repClsInstD (XClsInstDecl nec) = noExtCon nec repStandaloneDerivD :: LDerivDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) repStandaloneDerivD (dL->L loc (DerivDecl { deriv_strategy = strat@@ -556,8 +556,8 @@ where checkTys :: [LHsTypeArg GhcRn] -> DsM [LHsTypeArg GhcRn] checkTys tys@(HsValArg _:HsValArg _:_) = return tys checkTys _ = panic "repTyFamEqn:checkTys"-repTyFamEqn (XHsImplicitBndrs _) = panic "repTyFamEqn"-repTyFamEqn (HsIB _ (XFamEqn _)) = panic "repTyFamEqn"+repTyFamEqn (XHsImplicitBndrs nec) = noExtCon nec+repTyFamEqn (HsIB _ (XFamEqn nec)) = noExtCon nec repTyArgs :: DsM (Core TH.TypeQ) -> [LHsTypeArg GhcRn] -> DsM (Core TH.TypeQ) repTyArgs f [] = f@@ -596,10 +596,10 @@ checkTys tys@(HsValArg _: HsValArg _: _) = return tys checkTys _ = panic "repDataFamInstD:checkTys" -repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs _))- = panic "repDataFamInstD"-repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn _)))- = panic "repDataFamInstD"+repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs nec))+ = noExtCon nec+repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn nec)))+ = noExtCon nec repForD :: Located (ForeignDecl GhcRn) -> DsM (SrcSpan, Core TH.DecQ) repForD (dL->L loc (ForeignImport { fd_name = name, fd_sig_ty = typ@@ -694,7 +694,7 @@ = panic "ruleBndrNames" ruleBndrNames (dL->L _ (RuleBndrSig _ _ (XHsWildCardBndrs _))) = panic "ruleBndrNames"-ruleBndrNames (dL->L _ (XRuleBndr _)) = panic "ruleBndrNames"+ruleBndrNames (dL->L _ (XRuleBndr nec)) = noExtCon nec ruleBndrNames _ = panic "ruleBndrNames: Impossible Match" -- due to #15884 repRuleBndr :: LRuleBndr GhcRn -> DsM (Core TH.RuleBndrQ)@@ -887,7 +887,7 @@ else repTForall th_explicit_tvs th_ctxt th_ty ; sig <- repProto mk_sig nm1 ty1 ; return (loc, sig) }-rep_ty_sig _ _ (XHsImplicitBndrs _) _ = panic "rep_ty_sig"+rep_ty_sig _ _ (XHsImplicitBndrs nec) _ = noExtCon nec rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name -> DsM (SrcSpan, Core TH.DecQ)@@ -916,7 +916,7 @@ repTForall th_exis th_provs th_ty ; sig <- repProto patSynSigDName nm1 ty1 ; return (loc, sig) }-rep_patsyn_ty_sig _ (XHsImplicitBndrs _) _ = panic "rep_patsyn_ty_sig"+rep_patsyn_ty_sig _ (XHsImplicitBndrs nec) _ = noExtCon nec rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name -> DsM (SrcSpan, Core TH.DecQ)@@ -1024,7 +1024,7 @@ = addSimpleTyVarBinds imp_tvs $ addHsTyVarBinds exp_tvs $ thing_inside-addTyVarBinds (XLHsQTyVars _) _ = panic "addTyVarBinds"+addTyVarBinds (XLHsQTyVars nec) _ = noExtCon nec addTyClTyVarBinds :: LHsQTyVars GhcRn -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))@@ -1095,12 +1095,12 @@ ; if null explicit_tvs && null (unLoc ctxt) then return th_ty else repTForall th_explicit_tvs th_ctxt th_ty }-repHsSigType (XHsImplicitBndrs _) = panic "repHsSigType"+repHsSigType (XHsImplicitBndrs nec) = noExtCon nec repHsSigWcType :: LHsSigWcType GhcRn -> DsM (Core TH.TypeQ) repHsSigWcType (HsWC { hswc_body = sig1 }) = repHsSigType sig1-repHsSigWcType (XHsWildCardBndrs _) = panic "repHsSigWcType"+repHsSigWcType (XHsWildCardBndrs nec) = noExtCon nec -- yield the representation of a list of types repLTys :: [LHsType GhcRn] -> DsM [Core TH.TypeQ]@@ -1225,7 +1225,7 @@ repSplice (HsQuasiQuote _ n _ _ _) = rep_splice n repSplice e@(HsSpliced {}) = pprPanic "repSplice" (ppr e) repSplice e@(HsSplicedT {}) = pprPanic "repSpliceT" (ppr e)-repSplice e@(XSplice {}) = pprPanic "repSplice" (ppr e)+repSplice (XSplice nec) = noExtCon nec rep_splice :: Name -> DsM (Core a) rep_splice splice_name@@ -1262,7 +1262,7 @@ repE (HsOverLabel _ _ s) = repOverLabel s repE e@(HsRecFld _ f) = case f of- Unambiguous x _ -> repE (HsVar noExt (noLoc x))+ Unambiguous x _ -> repE (HsVar noExtField (noLoc x)) Ambiguous{} -> notHandled "Ambiguous record selectors" (ppr e) XAmbiguousFieldOcc{} -> notHandled "XAmbiguous record selectors" (ppr e) @@ -1421,7 +1421,7 @@ gs <- repGuards guards ; clause <- repClause ps1 gs ds ; wrapGenSyms (ss1++ss2) clause }}}-repClauseTup (dL->L _ (Match _ _ _ (XGRHSs _))) = panic "repClauseTup"+repClauseTup (dL->L _ (Match _ _ _ (XGRHSs nec))) = noExtCon nec repClauseTup _ = panic "repClauseTup" repGuards :: [LGRHS GhcRn (LHsExpr GhcRn)] -> DsM (Core TH.BodyQ)@@ -1528,7 +1528,7 @@ do { (ss1, zs) <- repSts (map unLoc stmts) ; zs1 <- coreList stmtQTyConName zs ; return (ss1, zs1) }- rep_stmt_block (XParStmtBlock{}) = panic "repSts"+ rep_stmt_block (XParStmtBlock nec) = noExtCon nec repSts [LastStmt _ e _ _] = do { e2 <- repLE e ; z <- repNoBindSt e2@@ -1638,7 +1638,7 @@ ; ans <- repFun fn' (nonEmptyCoreList ms1) ; return (loc, ans) } -rep_bind (dL->L _ (FunBind { fun_matches = XMatchGroup _ })) = panic "rep_bind"+rep_bind (dL->L _ (FunBind { fun_matches = XMatchGroup nec })) = noExtCon nec rep_bind (dL->L loc (PatBind { pat_lhs = pat , pat_rhs = GRHSs _ guards (dL->L _ wheres) }))@@ -1648,7 +1648,7 @@ ; ans <- repVal patcore guardcore wherecore ; ans' <- wrapGenSyms ss ans ; return (loc, ans') }-rep_bind (dL->L _ (PatBind _ _ (XGRHSs _) _)) = panic "rep_bind"+rep_bind (dL->L _ (PatBind _ _ (XGRHSs nec) _)) = noExtCon nec rep_bind (dL->L _ (VarBind { var_id = v, var_rhs = e})) = do { v' <- lookupBinder v@@ -1698,9 +1698,9 @@ wrapGenArgSyms (RecCon _) _ dec = return dec wrapGenArgSyms _ ss dec = wrapGenSyms ss dec -rep_bind (dL->L _ (PatSynBind _ (XPatSynBind _)))- = panic "rep_bind: XPatSynBind"-rep_bind (dL->L _ (XHsBindsLR {})) = panic "rep_bind: XHsBindsLR"+rep_bind (dL->L _ (PatSynBind _ (XPatSynBind nec)))+ = noExtCon nec+rep_bind (dL->L _ (XHsBindsLR nec)) = noExtCon nec rep_bind _ = panic "rep_bind: Impossible match!" -- due to #15884 @@ -1741,7 +1741,7 @@ repPatSynDir (ExplicitBidirectional (MG { mg_alts = (dL->L _ clauses) })) = do { clauses' <- mapM repClauseTup clauses ; repExplBidirPatSynDir (nonEmptyCoreList clauses') }-repPatSynDir (ExplicitBidirectional (XMatchGroup _)) = panic "repPatSynDir"+repPatSynDir (ExplicitBidirectional (XMatchGroup nec)) = noExtCon nec repExplBidirPatSynDir :: Core [TH.ClauseQ] -> DsM (Core TH.PatSynDirQ) repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]@@ -2597,7 +2597,7 @@ mk_rational :: FractionalLit -> DsM (HsLit GhcRn) mk_rational r = do rat_ty <- lookupType rationalTyConName- return $ HsRat noExt r rat_ty+ return $ HsRat noExtField r rat_ty mk_string :: FastString -> DsM (HsLit GhcRn) mk_string s = return $ HsString NoSourceText s @@ -2610,7 +2610,7 @@ -- The type Rational will be in the environment, because -- the smart constructor 'TH.Syntax.rationalL' uses it in its type, -- and rationalL is sucked in when any TH stuff is used-repOverloadedLiteral XOverLit{} = panic "repOverloadedLiteral"+repOverloadedLiteral (XOverLit nec) = noExtCon nec mk_lit :: OverLitVal -> DsM (HsLit GhcRn) mk_lit (HsIntegral i) = mk_integer (il_value i)
compiler/deSugar/DsUtils.hs view
@@ -955,7 +955,7 @@ ParPat x p -> cL l (ParPat x (go p)) LazyPat _ lp' -> lp' BangPat _ _ -> lp- _ -> cL l (BangPat noExt lp)+ _ -> cL l (BangPat noExtField lp) -- | Unconditionally make a 'Pat' strict. addBang :: LPat GhcTc -- ^ Original pattern@@ -965,10 +965,10 @@ go lp@(dL->L l p) = case p of ParPat x p -> cL l (ParPat x (go p))- LazyPat _ lp' -> cL l (BangPat noExt lp')+ LazyPat _ lp' -> cL l (BangPat noExtField lp') -- Should we bring the extension value over? BangPat _ _ -> lp- _ -> cL l (BangPat noExt lp)+ _ -> cL l (BangPat noExtField lp) isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
compiler/deSugar/ExtractDocs.hs view
@@ -137,7 +137,7 @@ -- Extract the source location where an instance is defined. This is used -- to correlate InstDecls with their Instance/CoAxiom Names, via the -- instanceMap.-getInstLoc :: InstDecl name -> SrcSpan+getInstLoc :: InstDecl (GhcPass p) -> SrcSpan getInstLoc = \case ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc (hsSigType ty) DataFamInstD _ (DataFamInstDecl@@ -234,10 +234,10 @@ classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls where decls = docs ++ defs ++ sigs ++ ats- docs = mkDecls tcdDocs (DocD noExt) class_- defs = mkDecls (bagToList . tcdMeths) (ValD noExt) class_- sigs = mkDecls tcdSigs (SigD noExt) class_- ats = mkDecls tcdATs (TyClD noExt . FamDecl noExt) class_+ docs = mkDecls tcdDocs (DocD noExtField) class_+ defs = mkDecls (bagToList . tcdMeths) (ValD noExtField) class_+ sigs = mkDecls tcdSigs (SigD noExtField) class_+ ats = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_ -- | Extract function argument docs from inside top-level decls. declTypeDocs :: HsDecl GhcRn -> Map Int (HsDocString)@@ -280,14 +280,14 @@ -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn] ungroup group_ =- mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExt) group_ ++- mkDecls hs_derivds (DerivD noExt) group_ ++- mkDecls hs_defds (DefD noExt) group_ ++- mkDecls hs_fords (ForD noExt) group_ ++- mkDecls hs_docs (DocD noExt) group_ ++- mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExt) group_ ++- mkDecls (typesigs . hs_valds) (SigD noExt) group_ ++- mkDecls (valbinds . hs_valds) (ValD noExt) group_+ mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExtField) group_ +++ mkDecls hs_derivds (DerivD noExtField) group_ +++ mkDecls hs_defds (DefD noExtField) group_ +++ mkDecls hs_fords (ForD noExtField) group_ +++ mkDecls hs_docs (DocD noExtField) group_ +++ mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExtField) group_ +++ mkDecls (typesigs . hs_valds) (SigD noExtField) group_ +++ mkDecls (valbinds . hs_valds) (ValD noExtField) group_ where typesigs (XValBindsLR (NValBinds _ sigs)) = filter (isUserSig . unLoc) sigs typesigs ValBinds{} = error "expected XValBindsLR"
compiler/deSugar/Match.hs view
@@ -501,9 +501,9 @@ -- Push the bang-pattern inwards, in the hope that -- it may disappear next time tidy_bang_pat v o l (AsPat x v' p)- = tidy1 v o (AsPat x v' (cL l (BangPat noExt p)))+ = tidy1 v o (AsPat x v' (cL l (BangPat noExtField p))) tidy_bang_pat v o l (CoPat x w p t)- = tidy1 v o (CoPat x w (BangPat noExt (cL l p)) t)+ = tidy1 v o (CoPat x w (BangPat noExtField (cL l p)) t) -- Discard bang around strict pattern tidy_bang_pat v o _ p@(LitPat {}) = tidy1 v o p@@ -538,7 +538,7 @@ -- -- NB: SigPatIn, ConPatIn should not happen -tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExt (cL l p))+tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExtField (cL l p)) ------------------- push_bang_into_newtype_arg :: SrcSpan@@ -549,16 +549,16 @@ -- We are transforming !(N p) into (N !p) push_bang_into_newtype_arg l _ty (PrefixCon (arg:args)) = ASSERT( null args)- PrefixCon [cL l (BangPat noExt arg)]+ PrefixCon [cL l (BangPat noExtField arg)] push_bang_into_newtype_arg l _ty (RecCon rf) | HsRecFields { rec_flds = (dL->L lf fld) : flds } <- rf , HsRecField { hsRecFieldArg = arg } <- fld = ASSERT( null flds) RecCon (rf { rec_flds = [cL lf (fld { hsRecFieldArg- = cL l (BangPat noExt arg) })] })+ = cL l (BangPat noExtField arg) })] }) push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {}) | HsRecFields { rec_flds = [] } <- rf- = PrefixCon [cL l (BangPat noExt (noLoc (WildPat ty)))]+ = PrefixCon [cL l (BangPat noExtField (noLoc (WildPat ty)))] push_bang_into_newtype_arg _ _ cd = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd) @@ -752,13 +752,13 @@ ; return (EqnInfo { eqn_pats = upats , eqn_orig = FromSource , eqn_rhs = match_result }) }- mk_eqn_info _ (dL->L _ (XMatch _)) = panic "matchWrapper"+ mk_eqn_info _ (dL->L _ (XMatch nec)) = noExtCon nec mk_eqn_info _ _ = panic "mk_eqn_info: Impossible Match" -- due to #15884 handleWarnings = if isGenerated origin then discardWarningsDs else id-matchWrapper _ _ (XMatchGroup _) = panic "matchWrapper"+matchWrapper _ _ (XMatchGroup nec) = noExtCon nec matchEquations :: HsMatchContext Name -> [MatchId] -> [EquationInfo] -> Type
compiler/deSugar/MatchLit.hs view
@@ -95,7 +95,7 @@ HsString _ str -> mkStringExprFS str HsInteger _ i _ -> mkIntegerExpr i HsInt _ i -> return (mkIntExpr dflags (il_value i))- XLit x -> pprPanic "dsLit" (ppr x)+ XLit nec -> noExtCon nec HsRat _ (FL _ _ val) ty -> do num <- mkIntegerExpr (numerator val) denom <- mkIntegerExpr (denominator val)@@ -116,7 +116,7 @@ case shortCutLit dflags val ty of Just expr | not rebindable -> dsExpr expr -- Note [Literal short cut] _ -> dsExpr witness-dsOverLit XOverLit{} = panic "dsOverLit"+dsOverLit (XOverLit nec) = noExtCon nec {- Note [Literal short cut] ~~~~~~~~~~~~~~~~~~~~~~~~@@ -337,7 +337,7 @@ (mkNilPat charTy) (unpackFS s) -- The stringTy is the type of the whole pattern, not -- the type to instantiate (:) or [] with!-tidyLitPat lit = LitPat noExt lit+tidyLitPat lit = LitPat noExtField lit ---------------- tidyNPat :: HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc@@ -373,7 +373,7 @@ mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc mk_con_pat con lit- = unLoc (mkPrefixConPat con [noLoc $ LitPat noExt lit] [])+ = unLoc (mkPrefixConPat con [noLoc $ LitPat noExtField lit] []) mb_int_lit :: Maybe Integer mb_int_lit = case (mb_neg, val) of
compiler/ghci/ByteCodeGen.hs view
@@ -432,8 +432,8 @@ return $ breakInstr `consOL` code | otherwise = schemeE d 0 p rhs -getVarOffSets :: DynFlags -> StackDepth -> BCEnv -> [Id] -> [(Id, Word16)]-getVarOffSets dflags depth env = catMaybes . map getOffSet+getVarOffSets :: DynFlags -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, Word16)]+getVarOffSets dflags depth env = map getOffSet where getOffSet id = case lookupBCEnv_maybe id env of Nothing -> Nothing
compiler/hieFile/HieAst.hs view
@@ -283,7 +283,7 @@ ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs GhcRn (Shielded (LHsType GhcRn)))- ProtectedSig GhcTc = NoExt+ ProtectedSig GhcTc = NoExtField class ProtectSig a where protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a@@ -295,7 +295,7 @@ toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a) instance ProtectSig GhcTc where- protectSig _ _ = NoExt+ protectSig _ _ = noExtField instance ProtectSig GhcRn where protectSig sc (HsWC a (HsIB b sig)) =@@ -368,10 +368,10 @@ instance (ToHie a) => ToHie (Maybe a) where toHie = maybe (pure []) toHie -instance ToHie (Context (Located NoExt)) where+instance ToHie (Context (Located NoExtField)) where toHie _ = pure [] -instance ToHie (TScoped NoExt) where+instance ToHie (TScoped NoExtField) where toHie _ = pure [] instance ToHie (IEContext (Located ModuleName)) where
compiler/hsSyn/Convert.hs view
@@ -147,16 +147,16 @@ | TH.VarP s <- pat = do { s' <- vNameL s ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds)- ; returnJustL $ Hs.ValD noExt $ mkFunBind s' [cl'] }+ ; returnJustL $ Hs.ValD noExtField $ mkFunBind s' [cl'] } | otherwise = do { pat' <- cvtPat pat ; body' <- cvtGuard body ; ds' <- cvtLocalDecs (text "a where clause") ds- ; returnJustL $ Hs.ValD noExt $+ ; returnJustL $ Hs.ValD noExtField $ PatBind { pat_lhs = pat'- , pat_rhs = GRHSs noExt body' (noLoc ds')- , pat_ext = noExt+ , pat_rhs = GRHSs noExtField body' (noLoc ds')+ , pat_ext = noExtField , pat_ticks = ([],[]) } } cvtDec (TH.FunD nm cls)@@ -167,13 +167,13 @@ | otherwise = do { nm' <- vNameL nm ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls- ; returnJustL $ Hs.ValD noExt $ mkFunBind nm' cls' }+ ; returnJustL $ Hs.ValD noExtField $ mkFunBind nm' cls' } cvtDec (TH.SigD nm typ) = do { nm' <- vNameL nm ; ty' <- cvtType typ- ; returnJustL $ Hs.SigD noExt- (TypeSig noExt [nm'] (mkLHsSigWcType ty')) }+ ; returnJustL $ Hs.SigD noExtField+ (TypeSig noExtField [nm'] (mkLHsSigWcType ty')) } cvtDec (TH.InfixD fx nm) -- Fixity signatures are allowed for variables, constructors, and types@@ -181,8 +181,8 @@ -- the RdrName says it's a variable or a constructor. So, just assume -- it's a variable or constructor and proceed. = do { nm' <- vcNameL nm- ; returnJustL (Hs.SigD noExt (FixSig noExt- (FixitySig noExt [nm'] (cvtFixity fx)))) }+ ; returnJustL (Hs.SigD noExtField (FixSig noExtField+ (FixitySig noExtField [nm'] (cvtFixity fx)))) } cvtDec (PragmaD prag) = cvtPragmaD prag@@ -190,8 +190,8 @@ cvtDec (TySynD tc tvs rhs) = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs ; rhs' <- cvtType rhs- ; returnJustL $ TyClD noExt $- SynDecl { tcdSExt = noExt, tcdLName = tc', tcdTyVars = tvs'+ ; returnJustL $ TyClD noExtField $+ SynDecl { tcdSExt = noExtField, tcdLName = tc', tcdTyVars = tvs' , tcdFixity = Prefix , tcdRhs = rhs' } } @@ -211,33 +211,33 @@ ; ksig' <- cvtKind `traverse` ksig ; cons' <- mapM cvtConstr constrs ; derivs' <- cvtDerivs derivs- ; let defn = HsDataDefn { dd_ext = noExt+ ; let defn = HsDataDefn { dd_ext = noExtField , dd_ND = DataType, dd_cType = Nothing , dd_ctxt = ctxt' , dd_kindSig = ksig' , dd_cons = cons', dd_derivs = derivs' }- ; returnJustL $ TyClD noExt (DataDecl- { tcdDExt = noExt- , tcdLName = tc', tcdTyVars = tvs'- , tcdFixity = Prefix- , tcdDataDefn = defn }) }+ ; returnJustL $ TyClD noExtField $+ DataDecl { tcdDExt = noExtField+ , tcdLName = tc', tcdTyVars = tvs'+ , tcdFixity = Prefix+ , tcdDataDefn = defn } } cvtDec (NewtypeD ctxt tc tvs ksig constr derivs) = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs ; ksig' <- cvtKind `traverse` ksig ; con' <- cvtConstr constr ; derivs' <- cvtDerivs derivs- ; let defn = HsDataDefn { dd_ext = noExt+ ; let defn = HsDataDefn { dd_ext = noExtField , dd_ND = NewType, dd_cType = Nothing , dd_ctxt = ctxt' , dd_kindSig = ksig' , dd_cons = [con'] , dd_derivs = derivs' }- ; returnJustL $ TyClD noExt (DataDecl- { tcdDExt = noExt- , tcdLName = tc', tcdTyVars = tvs'- , tcdFixity = Prefix- , tcdDataDefn = defn }) }+ ; returnJustL $ TyClD noExtField $+ DataDecl { tcdDExt = noExtField+ , tcdLName = tc', tcdTyVars = tvs'+ , tcdFixity = Prefix+ , tcdDataDefn = defn } } cvtDec (ClassD ctxt cl tvs fds decs) = do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs@@ -247,8 +247,8 @@ (failWith $ (text "Default data instance declarations" <+> text "are not allowed:") $$ (Outputable.ppr adts'))- ; returnJustL $ TyClD noExt $- ClassDecl { tcdCExt = noExt+ ; returnJustL $ TyClD noExtField $+ ClassDecl { tcdCExt = noExtField , tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs' , tcdFixity = Prefix , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'@@ -264,8 +264,8 @@ ; ctxt' <- cvtContext funPrec ctxt ; (dL->L loc ty') <- cvtType ty ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ cL loc ty'- ; returnJustL $ InstD noExt $ ClsInstD noExt $- ClsInstDecl { cid_ext = noExt, cid_poly_ty = mkLHsSigType inst_ty'+ ; returnJustL $ InstD noExtField $ ClsInstD noExtField $+ ClsInstDecl { cid_ext = noExtField, cid_poly_ty = mkLHsSigType inst_ty' , cid_binds = binds' , cid_sigs = Hs.mkClassOpSigs sigs' , cid_tyfam_insts = ats', cid_datafam_insts = adts'@@ -283,29 +283,29 @@ cvtDec (ForeignD ford) = do { ford' <- cvtForD ford- ; returnJustL $ ForD noExt ford' }+ ; returnJustL $ ForD noExtField ford' } cvtDec (DataFamilyD tc tvs kind) = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs ; result <- cvtMaybeKindToFamilyResultSig kind- ; returnJustL $ TyClD noExt $ FamDecl noExt $- FamilyDecl noExt DataFamily tc' tvs' Prefix result Nothing }+ ; returnJustL $ TyClD noExtField $ FamDecl noExtField $+ FamilyDecl noExtField DataFamily tc' tvs' Prefix result Nothing } cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs) = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys ; ksig' <- cvtKind `traverse` ksig ; cons' <- mapM cvtConstr constrs ; derivs' <- cvtDerivs derivs- ; let defn = HsDataDefn { dd_ext = noExt+ ; let defn = HsDataDefn { dd_ext = noExtField , dd_ND = DataType, dd_cType = Nothing , dd_ctxt = ctxt' , dd_kindSig = ksig' , dd_cons = cons', dd_derivs = derivs' } - ; returnJustL $ InstD noExt $ DataFamInstD- { dfid_ext = noExt+ ; returnJustL $ InstD noExtField $ DataFamInstD+ { dfid_ext = noExtField , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $- FamEqn { feqn_ext = noExt+ FamEqn { feqn_ext = noExtField , feqn_tycon = tc' , feqn_bndrs = bndrs' , feqn_pats = typats'@@ -317,15 +317,15 @@ ; ksig' <- cvtKind `traverse` ksig ; con' <- cvtConstr constr ; derivs' <- cvtDerivs derivs- ; let defn = HsDataDefn { dd_ext = noExt+ ; let defn = HsDataDefn { dd_ext = noExtField , dd_ND = NewType, dd_cType = Nothing , dd_ctxt = ctxt' , dd_kindSig = ksig' , dd_cons = [con'], dd_derivs = derivs' }- ; returnJustL $ InstD noExt $ DataFamInstD- { dfid_ext = noExt+ ; returnJustL $ InstD noExtField $ DataFamInstD+ { dfid_ext = noExtField , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $- FamEqn { feqn_ext = noExt+ FamEqn { feqn_ext = noExtField , feqn_tycon = tc' , feqn_bndrs = bndrs' , feqn_pats = typats'@@ -334,35 +334,35 @@ cvtDec (TySynInstD eqn) = do { (dL->L _ eqn') <- cvtTySynEqn eqn- ; returnJustL $ InstD noExt $ TyFamInstD- { tfid_ext = noExt+ ; returnJustL $ InstD noExtField $ TyFamInstD+ { tfid_ext = noExtField , tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } } cvtDec (OpenTypeFamilyD head) = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head- ; returnJustL $ TyClD noExt $ FamDecl noExt $- FamilyDecl noExt OpenTypeFamily tc' tyvars' Prefix result' injectivity'+ ; returnJustL $ TyClD noExtField $ FamDecl noExtField $+ FamilyDecl noExtField OpenTypeFamily tc' tyvars' Prefix result' injectivity' } cvtDec (ClosedTypeFamilyD head eqns) = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head ; eqns' <- mapM cvtTySynEqn eqns- ; returnJustL $ TyClD noExt $ FamDecl noExt $- FamilyDecl noExt (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix+ ; returnJustL $ TyClD noExtField $ FamDecl noExtField $+ FamilyDecl noExtField (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix result' injectivity' } cvtDec (TH.RoleAnnotD tc roles) = do { tc' <- tconNameL tc ; let roles' = map (noLoc . cvtRole) roles- ; returnJustL $ Hs.RoleAnnotD noExt (RoleAnnotDecl noExt tc' roles') }+ ; returnJustL $ Hs.RoleAnnotD noExtField (RoleAnnotDecl noExtField tc' roles') } cvtDec (TH.StandaloneDerivD ds cxt ty) = do { cxt' <- cvtContext funPrec cxt ; ds' <- traverse cvtDerivStrategy ds ; (dL->L loc ty') <- cvtType ty ; let inst_ty' = mkHsQualTy cxt loc cxt' $ cL loc ty'- ; returnJustL $ DerivD noExt $- DerivDecl { deriv_ext =noExt+ ; returnJustL $ DerivD noExtField $+ DerivDecl { deriv_ext =noExtField , deriv_strategy = ds' , deriv_type = mkLHsSigWcType inst_ty' , deriv_overlap_mode = Nothing } }@@ -370,16 +370,16 @@ cvtDec (TH.DefaultSigD nm typ) = do { nm' <- vNameL nm ; ty' <- cvtType typ- ; returnJustL $ Hs.SigD noExt- $ ClassOpSig noExt True [nm'] (mkLHsSigType ty')}+ ; returnJustL $ Hs.SigD noExtField+ $ ClassOpSig noExtField True [nm'] (mkLHsSigType ty')} cvtDec (TH.PatSynD nm args dir pat) = do { nm' <- cNameL nm ; args' <- cvtArgs args ; dir' <- cvtDir nm' dir ; pat' <- cvtPat pat- ; returnJustL $ Hs.ValD noExt $ PatSynBind noExt $- PSB noExt nm' args' pat' dir' }+ ; returnJustL $ Hs.ValD noExtField $ PatSynBind noExtField $+ PSB noExtField nm' args' pat' dir' } where cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon <$> mapM vNameL args cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameL a1 <*> vNameL a2@@ -397,7 +397,7 @@ cvtDec (TH.PatSynSigD nm ty) = do { nm' <- cNameL nm ; ty' <- cvtPatSynSigTy ty- ; returnJustL $ Hs.SigD noExt $ PatSynSig noExt [nm'] (mkLHsSigType ty')}+ ; returnJustL $ Hs.SigD noExtField $ PatSynSig noExtField [nm'] (mkLHsSigType ty')} -- Implicit parameter bindings are handled in cvtLocalDecs and -- cvtImplicitParamBind. They are not allowed in any other scope, so@@ -415,7 +415,7 @@ ; rhs' <- cvtType rhs ; let args' = map wrap_tyarg args ; returnL $ mkHsImplicitBndrs- $ FamEqn { feqn_ext = noExt+ $ FamEqn { feqn_ext = noExtField , feqn_tycon = nm' , feqn_bndrs = mb_bndrs' , feqn_pats = args'@@ -425,7 +425,7 @@ ; args' <- mapM cvtType [t1,t2] ; rhs' <- cvtType rhs ; returnL $ mkHsImplicitBndrs- $ FamEqn { feqn_ext = noExt+ $ FamEqn { feqn_ext = noExtField , feqn_tycon = nm' , feqn_bndrs = mb_bndrs' , feqn_pats =@@ -587,7 +587,7 @@ where all_tvs = hsQTvExplicit tvs' ++ ex_tvs - add_forall _ _ (XConDecl _) = panic "cvtConstr"+ add_forall _ _ (XConDecl nec) = noExtCon nec cvtConstr (GadtC c strtys ty) = do { c' <- mapM cNameL c@@ -600,8 +600,8 @@ = do { c' <- mapM cNameL c ; ty' <- cvtType ty ; rec_flds <- mapM cvt_id_arg varstrtys- ; let rec_ty = noLoc (HsFunTy noExt- (noLoc $ HsRecTy noExt rec_flds) ty')+ ; let rec_ty = noLoc (HsFunTy noExtField+ (noLoc $ HsRecTy noExtField rec_flds) ty') ; returnL $ fst $ mkGadtDecl c' rec_ty } cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness@@ -620,16 +620,16 @@ ; let ty' = parenthesizeHsType appPrec ty'' su' = cvtSrcUnpackedness su ss' = cvtSrcStrictness ss- ; returnL $ HsBangTy noExt (HsSrcBang NoSourceText su' ss') ty' }+ ; returnL $ HsBangTy noExtField (HsSrcBang NoSourceText su' ss') ty' } cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs) cvt_id_arg (i, str, ty) = do { (dL->L li i') <- vNameL i ; ty' <- cvt_arg (str,ty) ; return $ noLoc (ConDeclField- { cd_fld_ext = noExt+ { cd_fld_ext = noExtField , cd_fld_names- = [cL li $ FieldOcc noExt (cL li i')]+ = [cL li $ FieldOcc noExtField (cL li i')] , cd_fld_type = ty' , cd_fld_doc = Nothing}) } @@ -667,7 +667,7 @@ mk_imp impspec = do { nm' <- vNameL nm ; ty' <- cvtType ty- ; return (ForeignImport { fd_i_ext = noExt+ ; return (ForeignImport { fd_i_ext = noExtField , fd_name = nm' , fd_sig_ty = mkLHsSigType ty' , fd_fi = impspec })@@ -684,7 +684,7 @@ (mkFastString as) (cvt_conv callconv))) (noLoc (SourceText as))- ; return $ ForeignExport { fd_e_ext = noExt+ ; return $ ForeignExport { fd_e_ext = noExtField , fd_name = nm' , fd_sig_ty = mkLHsSigType ty' , fd_fe = e } }@@ -712,7 +712,7 @@ , inl_rule = cvtRuleMatch rm , inl_act = cvtPhases phases dflt , inl_sat = Nothing }- ; returnJustL $ Hs.SigD noExt $ InlineSig noExt nm' ip }+ ; returnJustL $ Hs.SigD noExtField $ InlineSig noExtField nm' ip } cvtPragmaD (SpecialiseP nm ty inline phases) = do { nm' <- vNameL nm@@ -730,12 +730,12 @@ , inl_rule = Hs.FunLike , inl_act = cvtPhases phases dflt , inl_sat = Nothing }- ; returnJustL $ Hs.SigD noExt $ SpecSig noExt nm' [mkLHsSigType ty'] ip }+ ; returnJustL $ Hs.SigD noExtField $ SpecSig noExtField nm' [mkLHsSigType ty'] ip } cvtPragmaD (SpecialiseInstP ty) = do { ty' <- cvtType ty- ; returnJustL $ Hs.SigD noExt $- SpecInstSig noExt (SourceText "{-# SPECIALISE") (mkLHsSigType ty') }+ ; returnJustL $ Hs.SigD noExtField $+ SpecInstSig noExtField (SourceText "{-# SPECIALISE") (mkLHsSigType ty') } cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases) = do { let nm' = mkFastString nm@@ -744,11 +744,11 @@ ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs ; lhs' <- cvtl lhs ; rhs' <- cvtl rhs- ; returnJustL $ Hs.RuleD noExt- $ HsRules { rds_ext = noExt+ ; returnJustL $ Hs.RuleD noExtField+ $ HsRules { rds_ext = noExtField , rds_src = SourceText "{-# RULES" , rds_rules = [noLoc $- HsRule { rd_ext = noExt+ HsRule { rd_ext = noExtField , rd_name = (noLoc (quotedSourceText nm,nm')) , rd_act = act , rd_tyvs = ty_bndrs'@@ -768,8 +768,8 @@ ValueAnnotation n -> do n' <- vcName n return (ValueAnnProvenance (noLoc n'))- ; returnJustL $ Hs.AnnD noExt- $ HsAnnotation noExt (SourceText "{-# ANN") target' exp'+ ; returnJustL $ Hs.AnnD noExtField+ $ HsAnnotation noExtField (SourceText "{-# ANN") target' exp' } cvtPragmaD (LineP line file)@@ -779,8 +779,8 @@ cvtPragmaD (CompleteP cls mty) = do { cls' <- noLoc <$> mapM cNameL cls ; mty' <- traverse tconNameL mty- ; returnJustL $ Hs.SigD noExt- $ CompleteMatchSig noExt NoSourceText cls' mty' }+ ; returnJustL $ Hs.SigD noExtField+ $ CompleteMatchSig noExtField NoSourceText cls' mty' } dfltActivation :: TH.Inline -> Activation dfltActivation TH.NoInline = NeverActive@@ -803,11 +803,11 @@ cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs) cvtRuleBndr (RuleVar n) = do { n' <- vNameL n- ; return $ noLoc $ Hs.RuleBndr noExt n' }+ ; return $ noLoc $ Hs.RuleBndr noExtField n' } cvtRuleBndr (TypedRuleVar n ty) = do { n' <- vNameL n ; ty' <- cvtType ty- ; return $ noLoc $ Hs.RuleBndrSig noExt n' $ mkLHsSigWcType ty' }+ ; return $ noLoc $ Hs.RuleBndrSig noExtField n' $ mkLHsSigWcType ty' } --------------------------------------------------- -- Declarations@@ -816,16 +816,16 @@ cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs) cvtLocalDecs doc ds = case partitionWith is_ip_bind ds of- ([], []) -> return (EmptyLocalBinds noExt)+ ([], []) -> return (EmptyLocalBinds noExtField) ([], _) -> do ds' <- cvtDecs ds let (binds, prob_sigs) = partitionWith is_bind ds' let (sigs, bads) = partitionWith is_sig prob_sigs unless (null bads) (failWith (mkBadDecMsg doc bads))- return (HsValBinds noExt (ValBinds noExt (listToBag binds) sigs))+ return (HsValBinds noExtField (ValBinds noExtField (listToBag binds) sigs)) (ip_binds, []) -> do binds <- mapM (uncurry cvtImplicitParamBind) ip_binds- return (HsIPBinds noExt (IPBinds noExt binds))+ return (HsIPBinds noExtField (IPBinds noExtField binds)) ((_:_), (_:_)) -> failWith (text "Implicit parameters mixed with other bindings") @@ -836,13 +836,13 @@ ; let pps = map (parenthesizePat appPrec) ps' ; g' <- cvtGuard body ; ds' <- cvtLocalDecs (text "a where clause") wheres- ; returnL $ Hs.Match noExt ctxt pps (GRHSs noExt g' (noLoc ds')) }+ ; returnL $ Hs.Match noExtField ctxt pps (GRHSs noExtField g' (noLoc ds')) } cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs) cvtImplicitParamBind n e = do n' <- wrapL (ipName n) e' <- cvtl e- returnL (IPBind noExt (Left n') e')+ returnL (IPBind noExtField (Left n') e') ------------------------------------------------------------------- -- Expressions@@ -851,12 +851,12 @@ cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs) cvtl e = wrapL (cvt e) where- cvt (VarE s) = do { s' <- vName s; return $ HsVar noExt (noLoc s') }- cvt (ConE s) = do { s' <- cName s; return $ HsVar noExt (noLoc s') }+ cvt (VarE s) = do { s' <- vName s; return $ HsVar noExtField (noLoc s') }+ cvt (ConE s) = do { s' <- cName s; return $ HsVar noExtField (noLoc s') } cvt (LitE l)- | overloadedLit l = go cvtOverLit (HsOverLit noExt)+ | overloadedLit l = go cvtOverLit (HsOverLit noExtField) (hsOverLitNeedsParens appPrec)- | otherwise = go cvtLit (HsLit noExt)+ | otherwise = go cvtLit (HsLit noExtField) (hsLitNeedsParens appPrec) where go :: (Lit -> CvtM (l GhcPs))@@ -866,17 +866,17 @@ go cvt_lit mk_expr is_compound_lit = do l' <- cvt_lit l let e' = mk_expr l'- return $ if is_compound_lit l' then HsPar noExt (noLoc e') else e'+ return $ if is_compound_lit l' then HsPar noExtField (noLoc e') else e' cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y- ; return $ HsApp noExt (mkLHsPar x')+ ; return $ HsApp noExtField (mkLHsPar x') (mkLHsPar y')} cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y- ; return $ HsApp noExt (mkLHsPar x')+ ; return $ HsApp noExtField (mkLHsPar x') (mkLHsPar y')} cvt (AppTypeE e t) = do { e' <- cvtl e ; t' <- cvtType t ; let tp = parenthesizeHsType appPrec t'- ; return $ HsAppType noExt e'+ ; return $ HsAppType noExtField e' $ mkHsWildCardBndrs tp } cvt (LamE [] e) = cvt e -- Degenerate case. We convert the body as its -- own expression to avoid pretty-printing@@ -884,82 +884,86 @@ -- lambda expressions. See #13856. cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e ; let pats = map (parenthesizePat appPrec) ps'- ; return $ HsLam noExt (mkMatchGroup FromSource+ ; return $ HsLam noExtField (mkMatchGroup FromSource [mkSimpleMatch LambdaExpr pats e'])} cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch CaseAlt) ms- ; return $ HsLamCase noExt+ ; return $ HsLamCase noExtField (mkMatchGroup FromSource ms') }- cvt (TupE [Just e]) = do { e' <- cvtl e; return $ HsPar noExt e' }+ cvt (TupE [Just e]) = do { e' <- cvtl e; return $ HsPar noExtField e' } -- Note [Dropping constructors] -- Singleton tuples treated like nothing (just parens) cvt (TupE es) = cvt_tup es Boxed cvt (UnboxedTupE es) = cvt_tup es Unboxed cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e ; unboxedSumChecks alt arity- ; return $ ExplicitSum noExt+ ; return $ ExplicitSum noExtField alt arity e'} cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;- ; return $ HsIf noExt (Just noSyntaxExpr) x' y' z' }+ ; return $ HsIf noExtField (Just noSyntaxExpr) x' y' z' } cvt (MultiIfE alts) | null alts = failWith (text "Multi-way if-expression with no alternatives") | otherwise = do { alts' <- mapM cvtpair alts- ; return $ HsMultiIf noExt alts' }+ ; return $ HsMultiIf noExtField alts' } cvt (LetE ds e) = do { ds' <- cvtLocalDecs (text "a let expression") ds- ; e' <- cvtl e; return $ HsLet noExt (noLoc ds') e'}+ ; e' <- cvtl e; return $ HsLet noExtField (noLoc ds') e'} cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms- ; return $ HsCase noExt e'+ ; return $ HsCase noExtField e' (mkMatchGroup FromSource ms') } cvt (DoE ss) = cvtHsDo DoExpr ss cvt (MDoE ss) = cvtHsDo MDoExpr ss cvt (CompE ss) = cvtHsDo ListComp ss cvt (ArithSeqE dd) = do { dd' <- cvtDD dd- ; return $ ArithSeq noExt Nothing dd' }+ ; return $ ArithSeq noExtField Nothing dd' } cvt (ListE xs) | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s)- ; return (HsLit noExt l') }+ ; return (HsLit noExtField l') } -- Note [Converting strings] | otherwise = do { xs' <- mapM cvtl xs- ; return $ ExplicitList noExt Nothing xs'+ ; return $ ExplicitList noExtField Nothing xs' } -- Infix expressions- cvt (InfixE (Just x) s (Just y)) =+ cvt (InfixE (Just x) s (Just y)) = ensureValidOpExp s $ do { x' <- cvtl x ; s' <- cvtl s ; y' <- cvtl y ; let px = parenthesizeHsExpr opPrec x' py = parenthesizeHsExpr opPrec y'- ; wrapParL (HsPar noExt)- $ OpApp noExt px s' py }+ ; wrapParL (HsPar noExtField)+ $ OpApp noExtField px s' py } -- Parenthesise both arguments and result, -- to ensure this operator application does -- does not get re-associated -- See Note [Operator association]- cvt (InfixE Nothing s (Just y)) = do { s' <- cvtl s; y' <- cvtl y- ; wrapParL (HsPar noExt) $- SectionR noExt s' y' }+ cvt (InfixE Nothing s (Just y)) = ensureValidOpExp s $+ do { s' <- cvtl s; y' <- cvtl y+ ; wrapParL (HsPar noExtField) $+ SectionR noExtField s' y' } -- See Note [Sections in HsSyn] in HsExpr- cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s- ; wrapParL (HsPar noExt) $- SectionL noExt x' s' }+ cvt (InfixE (Just x) s Nothing ) = ensureValidOpExp s $+ do { x' <- cvtl x; s' <- cvtl s+ ; wrapParL (HsPar noExtField) $+ SectionL noExtField x' s' } - cvt (InfixE Nothing s Nothing ) = do { s' <- cvtl s- ; return $ HsPar noExt s' }+ cvt (InfixE Nothing s Nothing ) = ensureValidOpExp s $+ do { s' <- cvtl s+ ; return $ HsPar noExtField s' } -- Can I indicate this is an infix thing? -- Note [Dropping constructors] - cvt (UInfixE x s y) = do { x' <- cvtl x+ cvt (UInfixE x s y) = ensureValidOpExp s $+ do { x' <- cvtl x ; let x'' = case unLoc x' of OpApp {} -> x' _ -> mkLHsPar x' ; cvtOpApp x'' s y } -- Note [Converting UInfix] - cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar noExt e' }+ cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar noExtField e' } cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t ; let pe = parenthesizeHsExpr sigPrec e'- ; return $ ExprWithTySig noExt pe (mkLHsSigWcType t') }+ ; return $ ExprWithTySig noExtField pe (mkLHsSigWcType t') } cvt (RecConE c flds) = do { c' <- cNameL c ; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) }@@ -968,15 +972,33 @@ <- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc)) flds ; return $ mkRdrRecordUpd e' flds' }- cvt (StaticE e) = fmap (HsStatic noExt) $ cvtl e+ cvt (StaticE e) = fmap (HsStatic noExtField) $ cvtl e cvt (UnboundVarE s) = do -- Use of 'vcName' here instead of 'vName' is -- important, because UnboundVarE may contain -- constructor names - see #14627. { s' <- vcName s- ; return $ HsVar noExt (noLoc s') }- cvt (LabelE s) = do { return $ HsOverLabel noExt Nothing (fsLit s) }- cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noExt n' }+ ; return $ HsVar noExtField (noLoc s') }+ cvt (LabelE s) = do { return $ HsOverLabel noExtField Nothing (fsLit s) }+ cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noExtField n' } +{- | #16895 Ensure an infix expression's operator is a variable/constructor.+Consider this example:++ $(uInfixE [|1|] [|id id|] [|2|])++This infix expression is obviously ill-formed so we use this helper function+to reject such programs outright.++The constructors `ensureValidOpExp` permits should be in sync with `pprInfixExp`+in Language.Haskell.TH.Ppr from the template-haskell library.+-}+ensureValidOpExp :: TH.Exp -> CvtM a -> CvtM a+ensureValidOpExp (VarE _n) m = m+ensureValidOpExp (ConE _n) m = m+ensureValidOpExp (UnboundVarE _n) m = m+ensureValidOpExp _e _m =+ failWith (text "Non-variable expression is not allowed in an infix expression")+ {- Note [Dropping constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we drop constructors from the input (for instance, when we encounter @TupE [e]@)@@ -1009,10 +1031,10 @@ cvt_tup :: [Maybe Exp] -> Boxity -> CvtM (HsExpr GhcPs) cvt_tup es boxity = do { let cvtl_maybe Nothing = return missingTupArg- cvtl_maybe (Just e) = fmap (Present noExt) (cvtl e)+ cvtl_maybe (Just e) = fmap (Present noExtField) (cvtl e) ; es' <- mapM cvtl_maybe es ; return $ ExplicitTuple- noExt+ noExtField (map noLoc es') boxity } @@ -1075,7 +1097,7 @@ cvtOpApp x op y = do { op' <- cvtl op ; y' <- cvtl y- ; return (OpApp noExt x op' y') }+ ; return (OpApp noExtField x op' y') } ------------------------------------- -- Do notation and statements@@ -1093,7 +1115,7 @@ -> return (cL loc (mkLastStmt body)) _ -> failWith (bad_last last') - ; return $ HsDo noExt do_or_lc (noLoc (stmts'' ++ [last''])) }+ ; return $ HsDo noExtField do_or_lc (noLoc (stmts'' ++ [last''])) } where bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAStmtContext do_or_lc <> colon , nest 2 $ Outputable.ppr stmt@@ -1106,12 +1128,12 @@ cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkBodyStmt e' } cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' } cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (text "a let binding") ds- ; returnL $ LetStmt noExt (noLoc ds') }+ ; returnL $ LetStmt noExtField (noLoc ds') } cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss- ; returnL $ ParStmt noExt dss' noExpr noSyntaxExpr }+ ; returnL $ ParStmt noExtField dss' noExpr noSyntaxExpr } where cvt_one ds = do { ds' <- cvtStmts ds- ; return (ParStmtBlock noExt ds' undefined noSyntaxExpr) }+ ; return (ParStmtBlock noExtField ds' undefined noSyntaxExpr) } cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss; returnL (mkRecStmt ss') } cvtMatch :: HsMatchContext RdrName@@ -1119,23 +1141,23 @@ cvtMatch ctxt (TH.Match p body decs) = do { p' <- cvtPat p ; let lp = case p' of- (dL->L loc SigPat{}) -> cL loc (ParPat NoExt p') -- #14875+ (dL->L loc SigPat{}) -> cL loc (ParPat noExtField p') -- #14875 _ -> p' ; g' <- cvtGuard body ; decs' <- cvtLocalDecs (text "a where clause") decs- ; returnL $ Hs.Match noExt ctxt [lp] (GRHSs noExt g' (noLoc decs')) }+ ; returnL $ Hs.Match noExtField ctxt [lp] (GRHSs noExtField g' (noLoc decs')) } cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)] cvtGuard (GuardedB pairs) = mapM cvtpair pairs cvtGuard (NormalB e) = do { e' <- cvtl e- ; g' <- returnL $ GRHS noExt [] e'; return [g'] }+ ; g' <- returnL $ GRHS noExtField [] e'; return [g'] } cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs)) cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs ; g' <- returnL $ mkBodyStmt ge'- ; returnL $ GRHS noExt [g'] rhs' }+ ; returnL $ GRHS noExtField [g'] rhs' } cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs- ; returnL $ GRHS noExt gs' rhs' }+ ; returnL $ GRHS noExtField gs' rhs' } cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs) cvtOverLit (IntegerL i)@@ -1176,9 +1198,9 @@ cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim NoSourceText i } cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim NoSourceText w } cvtLit (FloatPrimL f)- = do { force f; return $ HsFloatPrim noExt (mkFractionalLit f) }+ = do { force f; return $ HsFloatPrim noExtField (mkFractionalLit f) } cvtLit (DoublePrimL f)- = do { force f; return $ HsDoublePrim noExt (mkFractionalLit f) }+ = do { force f; return $ HsDoublePrim noExtField (mkFractionalLit f) } cvtLit (CharL c) = do { force c; return $ HsChar NoSourceText c } cvtLit (CharPrimL c) = do { force c; return $ HsCharPrim NoSourceText c } cvtLit (StringL s) = do { let { s' = mkFastString s }@@ -1212,24 +1234,24 @@ ; return (mkNPat (noLoc l') Nothing) } -- Not right for negative patterns; -- need to think about that!- | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat noExt l' }+ | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat noExtField l' } cvtp (TH.VarP s) = do { s' <- vName s- ; return $ Hs.VarPat noExt (noLoc s') }-cvtp (TupP [p]) = do { p' <- cvtPat p; return $ ParPat noExt p' }+ ; return $ Hs.VarPat noExtField (noLoc s') }+cvtp (TupP [p]) = do { p' <- cvtPat p; return $ ParPat noExtField p' } -- Note [Dropping constructors] cvtp (TupP ps) = do { ps' <- cvtPats ps- ; return $ TuplePat noExt ps' Boxed }+ ; return $ TuplePat noExtField ps' Boxed } cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps- ; return $ TuplePat noExt ps' Unboxed }+ ; return $ TuplePat noExtField ps' Unboxed } cvtp (UnboxedSumP p alt arity) = do { p' <- cvtPat p ; unboxedSumChecks alt arity- ; return $ SumPat noExt p' alt arity }+ ; return $ SumPat noExtField p' alt arity } cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps ; let pps = map (parenthesizePat appPrec) ps' ; return $ ConPatIn s' (PrefixCon pps) } cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2- ; wrapParL (ParPat noExt) $+ ; wrapParL (ParPat noExtField) $ ConPatIn s' $ InfixCon (parenthesizePat opPrec p1') (parenthesizePat opPrec p2') }@@ -1238,22 +1260,22 @@ cvtp (ParensP p) = do { p' <- cvtPat p; ; case unLoc p' of -- may be wrapped ConPatIn ParPat {} -> return $ unLoc p'- _ -> return $ ParPat noExt p' }-cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat noExt p' }-cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat noExt p' }+ _ -> return $ ParPat noExtField p' }+cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat noExtField p' }+cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat noExtField p' } cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p- ; return $ AsPat noExt s' p' }-cvtp TH.WildP = return $ WildPat noExt+ ; return $ AsPat noExtField s' p' }+cvtp TH.WildP = return $ WildPat noExtField cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) } cvtp (ListP ps) = do { ps' <- cvtPats ps ; return- $ ListPat noExt ps'}+ $ ListPat noExtField ps'} cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t- ; return $ SigPat noExt p' (mkLHsSigWcType t') }+ ; return $ SigPat noExtField p' (mkLHsSigWcType t') } cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p- ; return $ ViewPat noExt e' p'}+ ; return $ ViewPat noExtField e' p'} cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs)) cvtPatFld (s,p)@@ -1287,11 +1309,11 @@ cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr GhcPs) cvt_tv (TH.PlainTV nm) = do { nm' <- tNameL nm- ; returnL $ UserTyVar noExt nm' }+ ; returnL $ UserTyVar noExtField nm' } cvt_tv (TH.KindedTV nm ki) = do { nm' <- tNameL nm ; ki' <- cvtKind ki- ; returnL $ KindedTyVar noExt nm' ki' }+ ; returnL $ KindedTyVar noExtField nm' ki' } cvtRole :: TH.Role -> Maybe Coercion.Role cvtRole TH.NominalR = Just Coercion.Nominal@@ -1311,7 +1333,7 @@ cvtDerivClause (TH.DerivClause ds ctxt) = do { ctxt' <- fmap (map mkLHsSigType) <$> cvtContext appPrec ctxt ; ds' <- traverse cvtDerivStrategy ds- ; returnL $ HsDerivingClause noExt ds' ctxt' }+ ; returnL $ HsDerivingClause noExtField ds' ctxt' } cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs) cvtDerivStrategy TH.StockStrategy = returnL Hs.StockStrategy@@ -1337,21 +1359,21 @@ , normals `lengthIs` n -- Saturated -> if n==1 then return (head normals) -- Singleton tuples treated -- like nothing (ie just parens)- else returnL (HsTupleTy noExt+ else returnL (HsTupleTy noExtField HsBoxedOrConstraintTuple normals) | n == 1 -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor"))) | otherwise -> mk_apps- (HsTyVar noExt NotPromoted (noLoc (getRdrName (tupleTyCon Boxed n))))+ (HsTyVar noExtField NotPromoted (noLoc (getRdrName (tupleTyCon Boxed n)))) tys' UnboxedTupleT n | Just normals <- m_normals , normals `lengthIs` n -- Saturated- -> returnL (HsTupleTy noExt HsUnboxedTuple normals)+ -> returnL (HsTupleTy noExtField HsUnboxedTuple normals) | otherwise -> mk_apps- (HsTyVar noExt NotPromoted (noLoc (getRdrName (tupleTyCon Unboxed n))))+ (HsTyVar noExtField NotPromoted (noLoc (getRdrName (tupleTyCon Unboxed n)))) tys' UnboxedSumT n | n < 2@@ -1361,37 +1383,37 @@ text "Sums must have an arity of at least 2" ] | Just normals <- m_normals , normals `lengthIs` n -- Saturated- -> returnL (HsSumTy noExt normals)+ -> returnL (HsSumTy noExtField normals) | otherwise -> mk_apps- (HsTyVar noExt NotPromoted (noLoc (getRdrName (sumTyCon n))))+ (HsTyVar noExtField NotPromoted (noLoc (getRdrName (sumTyCon n)))) tys' ArrowT | Just normals <- m_normals , [x',y'] <- normals -> do x'' <- case unLoc x' of- HsFunTy{} -> returnL (HsParTy noExt x')- HsForAllTy{} -> returnL (HsParTy noExt x') -- #14646- HsQualTy{} -> returnL (HsParTy noExt x') -- #15324+ HsFunTy{} -> returnL (HsParTy noExtField x')+ HsForAllTy{} -> returnL (HsParTy noExtField x') -- #14646+ HsQualTy{} -> returnL (HsParTy noExtField x') -- #15324 _ -> return $ parenthesizeHsType sigPrec x' let y'' = parenthesizeHsType sigPrec y'- returnL (HsFunTy noExt x'' y'')+ returnL (HsFunTy noExtField x'' y'') | otherwise -> mk_apps- (HsTyVar noExt NotPromoted (noLoc (getRdrName funTyCon)))+ (HsTyVar noExtField NotPromoted (noLoc (getRdrName funTyCon))) tys' ListT | Just normals <- m_normals , [x'] <- normals -> do- returnL (HsListTy noExt x')+ returnL (HsListTy noExtField x') | otherwise -> mk_apps- (HsTyVar noExt NotPromoted (noLoc (getRdrName listTyCon)))+ (HsTyVar noExtField NotPromoted (noLoc (getRdrName listTyCon))) tys' VarT nm -> do { nm' <- tNameL nm- ; mk_apps (HsTyVar noExt NotPromoted nm') tys' }+ ; mk_apps (HsTyVar noExtField NotPromoted nm') tys' } ConT nm -> do { nm' <- tconName nm ; -- ConT can contain both data constructor (i.e., -- promoted) names and other (i.e, unpromoted)@@ -1400,7 +1422,7 @@ let prom = if isRdrDataCon nm' then IsPromoted else NotPromoted- ; mk_apps (HsTyVar noExt prom (noLoc nm')) tys'}+ ; mk_apps (HsTyVar noExtField prom (noLoc nm')) tys'} ForallT tvs cxt ty | null tys'@@ -1423,11 +1445,11 @@ SigT ty ki -> do { ty' <- cvtType ty ; ki' <- cvtKind ki- ; mk_apps (HsKindSig noExt ty' ki') tys'+ ; mk_apps (HsKindSig noExtField ty' ki') tys' } LitT lit- -> mk_apps (HsTyLit noExt (cvtTyLit lit)) tys'+ -> mk_apps (HsTyLit noExtField (cvtTyLit lit)) tys' WildCardT -> mk_apps mkAnonWildCardTy tys'@@ -1437,7 +1459,7 @@ ; t1' <- cvtType t1 ; t2' <- cvtType t2 ; mk_apps- (HsTyVar noExt NotPromoted (noLoc s'))+ (HsTyVar noExtField NotPromoted (noLoc s')) ([HsValArg t1', HsValArg t2'] ++ tys') } @@ -1449,11 +1471,11 @@ ParensT t -> do { t' <- cvtType t- ; mk_apps (HsParTy noExt t') tys'+ ; mk_apps (HsParTy noExtField t') tys' } PromotedT nm -> do { nm' <- cName nm- ; mk_apps (HsTyVar noExt IsPromoted (noLoc nm'))+ ; mk_apps (HsTyVar noExtField IsPromoted (noLoc nm')) tys' } -- Promoted data constructor; hence cName @@ -1462,34 +1484,34 @@ -> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str))) | Just normals <- m_normals , normals `lengthIs` n -- Saturated- -> returnL (HsExplicitTupleTy noExt normals)+ -> returnL (HsExplicitTupleTy noExtField normals) | otherwise -> mk_apps- (HsTyVar noExt IsPromoted (noLoc (getRdrName (tupleDataCon Boxed n))))+ (HsTyVar noExtField IsPromoted (noLoc (getRdrName (tupleDataCon Boxed n)))) tys' PromotedNilT- -> mk_apps (HsExplicitListTy noExt IsPromoted []) tys'+ -> mk_apps (HsExplicitListTy noExtField IsPromoted []) tys' PromotedConsT -- See Note [Representing concrete syntax in types] -- in Language.Haskell.TH.Syntax | Just normals <- m_normals , [ty1, dL->L _ (HsExplicitListTy _ ip tys2)] <- normals -> do- returnL (HsExplicitListTy noExt ip (ty1:tys2))+ returnL (HsExplicitListTy noExtField ip (ty1:tys2)) | otherwise -> mk_apps- (HsTyVar noExt IsPromoted (noLoc (getRdrName consDataCon)))+ (HsTyVar noExtField IsPromoted (noLoc (getRdrName consDataCon))) tys' StarT -> mk_apps- (HsTyVar noExt NotPromoted (noLoc (getRdrName liftedTypeKindTyCon)))+ (HsTyVar noExtField NotPromoted (noLoc (getRdrName liftedTypeKindTyCon))) tys' ConstraintT -> mk_apps- (HsTyVar noExt NotPromoted (noLoc (getRdrName constraintKindTyCon)))+ (HsTyVar noExtField NotPromoted (noLoc (getRdrName constraintKindTyCon))) tys' EqualityT@@ -1497,18 +1519,18 @@ , [x',y'] <- normals -> let px = parenthesizeHsType opPrec x' py = parenthesizeHsType opPrec y'- in returnL (HsOpTy noExt px (noLoc eqTyCon_RDR) py)+ in returnL (HsOpTy noExtField px (noLoc eqTyCon_RDR) py) -- The long-term goal is to remove the above case entirely and -- subsume it under the case for InfixT. See #15815, comment:6, -- for more details. | otherwise ->- mk_apps (HsTyVar noExt NotPromoted+ mk_apps (HsTyVar noExtField NotPromoted (noLoc eqTyCon_RDR)) tys' ImplicitParamT n t -> do { n' <- wrapL $ ipName n ; t' <- cvtType t- ; returnL (HsIParamTy noExt n' t')+ ; returnL (HsIParamTy noExtField n' t') } _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))@@ -1529,16 +1551,16 @@ go (arg:args) = case arg of HsValArg ty -> do p_ty <- add_parens ty- mk_apps (HsAppTy noExt phead_ty p_ty) args+ mk_apps (HsAppTy noExtField phead_ty p_ty) args HsTypeArg l ki -> do p_ki <- add_parens ki mk_apps (HsAppKindTy l phead_ty p_ki) args- HsArgPar _ -> mk_apps (HsParTy noExt phead_ty) args+ HsArgPar _ -> mk_apps (HsParTy noExtField phead_ty) args go type_args where -- See Note [Adding parens for splices] add_parens lt@(dL->L _ t)- | hsTypeNeedsParens appPrec t = returnL (HsParTy noExt lt)+ | hsTypeNeedsParens appPrec t = returnL (HsParTy noExtField lt) | otherwise = return lt wrap_tyarg :: LHsTypeArg GhcPs -> LHsTypeArg GhcPs@@ -1574,7 +1596,7 @@ mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL where go :: LHsType GhcPs -> HsType GhcPs -> CvtM (HsType GhcPs) go arg ret_ty = do { ret_ty_l <- returnL ret_ty- ; return (HsFunTy noExt arg ret_ty_l) }+ ; return (HsFunTy noExtField arg ret_ty_l) } split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsTypeArg GhcPs]) split_ty_app ty = go ty []@@ -1612,18 +1634,18 @@ -- signature is possible). cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind -> CvtM (LFamilyResultSig GhcPs)-cvtMaybeKindToFamilyResultSig Nothing = returnL (Hs.NoSig noExt)+cvtMaybeKindToFamilyResultSig Nothing = returnL (Hs.NoSig noExtField) cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki- ; returnL (Hs.KindSig noExt ki') }+ ; returnL (Hs.KindSig noExtField ki') } -- | Convert type family result signature. Used with both open and closed type -- families. cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig GhcPs)-cvtFamilyResultSig TH.NoSig = returnL (Hs.NoSig noExt)+cvtFamilyResultSig TH.NoSig = returnL (Hs.NoSig noExtField) cvtFamilyResultSig (TH.KindSig ki) = do { ki' <- cvtKind ki- ; returnL (Hs.KindSig noExt ki') }+ ; returnL (Hs.KindSig noExtField ki') } cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr- ; returnL (Hs.TyVarSig noExt tv) }+ ; returnL (Hs.TyVarSig noExtField tv) } -- | Convert injectivity annotation of a type family. cvtInjectivityAnnotation :: TH.InjectivityAnn@@ -1642,7 +1664,7 @@ | null univs, null reqs = do { l <- getL ; ty' <- cvtType (ForallT exis provs ty) ; return $ cL l (HsQualTy { hst_ctxt = cL l []- , hst_xqual = noExt+ , hst_xqual = noExtField , hst_body = ty' }) } | null reqs = do { l <- getL ; univs' <- hsQTvExplicit <$> cvtTvs univs@@ -1650,10 +1672,10 @@ ; let forTy = HsForAllTy { hst_fvf = ForallInvis , hst_bndrs = univs'- , hst_xforall = noExt+ , hst_xforall = noExtField , hst_body = cL l cxtTy } cxtTy = HsQualTy { hst_ctxt = cL l []- , hst_xqual = noExt+ , hst_xqual = noExtField , hst_body = ty' } ; return $ cL l forTy } | otherwise = cvtType (ForallT univs reqs (ForallT exis provs ty))@@ -1716,7 +1738,7 @@ | null tvs = rho_ty | otherwise = cL loc $ HsForAllTy { hst_fvf = fvf , hst_bndrs = hsQTvExplicit tvs'- , hst_xforall = noExt+ , hst_xforall = noExtField , hst_body = rho_ty } -- | If passed an empty 'TH.Cxt', this simply returns the third argument@@ -1739,7 +1761,7 @@ -- ^ The complete type, qualified with a context if necessary mkHsQualTy ctxt loc ctxt' ty | null ctxt = ty- | otherwise = cL loc $ HsQualTy { hst_xqual = noExt+ | otherwise = cL loc $ HsQualTy { hst_xqual = noExtField , hst_ctxt = ctxt' , hst_body = ty }
compiler/iface/MkIface.hs view
@@ -115,6 +115,7 @@ import Data.Function import Data.List import qualified Data.Map as Map+import qualified Data.Set as Set import Data.Ord import Data.IORef import System.Directory@@ -1177,8 +1178,8 @@ -- is equivalent to the current source file the user asked us to compile. -- If the same, we can avoid recompilation. We return a tuple where the -- first element is a bool saying if we should recompile the object file--- and the second is maybe the interface file, where Nothng means to--- rebuild the interface file not use the exisitng one.+-- and the second is maybe the interface file, where Nothing means to+-- rebuild the interface file and not use the existing one. checkOldIface :: HscEnv -> ModSummary@@ -1486,11 +1487,30 @@ -- - a new home module has been added that shadows a package module -- See bug #1372. --+-- In addition, we also check if the union of dependencies of the imported+-- modules has any difference to the previous set of dependencies. We would need+-- to recompile in that case also since the `mi_deps` field of ModIface needs+-- to be updated to match that information. This is one of the invariants+-- of interface files (see https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance#interface-file-invariants).+-- See bug #16511.+-- -- Returns (RecompBecause <textual reason>) if recompilation is required. checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired checkDependencies hsc_env summary iface- = checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary))- where+ = do+ checkList $+ [ checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary))+ , do+ (recomp, mnames_seen) <- runUntilRecompRequired $ map+ checkForNewHomeDependency+ (ms_home_imps summary)+ case recomp of+ UpToDate -> do+ let+ seen_home_deps = Set.unions $ map Set.fromList mnames_seen+ checkIfAllOldHomeDependenciesAreSeen seen_home_deps+ _ -> return recomp]+ where prev_dep_mods = dep_mods (mi_deps iface) prev_dep_plgn = dep_plgins (mi_deps iface) prev_dep_pkgs = dep_pkgs (mi_deps iface)@@ -1522,12 +1542,74 @@ where pkg = moduleUnitId mod _otherwise -> return (RecompBecause reason) + old_deps = Set.fromList $ map fst $ filter (not . snd) prev_dep_mods+ isOldHomeDeps = flip Set.member old_deps+ checkForNewHomeDependency (L _ mname) = do+ let+ mod = mkModule this_pkg mname+ str_mname = moduleNameString mname+ reason = str_mname ++ " changed"+ -- We only want to look at home modules to check if any new home dependency+ -- pops in and thus here, skip modules that are not home. Checking+ -- membership in old home dependencies suffice because the `dep_missing`+ -- check already verified that all imported home modules are present there.+ if not (isOldHomeDeps mname)+ then return (UpToDate, [])+ else do+ mb_result <- getFromModIface "need mi_deps for" mod $ \imported_iface -> do+ let mnames = mname:(map fst $ filter (not . snd) $+ dep_mods $ mi_deps imported_iface)+ case find (not . isOldHomeDeps) mnames of+ Nothing -> return (UpToDate, mnames)+ Just new_dep_mname -> do+ traceHiDiffs $+ text "imported home module " <> quotes (ppr mod) <>+ text " has a new dependency " <> quotes (ppr new_dep_mname)+ return (RecompBecause reason, [])+ return $ fromMaybe (MustCompile, []) mb_result++ -- Performs all recompilation checks in the list until a check that yields+ -- recompile required is encountered. Returns the list of the results of+ -- all UpToDate checks.+ runUntilRecompRequired [] = return (UpToDate, [])+ runUntilRecompRequired (check:checks) = do+ (recompile, value) <- check+ if recompileRequired recompile+ then return (recompile, [])+ else do+ (recomp, values) <- runUntilRecompRequired checks+ return (recomp, value:values)++ checkIfAllOldHomeDependenciesAreSeen seen_deps = do+ let unseen_old_deps = Set.difference+ old_deps+ seen_deps+ if not (null unseen_old_deps)+ then do+ let missing_dep = Set.elemAt 0 unseen_old_deps+ traceHiDiffs $+ text "missing old home dependency " <> quotes (ppr missing_dep)+ return $ RecompBecause "missing old dependency"+ else return UpToDate+ needInterface :: Module -> (ModIface -> IfG RecompileRequired)- -> IfG RecompileRequired+ -> IfG RecompileRequired needInterface mod continue+ = do+ mb_recomp <- getFromModIface+ "need version info for"+ mod+ continue+ case mb_recomp of+ Nothing -> return MustCompile+ Just recomp -> return recomp++getFromModIface :: String -> Module -> (ModIface -> IfG a)+ -> IfG (Maybe a)+getFromModIface doc_msg mod getter = do -- Load the imported interface if possible- let doc_str = sep [text "need version info for", ppr mod]- traceHiDiffs (text "Checking usages for module" <+> ppr mod)+ let doc_str = sep [text doc_msg, ppr mod]+ traceHiDiffs (text "Checking innterface for module" <+> ppr mod) mb_iface <- loadInterface doc_str mod ImportBySystem -- Load the interface, but don't complain on failure;@@ -1537,12 +1619,12 @@ Failed _ -> do traceHiDiffs (sep [text "Couldn't load interface for module", ppr mod])- return MustCompile+ return Nothing -- Couldn't find or parse a module mentioned in the -- old interface file. Don't complain: it might -- just be that the current module doesn't need that -- import and it's been deleted- Succeeded iface -> continue iface+ Succeeded iface -> Just <$> getter iface -- | Given the usage information extracted from the old -- M.hi file for the module being compiled, figure out
compiler/iface/TcIface.hs view
@@ -35,6 +35,7 @@ import Coercion import CoAxiom import TyCoRep -- needs to build types & coercions in a knot+import TyCoSubst ( substTyCoVars ) import HscTypes import Annotations import InstEnv
compiler/llvmGen/LlvmCodeGen.hs view
@@ -90,7 +90,7 @@ where header :: SDoc header = sdocWithDynFlags $ \dflags ->- let target = LLVM_TARGET+ let target = platformMisc_llvmTarget $ platformMisc dflags layout = case lookup target (llvmTargets dflags) of Just (LlvmTarget dl _ _) -> dl Nothing -> error $ "Failed to lookup the datalayout for " ++ target ++ "; available targets: " ++ show (map fst $ llvmTargets dflags)
compiler/llvmGen/LlvmCodeGen/Base.hs view
@@ -152,12 +152,12 @@ where platform = targetPlatform dflags isLive r = not (isSSE r) || r `elem` alwaysLive || r `elem` live isPassed r = not (isSSE r) || isLive r- isSSE (FloatReg _) = True- isSSE (DoubleReg _) = True- isSSE (XmmReg _ _ _ _ ) = True- isSSE (YmmReg _ _ _ _ ) = True- isSSE (ZmmReg _ _ _ _ ) = True- isSSE _ = False+ isSSE (FloatReg _) = True+ isSSE (DoubleReg _) = True+ isSSE (XmmReg _) = True+ isSSE (YmmReg _) = True+ isSSE (ZmmReg _) = True+ isSSE _ = False -- | Llvm standard fun attributes llvmStdFunAttrs :: [LlvmFuncAttr]
compiler/llvmGen/LlvmCodeGen/CodeGen.hs view
@@ -1287,7 +1287,6 @@ MO_VU_Quot _ _ -> panicOp MO_VU_Rem _ _ -> panicOp - MO_VF_Broadcast _ _ -> panicOp MO_VF_Insert _ _ -> panicOp MO_VF_Extract _ _ -> panicOp @@ -1484,7 +1483,6 @@ MO_VS_Neg {} -> panicOp - MO_VF_Broadcast {} -> panicOp MO_VF_Insert {} -> panicOp MO_VF_Extract {} -> panicOp @@ -1846,9 +1844,9 @@ let liveRegs = alwaysLive ++ live isSSE (FloatReg _) = True isSSE (DoubleReg _) = True- isSSE (XmmReg _ _ _ _) = True- isSSE (YmmReg _ _ _ _) = True- isSSE (ZmmReg _ _ _ _) = True+ isSSE (XmmReg _) = True+ isSSE (YmmReg _) = True+ isSSE (ZmmReg _) = True isSSE _ = False -- Set to value or "undef" depending on whether the register is
compiler/llvmGen/LlvmCodeGen/Regs.hs view
@@ -60,24 +60,24 @@ DoubleReg 4 -> doubleGlobal $ "D4" ++ suf DoubleReg 5 -> doubleGlobal $ "D5" ++ suf DoubleReg 6 -> doubleGlobal $ "D6" ++ suf- XmmReg 1 _ _ _ -> xmmGlobal $ "XMM1" ++ suf- XmmReg 2 _ _ _ -> xmmGlobal $ "XMM2" ++ suf- XmmReg 3 _ _ _ -> xmmGlobal $ "XMM3" ++ suf- XmmReg 4 _ _ _ -> xmmGlobal $ "XMM4" ++ suf- XmmReg 5 _ _ _ -> xmmGlobal $ "XMM5" ++ suf- XmmReg 6 _ _ _ -> xmmGlobal $ "XMM6" ++ suf- YmmReg 1 _ _ _ -> ymmGlobal $ "YMM1" ++ suf- YmmReg 2 _ _ _ -> ymmGlobal $ "YMM2" ++ suf- YmmReg 3 _ _ _ -> ymmGlobal $ "YMM3" ++ suf- YmmReg 4 _ _ _ -> ymmGlobal $ "YMM4" ++ suf- YmmReg 5 _ _ _ -> ymmGlobal $ "YMM5" ++ suf- YmmReg 6 _ _ _ -> ymmGlobal $ "YMM6" ++ suf- ZmmReg 1 _ _ _ -> zmmGlobal $ "ZMM1" ++ suf- ZmmReg 2 _ _ _ -> zmmGlobal $ "ZMM2" ++ suf- ZmmReg 3 _ _ _ -> zmmGlobal $ "ZMM3" ++ suf- ZmmReg 4 _ _ _ -> zmmGlobal $ "ZMM4" ++ suf- ZmmReg 5 _ _ _ -> zmmGlobal $ "ZMM5" ++ suf- ZmmReg 6 _ _ _ -> zmmGlobal $ "ZMM6" ++ suf+ XmmReg 1 -> xmmGlobal $ "XMM1" ++ suf+ XmmReg 2 -> xmmGlobal $ "XMM2" ++ suf+ XmmReg 3 -> xmmGlobal $ "XMM3" ++ suf+ XmmReg 4 -> xmmGlobal $ "XMM4" ++ suf+ XmmReg 5 -> xmmGlobal $ "XMM5" ++ suf+ XmmReg 6 -> xmmGlobal $ "XMM6" ++ suf+ YmmReg 1 -> ymmGlobal $ "YMM1" ++ suf+ YmmReg 2 -> ymmGlobal $ "YMM2" ++ suf+ YmmReg 3 -> ymmGlobal $ "YMM3" ++ suf+ YmmReg 4 -> ymmGlobal $ "YMM4" ++ suf+ YmmReg 5 -> ymmGlobal $ "YMM5" ++ suf+ YmmReg 6 -> ymmGlobal $ "YMM6" ++ suf+ ZmmReg 1 -> zmmGlobal $ "ZMM1" ++ suf+ ZmmReg 2 -> zmmGlobal $ "ZMM2" ++ suf+ ZmmReg 3 -> zmmGlobal $ "ZMM3" ++ suf+ ZmmReg 4 -> zmmGlobal $ "ZMM4" ++ suf+ ZmmReg 5 -> zmmGlobal $ "ZMM5" ++ suf+ ZmmReg 6 -> zmmGlobal $ "ZMM6" ++ suf MachSp -> wordGlobal $ "MachSp" ++ suf _other -> panic $ "LlvmCodeGen.Reg: GlobalReg (" ++ (show reg) ++ ") not supported!"
compiler/main/CodeOutput.hs view
@@ -120,28 +120,29 @@ -- ToDo: make the C backend consume the C-- incrementally, by -- pushing the cmm_stream inside (c.f. nativeCodeGen) rawcmms <- Stream.collect cmm_stream+ withTiming (return dflags) (text "C codegen") id $ do - -- figure out which header files to #include in the generated .hc file:- --- -- * extra_includes from packages- -- * -#include options from the cmdline and OPTIONS pragmas- -- * the _stub.h file, if there is one.- --- let rts = getPackageDetails dflags rtsUnitId+ -- figure out which header files to #include in the generated .hc file:+ --+ -- * extra_includes from packages+ -- * -#include options from the cmdline and OPTIONS pragmas+ -- * the _stub.h file, if there is one.+ --+ let rts = getPackageDetails dflags rtsUnitId - let cc_injects = unlines (map mk_include (includes rts))- mk_include h_file =- case h_file of- '"':_{-"-} -> "#include "++h_file- '<':_ -> "#include "++h_file- _ -> "#include \""++h_file++"\""+ let cc_injects = unlines (map mk_include (includes rts))+ mk_include h_file =+ case h_file of+ '"':_{-"-} -> "#include "++h_file+ '<':_ -> "#include "++h_file+ _ -> "#include \""++h_file++"\"" - let pkg_names = map installedUnitIdString packages+ let pkg_names = map installedUnitIdString packages - doOutput filenm $ \ h -> do- hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")- hPutStr h cc_injects- writeCs dflags h rawcmms+ doOutput filenm $ \ h -> do+ hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")+ hPutStr h cc_injects+ writeCs dflags h rawcmms {- ************************************************************************@@ -252,8 +253,8 @@ then Just stub_c else Nothing ) where- cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"- cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n"+ cplusplus_hdr = "#if defined(__cplusplus)\nextern \"C\" {\n#endif\n"+ cplusplus_ftr = "#if defined(__cplusplus)\n}\n#endif\n" -- Don't use doOutput for dumping the f. export stubs
compiler/main/DriverPipeline.hs view
@@ -867,7 +867,7 @@ , not (any (isInfixOf "-mcpu") (getOpts dflags opt_lc)) ] ++ [("", "-mattr=" ++ attrs) | not (null attrs) ] - where target = LLVM_TARGET+ where target = platformMisc_llvmTarget $ platformMisc dflags Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets dflags) -- Relocation models@@ -1962,11 +1962,13 @@ let cpp_prog args | raw = SysTools.runCpp dflags args | otherwise = SysTools.runCc Nothing dflags (SysTools.Option "-E" : args) + let targetArch = stringEncodeArch $ platformArch $ targetPlatform dflags+ targetOS = stringEncodeOS $ platformOS $ targetPlatform dflags let target_defs = [ "-D" ++ HOST_OS ++ "_BUILD_OS", "-D" ++ HOST_ARCH ++ "_BUILD_ARCH",- "-D" ++ TARGET_OS ++ "_HOST_OS",- "-D" ++ TARGET_ARCH ++ "_HOST_ARCH" ]+ "-D" ++ targetOS ++ "_HOST_OS",+ "-D" ++ targetArch ++ "_HOST_ARCH" ] -- remember, in code we *compile*, the HOST is the same our TARGET, -- and BUILD is the same as our HOST.
compiler/main/GhcMake.hs view
@@ -2198,15 +2198,17 @@ -- to by the user. But we need them, so we patch their locations in -- the ModSummary with temporary files. --- hi_file <-+ (hi_file, o_file) <-+ -- If ``-fwrite-interface` is specified, then the .o and .hi files+ -- are written into `-odir` and `-hidir` respectively. #16670 if gopt Opt_WriteInterface dflags- then return $ ml_hi_file ms_location- else new_temp_file (hiSuf dflags) (dynHiSuf dflags)- o_temp_file <- new_temp_file (objectSuf dflags) (dynObjectSuf dflags)+ then return (ml_hi_file ms_location, ml_obj_file ms_location)+ else (,) <$> (new_temp_file (hiSuf dflags) (dynHiSuf dflags))+ <*> (new_temp_file (objectSuf dflags) (dynObjectSuf dflags)) return $ ms { ms_location =- ms_location {ml_hi_file = hi_file, ml_obj_file = o_temp_file}+ ms_location {ml_hi_file = hi_file, ml_obj_file = o_file} , ms_hspp_opts = updOptLevel 0 $ dflags {hscTarget = target} } | otherwise = return ms@@ -2254,28 +2256,6 @@ msDeps s = concat [ [(m,IsBoot), (m,NotBoot)] | m <- ms_home_srcimps s ] ++ [ (m,NotBoot) | m <- ms_home_imps s ]--home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName]-home_imps imps = [ lmodname | (mb_pkg, lmodname) <- imps,- isLocal mb_pkg ]- where isLocal Nothing = True- isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special- isLocal _ = False--ms_home_allimps :: ModSummary -> [ModuleName]-ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)---- | Like 'ms_home_imps', but for SOURCE imports.-ms_home_srcimps :: ModSummary -> [Located ModuleName]-ms_home_srcimps = home_imps . ms_srcimps---- | All of the (possibly) home module imports from a--- 'ModSummary'; that is to say, each of these module names--- could be a home import if an appropriately named file--- existed. (This is in contrast to package qualified--- imports, which are guaranteed not to be home imports.)-ms_home_imps :: ModSummary -> [Located ModuleName]-ms_home_imps = home_imps . ms_imps ----------------------------------------------------------------------------- -- Summarising modules
compiler/main/HscMain.hs view
@@ -965,11 +965,13 @@ -> return tcg_env' warns dflags rules = listToBag $ map (warnRules dflags) rules++ warnRules :: DynFlags -> GenLocated SrcSpan (RuleDecl GhcTc) -> ErrMsg warnRules dflags (L loc (HsRule { rd_name = n })) = mkPlainWarnMsg dflags loc $ text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$ text "User defined rules are disabled under Safe Haskell"- warnRules _ (L _ (XRuleDecl _)) = panic "hscCheckSafeImports"+ warnRules _ (L _ (XRuleDecl nec)) = noExtCon nec -- | Validate that safe imported modules are actually safe. For modules in the -- HomePackage (the package the module we are compiling in resides) this just@@ -1470,7 +1472,7 @@ let dflags = hsc_dflags hsc_env cmm <- ioMsgMaybe $ parseCmmFile dflags filename liftIO $ do- dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose "Parsed Cmm" (ppr cmm)+ dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" (ppr cmm) let -- Make up a module name to give the NCG. We can't pass bottom here -- lest we reproduce #11784. mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename
compiler/main/HscStats.hs view
@@ -122,7 +122,7 @@ import_info (dL->L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual , ideclAs = as, ideclHiding = spec })) = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec)- import_info (dL->L _ (XImportDecl _)) = panic "import_info"+ import_info (dL->L _ (XImportDecl nec)) = noExtCon nec import_info _ = panic " import_info: Impossible Match" -- due to #15884 @@ -163,8 +163,8 @@ ss, is, length ats, length adts) where methods = map unLoc $ bagToList inst_meths- inst_info (ClsInstD _ (XClsInstDecl _)) = panic "inst_info"- inst_info (XInstDecl _) = panic "inst_info"+ inst_info (ClsInstD _ (XClsInstDecl nec)) = noExtCon nec+ inst_info (XInstDecl nec) = noExtCon nec -- TODO: use Sum monoid addpr :: (Int,Int,Int) -> Int
compiler/main/InteractiveEval.hs view
@@ -104,7 +104,7 @@ import Data.Array import Exception -import TcRnDriver ( runTcInteractive, tcRnType )+import TcRnDriver ( runTcInteractive, tcRnType, loadUnqualIfaces ) import TcHsSyn ( ZonkFlexi (SkolemiseFlexi) ) import TcEnv (tcGetInstEnvs)@@ -521,20 +521,17 @@ breaks = getModBreaks hmi info = expectJust "bindLocalsAtBreakpoint2" $ IntMap.lookup breakInfo_number (modBreaks_breakInfo breaks)- vars = cgb_vars info+ mbVars = cgb_vars info result_ty = cgb_resty info occs = modBreaks_vars breaks ! breakInfo_number span = modBreaks_locs breaks ! breakInfo_number decl = intercalate "." $ modBreaks_decls breaks ! breakInfo_number - -- Filter out any unboxed ids;+ -- Filter out any unboxed ids by changing them to Nothings; -- we can't bind these at the prompt- pointers = filter (\(id,_) -> isPointer id) vars- isPointer id | [rep] <- typePrimRep (idType id)- , isGcPtrRep rep = True- | otherwise = False+ mbPointers = nullUnboxed <$> mbVars - (ids, offsets) = unzip pointers+ (ids, offsets, occs') = syncOccs mbPointers occs free_tvs = tyCoVarsOfTypesList (result_ty:map idType ids) @@ -550,11 +547,12 @@ us <- mkSplitUniqSupply 'I' -- Dodgy; will give the same uniques every time let tv_subst = newTyVars us free_tvs- filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]+ (filtered_ids, occs'') = unzip -- again, sync the occ-names+ [ (id, occ) | (id, Just _hv, occ) <- zip3 ids mb_hValues occs' ] (_,tidy_tys) = tidyOpenTypes emptyTidyEnv $ map (substTy tv_subst . idType) filtered_ids - new_ids <- zipWith3M mkNewId occs tidy_tys filtered_ids+ new_ids <- zipWith3M mkNewId occs'' tidy_tys filtered_ids result_name <- newInteractiveBinder hsc_env (mkVarOccFS result_fs) span let result_id = Id.mkVanillaGlobal result_name@@ -591,6 +589,24 @@ | (tv, uniq) <- tvs `zip` uniqsFromSupply us , let name = setNameUnique (tyVarName tv) uniq ] + isPointer id | [rep] <- typePrimRep (idType id)+ , isGcPtrRep rep = True+ | otherwise = False++ -- Convert unboxed Id's to Nothings+ nullUnboxed (Just (fv@(id, _)))+ | isPointer id = Just fv+ | otherwise = Nothing+ nullUnboxed Nothing = Nothing++ -- See Note [Syncing breakpoint info]+ syncOccs :: [Maybe (a,b)] -> [c] -> ([a], [b], [c])+ syncOccs mbVs ocs = unzip3 $ catMaybes $ joinOccs mbVs ocs+ where+ joinOccs :: [Maybe (a,b)] -> [c] -> [Maybe (a,b,c)]+ joinOccs = zipWith joinOcc+ joinOcc mbV oc = (\(a,b) c -> (a,b,c)) <$> mbV <*> pure oc+ rttiEnvironment :: HscEnv -> IO HscEnv rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do let tmp_ids = [id | AnId id <- ic_tythings ic]@@ -632,6 +648,35 @@ ictxt0 = hsc_IC hsc_env ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 } ++ {-+ Note [Syncing breakpoint info]++ To display the values of the free variables for a single breakpoint, the+ function `compiler/main/InteractiveEval.hs:bindLocalsAtBreakpoint` pulls+ out the information from the fields `modBreaks_breakInfo` and+ `modBreaks_vars` of the `ModBreaks` data structure.+ For a specific breakpoint this gives 2 lists of type `Id` (or `Var`)+ and `OccName`.+ They are used to create the Id's for the free variables and must be kept+ in sync!++ There are 3 situations where items are removed from the Id list+ (or replaced with `Nothing`):+ 1.) If function `compiler/ghci/ByteCodeGen.hs:schemeER_wrk` (which creates+ the Id list) doesn't find an Id in the ByteCode environement.+ 2.) If function `compiler/main/InteractiveEval.hs:bindLocalsAtBreakpoint`+ filters out unboxed elements from the Id list, because GHCi cannot+ yet handle them.+ 3.) If the GHCi interpreter doesn't find the reference to a free variable+ of our breakpoint. This also happens in the function+ bindLocalsAtBreakpoint.++ If an element is removed from the Id list, then the corresponding element+ must also be removed from the Occ list. Otherwise GHCi will confuse+ variable names as in #8487.+ -}+ -- ----------------------------------------------------------------------------- -- Abandoning a resume context @@ -1003,6 +1048,8 @@ getInstancesForType ty = withSession $ \hsc_env -> do liftIO $ runInteractiveHsc hsc_env $ do ioMsgMaybe $ runTcInteractive hsc_env $ do+ -- Bring class and instances from unqualified modules into scope, this fixes #16793.+ loadUnqualIfaces hsc_env (hsc_IC hsc_env) matches <- findMatchingInstances ty fmap catMaybes . forM matches $ uncurry checkForExistence @@ -1138,8 +1185,8 @@ -- create a new binding. let expr_fs = fsLit "_compileParsedExpr" expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc- let_stmt = L loc . LetStmt noExt . L loc . (HsValBinds noExt) $- ValBinds noExt+ let_stmt = L loc . LetStmt noExtField . L loc . (HsValBinds noExtField) $+ ValBinds noExtField (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) [] pstmt <- liftIO $ hscParsedStmt hsc_env let_stmt@@ -1167,7 +1214,7 @@ parsed_expr <- parseExpr expr -- > Data.Dynamic.toDyn expr let loc = getLoc parsed_expr- to_dyn_expr = mkHsApp (L loc . HsVar noExt . L loc $ getRdrName toDynName)+ to_dyn_expr = mkHsApp (L loc . HsVar noExtField . L loc $ getRdrName toDynName) parsed_expr hval <- compileParsedExpr to_dyn_expr return (unsafeCoerce# hval :: Dynamic)
compiler/main/SysTools.hs view
@@ -236,6 +236,8 @@ ld_prog = cc_prog ld_args = map Option (cc_args ++ words cc_link_args_str) + llvmTarget <- getSetting "LLVM target"+ -- We just assume on command line lc_prog <- getSetting "LLVM llc command" lo_prog <- getSetting "LLVM opt command"@@ -336,6 +338,7 @@ , platformMisc_ghcThreaded = ghcThreaded , platformMisc_ghcDebugged = ghcDebugged , platformMisc_ghcRtsWithLibdw = ghcRtsWithLibdw+ , platformMisc_llvmTarget = llvmTarget } , sPlatformConstants = platformConstants
compiler/main/SysTools/Tasks.hs view
@@ -37,14 +37,14 @@ -} runUnlit :: DynFlags -> [Option] -> IO ()-runUnlit dflags args = do+runUnlit dflags args = traceToolCommand dflags "unlit" $ do let prog = pgm_L dflags opts = getOpts dflags opt_L runSomething dflags "Literate pre-processor" prog (map Option opts ++ args) runCpp :: DynFlags -> [Option] -> IO ()-runCpp dflags args = do+runCpp dflags args = traceToolCommand dflags "cpp" $ do let (p,args0) = pgm_P dflags args1 = map Option (getOpts dflags opt_P) args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags]@@ -54,14 +54,14 @@ (args0 ++ args1 ++ args2 ++ args) Nothing mb_env runPp :: DynFlags -> [Option] -> IO ()-runPp dflags args = do+runPp dflags args = traceToolCommand dflags "pp" $ do let prog = pgm_F dflags opts = map Option (getOpts dflags opt_F) runSomething dflags "Haskell pre-processor" prog (args ++ opts) -- | Run compiler of C-like languages and raw objects (such as gcc or clang). runCc :: Maybe ForeignSrcLang -> DynFlags -> [Option] -> IO ()-runCc mLanguage dflags args = do+runCc mLanguage dflags args = traceToolCommand dflags "cc" $ do let p = pgm_c dflags args1 = map Option userOpts args2 = languageOptions ++ args ++ args1@@ -144,7 +144,7 @@ -- | Run the linker with some arguments and return the output askLd :: DynFlags -> [Option] -> IO String-askLd dflags args = do+askLd dflags args = traceToolCommand dflags "linker" $ do let (p,args0) = pgm_l dflags args1 = map Option (getOpts dflags opt_l) args2 = args0 ++ args1 ++ args@@ -153,7 +153,7 @@ readCreateProcessWithExitCode' (proc p real_args){ env = mb_env } runAs :: DynFlags -> [Option] -> IO ()-runAs dflags args = do+runAs dflags args = traceToolCommand dflags "as" $ do let (p,args0) = pgm_a dflags args1 = map Option (getOpts dflags opt_a) args2 = args0 ++ args1 ++ args@@ -162,7 +162,7 @@ -- | Run the LLVM Optimiser runLlvmOpt :: DynFlags -> [Option] -> IO ()-runLlvmOpt dflags args = do+runLlvmOpt dflags args = traceToolCommand dflags "opt" $ do let (p,args0) = pgm_lo dflags args1 = map Option (getOpts dflags opt_lo) -- We take care to pass -optlo flags (e.g. args0) last to ensure that the@@ -171,7 +171,7 @@ -- | Run the LLVM Compiler runLlvmLlc :: DynFlags -> [Option] -> IO ()-runLlvmLlc dflags args = do+runLlvmLlc dflags args = traceToolCommand dflags "llc" $ do let (p,args0) = pgm_lc dflags args1 = map Option (getOpts dflags opt_lc) runSomething dflags "LLVM Compiler" p (args0 ++ args1 ++ args)@@ -180,7 +180,7 @@ -- backend on OS X as LLVM doesn't support the OS X system -- assembler) runClang :: DynFlags -> [Option] -> IO ()-runClang dflags args = do+runClang dflags args = traceToolCommand dflags "clang" $ do let (clang,_) = pgm_lcc dflags -- be careful what options we call clang with -- see #5903 and #7617 for bugs caused by this.@@ -201,7 +201,7 @@ -- | Figure out which version of LLVM we are running this session figureLlvmVersion :: DynFlags -> IO (Maybe LlvmVersion)-figureLlvmVersion dflags = do+figureLlvmVersion dflags = traceToolCommand dflags "llc" $ do let (pgm,opts) = pgm_lc dflags args = filter notNull (map showOpt opts) -- we grab the args even though they should be useless just in@@ -246,7 +246,7 @@ runLink :: DynFlags -> [Option] -> IO ()-runLink dflags args = do+runLink dflags args = traceToolCommand dflags "linker" $ do -- See Note [Run-time linker info] linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags let (p,args0) = pgm_l dflags@@ -306,7 +306,7 @@ runLibtool :: DynFlags -> [Option] -> IO ()-runLibtool dflags args = do+runLibtool dflags args = traceToolCommand dflags "libtool" $ do linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags let args1 = map Option (getOpts dflags opt_l) args2 = [Option "-static"] ++ args1 ++ args ++ linkargs@@ -315,30 +315,30 @@ runSomethingFiltered dflags id "Linker" libtool args2 Nothing mb_env runAr :: DynFlags -> Maybe FilePath -> [Option] -> IO ()-runAr dflags cwd args = do+runAr dflags cwd args = traceToolCommand dflags "ar" $ do let ar = pgm_ar dflags runSomethingFiltered dflags id "Ar" ar args cwd Nothing askAr :: DynFlags -> Maybe FilePath -> [Option] -> IO String-askAr dflags mb_cwd args = do+askAr dflags mb_cwd args = traceToolCommand dflags "ar" $ do let ar = pgm_ar dflags runSomethingWith dflags "Ar" ar args $ \real_args -> readCreateProcessWithExitCode' (proc ar real_args){ cwd = mb_cwd } runRanlib :: DynFlags -> [Option] -> IO ()-runRanlib dflags args = do+runRanlib dflags args = traceToolCommand dflags "ranlib" $ do let ranlib = pgm_ranlib dflags runSomethingFiltered dflags id "Ranlib" ranlib args Nothing Nothing runMkDLL :: DynFlags -> [Option] -> IO ()-runMkDLL dflags args = do+runMkDLL dflags args = traceToolCommand dflags "mkdll" $ do let (p,args0) = pgm_dll dflags args1 = args0 ++ args mb_env <- getGccEnv (args0++args) runSomethingFiltered dflags id "Make DLL" p args1 Nothing mb_env runWindres :: DynFlags -> [Option] -> IO ()-runWindres dflags args = do+runWindres dflags args = traceToolCommand dflags "windres" $ do let cc = pgm_c dflags cc_args = map Option (sOpt_c (settings dflags)) windres = pgm_windres dflags@@ -361,5 +361,18 @@ runSomethingFiltered dflags id "Windres" windres args' Nothing mb_env touch :: DynFlags -> String -> String -> IO ()-touch dflags purpose arg =+touch dflags purpose arg = traceToolCommand dflags "touch" $ runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]++-- * Tracing utility++-- | Record in the eventlog when the given tool command starts+-- and finishes, prepending the given 'String' with+-- \"systool:\", to easily be able to collect and process+-- all the systool events.+--+-- For those events to show up in the eventlog, you need+-- to run GHC with @-v2@ or @-ddump-timings@.+traceToolCommand :: DynFlags -> String -> IO a -> IO a+traceToolCommand dflags tool = withTiming+ (return dflags) (text $ "systool:" ++ tool) (const ())
compiler/nativeGen/AsmCodeGen.hs view
@@ -335,7 +335,7 @@ -> NativeGenAcc statics instr -> IO UniqSupply finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs- = do+ = withTiming (return dflags) (text "NCG") (`seq` ()) $ do -- Write debug data and finish let emitDw = debugLevel dflags > 0 us' <- if not emitDw then return us else do@@ -401,28 +401,33 @@ }, us) Right (cmms, cmm_stream') -> do-- -- Generate debug information- let debugFlag = debugLevel dflags > 0- !ndbgs | debugFlag = cmmDebugGen modLoc cmms- | otherwise = []- dbgMap = debugToMap ndbgs+ (us', ngs'') <-+ withTiming (return dflags)+ ncglabel (\(a, b) -> a `seq` b `seq` ()) $ do+ -- Generate debug information+ let debugFlag = debugLevel dflags > 0+ !ndbgs | debugFlag = cmmDebugGen modLoc cmms+ | otherwise = []+ dbgMap = debugToMap ndbgs - -- Generate native code- (ngs',us') <- cmmNativeGens dflags this_mod modLoc ncgImpl h- dbgMap us cmms ngs 0+ -- Generate native code+ (ngs',us') <- cmmNativeGens dflags this_mod modLoc ncgImpl h+ dbgMap us cmms ngs 0 - -- Link native code information into debug blocks- -- See Note [What is this unwinding business?] in Debug.- let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs- dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos"- (vcat $ map ppr ldbgs)+ -- Link native code information into debug blocks+ -- See Note [What is this unwinding business?] in Debug.+ let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs+ dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos"+ (vcat $ map ppr ldbgs) - -- Accumulate debug information for emission in finishNativeGen.- let ngs'' = ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs, ngs_labels = [] }+ -- Accumulate debug information for emission in finishNativeGen.+ let ngs'' = ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs, ngs_labels = [] }+ return (us', ngs'') cmmNativeGenStream dflags this_mod modLoc ncgImpl h us' cmm_stream' ngs''++ where ncglabel = text "NCG" -- | Do native code generation on all these cmms. --
compiler/nativeGen/Format.hs view
@@ -10,11 +10,9 @@ -- module Format ( Format(..),- ScalarFormat(..), intFormat, floatFormat, isFloatFormat,- isVecFormat, cmmTypeFormat, formatToWidth, formatInBytes@@ -27,29 +25,6 @@ import Cmm import Outputable ---- Note [GHC's data format representations]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ GHC has severals types that represent various aspects of data format.--- These include:------ * 'CmmType.CmmType': The data classification used throughout the C----- pipeline. This is a pair of a CmmCat and a Width.------ * 'CmmType.CmmCat': What the bits in a C-- value mean (e.g. a pointer, integer, or floating-point value)------ * 'CmmType.Width': The width of a C-- value.------ * 'CmmType.Length': The width (measured in number of scalars) of a vector value.------ * 'Format.Format': The data format representation used by much of the backend.------ * 'Format.ScalarFormat': The format of a 'Format.VecFormat'\'s scalar.------ * 'RegClass.RegClass': Whether a register is an integer, float-point, or vector register---- -- It looks very like the old MachRep, but it's now of purely local -- significance, here in the native code generator. You can change it -- without global consequences.@@ -72,16 +47,8 @@ | II64 | FF32 | FF64- | VecFormat !Length !ScalarFormat !Width deriving (Show, Eq) -data ScalarFormat = FmtInt8- | FmtInt16- | FmtInt32- | FmtInt64- | FmtFloat- | FmtDouble- deriving (Show, Eq) -- | Get the integer format of this width. intFormat :: Width -> Format@@ -114,33 +81,13 @@ FF64 -> True _ -> False --- | Check if a format represents a vector-isVecFormat :: Format -> Bool-isVecFormat (VecFormat {}) = True-isVecFormat _ = False -- | Convert a Cmm type to a Format. cmmTypeFormat :: CmmType -> Format cmmTypeFormat ty | isFloatType ty = floatFormat (typeWidth ty)- | isVecType ty = vecFormat ty | otherwise = intFormat (typeWidth ty) -vecFormat :: CmmType -> Format-vecFormat ty =- let l = vecLength ty- elemTy = vecElemType ty- in if isFloatType elemTy- then case typeWidth elemTy of- W32 -> VecFormat l FmtFloat W32- W64 -> VecFormat l FmtDouble W64- _ -> pprPanic "Incorrect vector element width" (ppr elemTy)- else case typeWidth elemTy of- W8 -> VecFormat l FmtInt8 W8- W16 -> VecFormat l FmtInt16 W16- W32 -> VecFormat l FmtInt32 W32- W64 -> VecFormat l FmtInt64 W64- _ -> pprPanic "Incorrect vector element width" (ppr elemTy) -- | Get the Width of a Format. formatToWidth :: Format -> Width@@ -152,7 +99,7 @@ II64 -> W64 FF32 -> W32 FF64 -> W64- VecFormat l _ w -> widthFromBytes (l*widthInBytes w)+ formatInBytes :: Format -> Int formatInBytes = widthInBytes . formatToWidth
compiler/nativeGen/NCGMonad.hs view
@@ -250,6 +250,7 @@ dflags <- getDynFlags return (RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep) + getNewRegPairNat :: Format -> NatM (Reg,Reg) getNewRegPairNat rep = do u <- getUniqueNat
compiler/nativeGen/PPC/CodeGen.hs view
@@ -1909,8 +1909,6 @@ FF32 -> (1, 1, 4, fprs) FF64 -> (2, 1, 8, fprs) II64 -> panic "genCCall' passArguments II64"- VecFormat {}- -> panic "genCCall' passArguments vector format" GCP32ELF -> case cmmTypeFormat rep of@@ -1921,8 +1919,6 @@ FF32 -> (0, 1, 4, fprs) FF64 -> (0, 1, 8, fprs) II64 -> panic "genCCall' passArguments II64"- VecFormat {}- -> panic "genCCall' passArguments vector format" GCP64ELF _ -> case cmmTypeFormat rep of II8 -> (1, 0, 8, gprs)@@ -1934,8 +1930,6 @@ -- the FPRs. FF32 -> (1, 1, 8, fprs) FF64 -> (1, 1, 8, fprs)- VecFormat {}- -> panic "genCCall' passArguments vector format" moveResult reduceToFF32 = case dest_regs of
compiler/nativeGen/PPC/Ppr.hs view
@@ -29,7 +29,7 @@ import CLabel import PprCmmExpr () -import Unique ( getUnique )+import Unique ( pprUniqueAlways, getUnique ) import GHC.Platform import FastString import Outputable@@ -168,7 +168,10 @@ = case r of RegReal (RealRegSingle i) -> ppr_reg_no i RegReal (RealRegPair{}) -> panic "PPC.pprReg: no reg pairs on this arch"- RegVirtual v -> ppr v+ RegVirtual (VirtualRegI u) -> text "%vI_" <> pprUniqueAlways u+ RegVirtual (VirtualRegHi u) -> text "%vHi_" <> pprUniqueAlways u+ RegVirtual (VirtualRegF u) -> text "%vF_" <> pprUniqueAlways u+ RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUniqueAlways u where ppr_reg_no :: Int -> SDoc@@ -187,8 +190,7 @@ II32 -> sLit "w" II64 -> sLit "d" FF32 -> sLit "fs"- FF64 -> sLit "fd"- VecFormat _ _ _ -> panic "PPC.Ppr.pprFormat: VecFormat")+ FF64 -> sLit "fd") pprCond :: Cond -> SDoc@@ -373,7 +375,6 @@ II64 -> sLit "d" FF32 -> sLit "fs" FF64 -> sLit "fd"- VecFormat _ _ _ -> panic "PPC.Ppr.pprInstr: VecFormat" ), case addr of AddrRegImm _ _ -> empty AddrRegReg _ _ -> char 'x',@@ -413,7 +414,6 @@ II64 -> sLit "d" FF32 -> sLit "fs" FF64 -> sLit "fd"- VecFormat _ _ _ -> panic "PPC.Ppr.pprInstr: VecFormat" ), case addr of AddrRegImm _ _ -> empty AddrRegReg _ _ -> char 'x',
compiler/nativeGen/Reg.hs view
@@ -56,7 +56,6 @@ | VirtualRegHi {-# UNPACK #-} !Unique -- High part of 2-word register | VirtualRegF {-# UNPACK #-} !Unique | VirtualRegD {-# UNPACK #-} !Unique- | VirtualRegVec {-# UNPACK #-} !Unique deriving (Eq, Show) @@ -70,7 +69,6 @@ compare (VirtualRegHi a) (VirtualRegHi b) = nonDetCmpUnique a b compare (VirtualRegF a) (VirtualRegF b) = nonDetCmpUnique a b compare (VirtualRegD a) (VirtualRegD b) = nonDetCmpUnique a b- compare (VirtualRegVec a) (VirtualRegVec b) = nonDetCmpUnique a b compare VirtualRegI{} _ = LT compare _ VirtualRegI{} = GT@@ -78,10 +76,9 @@ compare _ VirtualRegHi{} = GT compare VirtualRegF{} _ = LT compare _ VirtualRegF{} = GT- compare VirtualRegVec{} _ = LT- compare _ VirtualRegVec{} = GT + instance Uniquable VirtualReg where getUnique reg = case reg of@@ -89,7 +86,6 @@ VirtualRegHi u -> u VirtualRegF u -> u VirtualRegD u -> u- VirtualRegVec u -> u instance Outputable VirtualReg where ppr reg@@ -99,9 +95,8 @@ -- this code is kinda wrong on x86 -- because float and double occupy the same register set -- namely SSE2 register xmm0 .. xmm15- VirtualRegF u -> text "%vFloat_" <> pprUniqueAlways u- VirtualRegD u -> text "%vDouble_" <> pprUniqueAlways u- VirtualRegVec u -> text "%vVec_" <> pprUniqueAlways u+ VirtualRegF u -> text "%vFloat_" <> pprUniqueAlways u+ VirtualRegD u -> text "%vDouble_" <> pprUniqueAlways u @@ -112,7 +107,6 @@ VirtualRegHi _ -> VirtualRegHi u VirtualRegF _ -> VirtualRegF u VirtualRegD _ -> VirtualRegD u- VirtualRegVec _ -> VirtualRegVec u classOfVirtualReg :: VirtualReg -> RegClass@@ -122,8 +116,6 @@ VirtualRegHi{} -> RcInteger VirtualRegF{} -> RcFloat VirtualRegD{} -> RcDouble- -- Below is an awful, largely x86-specific hack- VirtualRegVec{} -> RcDouble
compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs view
@@ -195,6 +195,7 @@ + -- Specification Code ---------------------------------------------------------- -- -- The trivColorable function for each particular architecture should
compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs view
@@ -2,7 +2,6 @@ module RegAlloc.Linear.FreeRegs ( FR(..),- allFreeRegs, maxSpillSlots ) @@ -69,10 +68,6 @@ frGetFreeRegs = \_ -> SPARC.getFreeRegs frInitFreeRegs = SPARC.initFreeRegs frReleaseReg = SPARC.releaseReg---- | For debugging output.-allFreeRegs :: FR freeRegs => Platform -> freeRegs -> [RealReg]-allFreeRegs plat fr = foldMap (\rcls -> frGetFreeRegs plat rcls fr) allRegClasses maxSpillSlots :: DynFlags -> Int maxSpillSlots dflags
compiler/nativeGen/RegAlloc/Linear/Main.hs view
@@ -884,10 +884,8 @@ $ vcat [ text "allocating vreg: " <> text (show r) , text "assignment: " <> ppr assig- , text "freeRegs: " <> text (showRegs freeRegs)- , text "initFreeRegs: " <> text (showRegs (frInitFreeRegs platform `asTypeOf` freeRegs))- ]- where showRegs = show . map (\reg -> (reg, targetClassOfRealReg platform reg)) . allFreeRegs platform+ , text "freeRegs: " <> text (show freeRegs)+ , text "initFreeRegs: " <> text (show (frInitFreeRegs platform `asTypeOf` freeRegs)) ] result
compiler/nativeGen/RegClass.hs view
@@ -1,14 +1,15 @@ -- | An architecture independent description of a register's class. module RegClass- ( RegClass(..)- , allRegClasses- ) where+ ( RegClass (..) ) +where+ import GhcPrelude import Outputable import Unique + -- | The class of a register. -- Used in the register allocator. -- We treat all registers in a class as being interchangable.@@ -17,11 +18,7 @@ = RcInteger | RcFloat | RcDouble- deriving (Eq, Show)--allRegClasses :: [RegClass]-allRegClasses =- [ RcInteger, RcFloat, RcDouble ]+ deriving Eq instance Uniquable RegClass where@@ -30,6 +27,6 @@ getUnique RcDouble = mkRegClassUnique 2 instance Outputable RegClass where- ppr RcInteger = Outputable.text "I"- ppr RcFloat = Outputable.text "F"- ppr RcDouble = Outputable.text "D"+ ppr RcInteger = Outputable.text "I"+ ppr RcFloat = Outputable.text "F"+ ppr RcDouble = Outputable.text "D"
compiler/nativeGen/SPARC/Ppr.hs view
@@ -45,6 +45,7 @@ import Hoopl.Label import Hoopl.Collections +import Unique ( pprUniqueAlways ) import Outputable import GHC.Platform import FastString@@ -147,8 +148,13 @@ pprReg reg = case reg of RegVirtual vr- -> ppr vr+ -> case vr of+ VirtualRegI u -> text "%vI_" <> pprUniqueAlways u+ VirtualRegHi u -> text "%vHi_" <> pprUniqueAlways u+ VirtualRegF u -> text "%vF_" <> pprUniqueAlways u+ VirtualRegD u -> text "%vD_" <> pprUniqueAlways u + RegReal rr -> case rr of RealRegSingle r1@@ -215,8 +221,7 @@ II32 -> sLit "" II64 -> sLit "d" FF32 -> sLit ""- FF64 -> sLit "d"- VecFormat _ _ _ -> panic "SPARC.Ppr.pprFormat: VecFormat")+ FF64 -> sLit "d") -- | Pretty print a format for an instruction suffix.@@ -230,8 +235,7 @@ II32 -> sLit "" II64 -> sLit "x" FF32 -> sLit ""- FF64 -> sLit "d"- VecFormat _ _ _ -> panic "SPARC.Ppr.pprFormat: VecFormat")+ FF64 -> sLit "d")
compiler/nativeGen/SPARC/Regs.hs view
@@ -104,6 +104,7 @@ VirtualRegD{} -> 1 _other -> 0 + {-# INLINE realRegSqueeze #-} realRegSqueeze :: RegClass -> RealReg -> Int @@ -132,6 +133,7 @@ | otherwise -> 1 RealRegPair{} -> 1+ -- | All the allocatable registers in the machine, -- including register pairs.
compiler/nativeGen/X86/CodeGen.hs view
@@ -111,26 +111,13 @@ ArchX86 -> return True _ -> panic "trying to generate x86/x86_64 on the wrong platform" -sse4_1Enabled :: NatM Bool-sse4_1Enabled = do- dflags <- getDynFlags- return (isSse4_1Enabled dflags) sse4_2Enabled :: NatM Bool sse4_2Enabled = do dflags <- getDynFlags return (isSse4_2Enabled dflags) -sseEnabled :: NatM Bool-sseEnabled = do- dflags <- getDynFlags- return (isSseEnabled dflags) -avxEnabled :: NatM Bool-avxEnabled = do- dflags <- getDynFlags- return (isAvxEnabled dflags)- cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl (Alignment, CmmStatics) Instr]@@ -228,7 +215,6 @@ CmmAssign reg src | isFloatType ty -> assignReg_FltCode format reg src | is32Bit && isWord64 ty -> assignReg_I64Code reg src- | isVecType ty -> assignReg_VecCode format reg src | otherwise -> assignReg_IntCode format reg src where ty = cmmRegType dflags reg format = cmmTypeFormat ty@@ -236,7 +222,6 @@ CmmStore addr src | isFloatType ty -> assignMem_FltCode format addr src | is32Bit && isWord64 ty -> assignMem_I64Code addr src- | isVecType ty -> assignMem_VecCode format addr src | otherwise -> assignMem_IntCode format addr src where ty = cmmExprType dflags src format = cmmTypeFormat ty@@ -323,15 +308,6 @@ -- platform. Hence ... -getVecRegisterReg :: Platform -> Bool -> Format -> CmmReg -> Reg-getVecRegisterReg _ use_avx format (CmmLocal (LocalReg u pk))- | isVecType pk && use_avx = RegVirtual (mkVirtualReg u format)- | otherwise = pprPanic- (unlines ["avx flag is not enabled" ,- "or this is not a vector register"])- (ppr pk)-getVecRegisterReg platform _use_avx _format c = getRegisterReg platform c- -- | Memory addressing modes passed up the tree. data Amode = Amode AddrMode InstrBlock@@ -527,13 +503,6 @@ ------------------------------------------------------------------------------------ This is a helper data type which helps reduce the code duplication for--- the code generation of arithmetic operations. This is not specifically--- targetted for any particular type like Int8, Int32 etc-data VectorArithInstns = VA_Add | VA_Sub | VA_Mul | VA_Div-- getRegister :: CmmExpr -> NatM Register getRegister e = do dflags <- getDynFlags is32Bit <- is32BitPlatform@@ -551,24 +520,16 @@ do reg' <- getPicBaseNat (archWordFormat is32Bit) return (Fixed (archWordFormat is32Bit) reg' nilOL) _ ->- do use_sse2 <- sse2Enabled- use_avx <- avxEnabled- let cmmregtype = cmmRegType dflags reg- if isVecType cmmregtype- then return (vectorRegister cmmregtype use_avx use_sse2)- else return (standardRegister cmmregtype)- where- vectorRegister :: CmmType -> Bool -> Bool -> Register- vectorRegister reg_ty use_avx use_sse2- | use_avx || use_sse2 =- let vecfmt = cmmTypeFormat reg_ty- platform = targetPlatform dflags- in (Fixed vecfmt (getVecRegisterReg platform True vecfmt reg) nilOL)- | otherwise = panic "Please enable the -mavx or -msse2 flag"+ do+ let+ fmt = cmmTypeFormat (cmmRegType dflags reg)+ format = fmt+ --+ let platform = targetPlatform dflags+ return (Fixed format+ (getRegisterReg platform reg)+ nilOL) - standardRegister crt =- let platform = targetPlatform dflags- in (Fixed (cmmTypeFormat crt) (getRegisterReg platform reg) nilOL) getRegister' dflags is32Bit (CmmRegOff r n) = getRegister' dflags is32Bit $ mangleIndexTree dflags r n@@ -670,69 +631,7 @@ return $ Any II64 (\dst -> unitOL $ LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst)) -getRegister' _ _ (CmmMachOp mop [x, y, z]) = do -- ternary MachOps- sse4_1 <- sse4_1Enabled- sse2 <- sse2Enabled- sse <- sseEnabled- case mop of- MO_VF_Insert l W32 | sse4_1 && sse -> vector_float_pack l W32 x y z- | otherwise- -> sorry "Please enable the -msse4 and -msse flag"- MO_VF_Insert l W64 | sse2 && sse -> vector_float_pack l W64 x y z- | otherwise- -> sorry "Please enable the -msse2 and -msse flag"- _other -> incorrectOperands- where- vector_float_pack :: Length- -> Width- -> CmmExpr- -> CmmExpr- -> CmmExpr- -> NatM Register- vector_float_pack len W32 expr1 expr2 (CmmLit offset)- = do- fn <- getAnyReg expr1- (r, exp) <- getSomeReg expr2- let f = VecFormat len FmtFloat W32- imm = litToImm offset- code dst = exp `appOL`- (fn dst) `snocOL`- (INSERTPS f (OpImm imm) (OpReg r) dst)- in return $ Any f code- vector_float_pack len W64 expr1 expr2 (CmmLit offset)- = do- Amode addr addr_code <- getAmode expr2- (r, exp) <- getSomeReg expr1-- -- fn <- getAnyReg expr1- -- (r, exp) <- getSomeReg expr2- let f = VecFormat len FmtDouble W64- code dst- = case offset of- CmmInt 0 _ -> exp `appOL` addr_code `snocOL`- (MOVL f (OpAddr addr) (OpReg r)) `snocOL`- (MOVU f (OpReg r) (OpReg dst))- CmmInt 16 _ -> exp `appOL` addr_code `snocOL`- (MOVH f (OpAddr addr) (OpReg r)) `snocOL`- (MOVU f (OpReg r) (OpReg dst))- _ -> panic "Error in offset while packing"- -- code dst- -- = case offset of- -- CmmInt 0 _ -> exp `appOL`- -- (fn dst) `snocOL`- -- (MOVL f (OpReg r) (OpReg dst))- -- CmmInt 16 _ -> exp `appOL`- -- (fn dst) `snocOL`- -- (MOVH f (OpReg r) (OpReg dst))- -- _ -> panic "Error in offset while packing"- in return $ Any f code- vector_float_pack _ _ _ c _- = pprPanic "Pack not supported for : " (ppr c)- getRegister' dflags is32Bit (CmmMachOp mop [x]) = do -- unary MachOps- sse2 <- sse2Enabled- sse <- sseEnabled- avx <- avxEnabled case mop of MO_F_Neg w -> sse2NegCode w x @@ -809,28 +708,23 @@ MO_FS_Conv from to -> coerceFP2Int from to x MO_SF_Conv from to -> coerceInt2FP from to x - MO_V_Insert {} -> needLlvm- MO_V_Extract {} -> needLlvm- MO_V_Add {} -> needLlvm- MO_V_Sub {} -> needLlvm- MO_V_Mul {} -> needLlvm- MO_VS_Quot {} -> needLlvm- MO_VS_Rem {} -> needLlvm- MO_VS_Neg {} -> needLlvm- MO_VU_Quot {} -> needLlvm- MO_VU_Rem {} -> needLlvm- MO_VF_Broadcast {} -> incorrectOperands- MO_VF_Insert {} -> incorrectOperands- MO_VF_Extract {} -> incorrectOperands- MO_VF_Add {} -> incorrectOperands- MO_VF_Sub {} -> incorrectOperands- MO_VF_Mul {} -> incorrectOperands- MO_VF_Quot {} -> incorrectOperands-- MO_VF_Neg l w | avx -> vector_float_negate_avx l w x- | sse && sse2 -> vector_float_negate_sse l w x- | otherwise- -> sorry "Please enable the -mavx or -msse, -msse2 flag"+ MO_V_Insert {} -> needLlvm+ MO_V_Extract {} -> needLlvm+ MO_V_Add {} -> needLlvm+ MO_V_Sub {} -> needLlvm+ MO_V_Mul {} -> needLlvm+ MO_VS_Quot {} -> needLlvm+ MO_VS_Rem {} -> needLlvm+ MO_VS_Neg {} -> needLlvm+ MO_VU_Quot {} -> needLlvm+ MO_VU_Rem {} -> needLlvm+ MO_VF_Insert {} -> needLlvm+ MO_VF_Extract {} -> needLlvm+ MO_VF_Add {} -> needLlvm+ MO_VF_Sub {} -> needLlvm+ MO_VF_Mul {} -> needLlvm+ MO_VF_Quot {} -> needLlvm+ MO_VF_Neg {} -> needLlvm _other -> pprPanic "getRegister" (pprMachOp mop) where@@ -868,45 +762,8 @@ = do e_code <- getRegister' dflags is32Bit expr return (swizzleRegisterRep e_code new_format) - vector_float_negate_avx :: Length -> Width -> CmmExpr -> NatM Register- vector_float_negate_avx l w expr = do- tmp <- getNewRegNat (VecFormat l FmtFloat w)- (reg, exp) <- getSomeReg expr- Amode addr addr_code <- memConstant (mkAlignment $ widthInBytes W32) (CmmFloat 0.0 W32)- let format = case w of- W32 -> VecFormat l FmtFloat w- W64 -> VecFormat l FmtDouble w- _ -> pprPanic "Cannot negate vector of width" (ppr w)- code dst = case w of- W32 -> exp `appOL` addr_code `snocOL`- (VBROADCAST format addr tmp) `snocOL`- (VSUB format (OpReg reg) tmp dst)- W64 -> exp `appOL` addr_code `snocOL`- (MOVL format (OpAddr addr) (OpReg tmp)) `snocOL`- (MOVH format (OpAddr addr) (OpReg tmp)) `snocOL`- (VSUB format (OpReg reg) tmp dst)- _ -> pprPanic "Cannot negate vector of width" (ppr w)- return (Any format code) - vector_float_negate_sse :: Length -> Width -> CmmExpr -> NatM Register- vector_float_negate_sse l w expr = do- tmp <- getNewRegNat (VecFormat l FmtFloat w)- (reg, exp) <- getSomeReg expr- let format = case w of- W32 -> VecFormat l FmtFloat w- W64 -> VecFormat l FmtDouble w- _ -> pprPanic "Cannot negate vector of width" (ppr w)- code dst = exp `snocOL`- (XOR format (OpReg tmp) (OpReg tmp)) `snocOL`- (MOVU format (OpReg tmp) (OpReg dst)) `snocOL`- (SUB format (OpReg reg) (OpReg dst))- return (Any format code)- getRegister' _ is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps- sse4_1 <- sse4_1Enabled- sse2 <- sse2Enabled- sse <- sseEnabled- avx <- avxEnabled case mop of MO_F_Eq _ -> condFltReg is32Bit EQQ x y MO_F_Ne _ -> condFltReg is32Bit NE x y@@ -971,49 +828,13 @@ MO_VS_Quot {} -> needLlvm MO_VS_Rem {} -> needLlvm MO_VS_Neg {} -> needLlvm-- MO_VF_Broadcast l W32 | avx -> vector_float_broadcast_avx l W32 x y- | sse4_1 -> vector_float_broadcast_sse l W32 x y- | otherwise- -> sorry "Please enable the -mavx or -msse4 flag"-- MO_VF_Broadcast l W64 | sse2 -> vector_float_broadcast_avx l W64 x y- | otherwise -> sorry "Please enable the -msse2 flag"-- MO_VF_Extract l W32 | avx -> vector_float_unpack l W32 x y- | sse -> vector_float_unpack_sse l W32 x y- | otherwise- -> sorry "Please enable the -mavx or -msse flag"-- MO_VF_Extract l W64 | sse2 -> vector_float_unpack l W64 x y- | otherwise -> sorry "Please enable the -msse2 flag"-- MO_VF_Add l w | avx -> vector_float_op_avx VA_Add l w x y- | sse && w == W32 -> vector_float_op_sse VA_Add l w x y- | sse2 && w == W64 -> vector_float_op_sse VA_Add l w x y- | otherwise- -> sorry "Please enable the -mavx or -msse flag"-- MO_VF_Sub l w | avx -> vector_float_op_avx VA_Sub l w x y- | sse && w == W32 -> vector_float_op_sse VA_Sub l w x y- | sse2 && w == W64 -> vector_float_op_sse VA_Sub l w x y- | otherwise- -> sorry "Please enable the -mavx or -msse flag"-- MO_VF_Mul l w | avx -> vector_float_op_avx VA_Mul l w x y- | sse && w == W32 -> vector_float_op_sse VA_Mul l w x y- | sse2 && w == W64 -> vector_float_op_sse VA_Mul l w x y- | otherwise- -> sorry "Please enable the -mavx or -msse flag"-- MO_VF_Quot l w | avx -> vector_float_op_avx VA_Div l w x y- | sse && w == W32 -> vector_float_op_sse VA_Div l w x y- | sse2 && w == W64 -> vector_float_op_sse VA_Div l w x y- | otherwise- -> sorry "Please enable the -mavx or -msse flag"-- MO_VF_Insert {} -> incorrectOperands- MO_VF_Neg {} -> incorrectOperands+ MO_VF_Insert {} -> needLlvm+ MO_VF_Extract {} -> needLlvm+ MO_VF_Add {} -> needLlvm+ MO_VF_Sub {} -> needLlvm+ MO_VF_Mul {} -> needLlvm+ MO_VF_Quot {} -> needLlvm+ MO_VF_Neg {} -> needLlvm _other -> pprPanic "getRegister(x86) - binary CmmMachOp (1)" (pprMachOp mop) where@@ -1109,171 +930,7 @@ -- TODO: There are other interesting patterns we want to replace -- with a LEA, e.g. `(x + offset) + (y << shift)`. - ------------------------ -- Vector operations---- vector_float_op_avx :: VectorArithInstns- -> Length- -> Width- -> CmmExpr- -> CmmExpr- -> NatM Register- vector_float_op_avx op l w expr1 expr2 = do- (reg1, exp1) <- getSomeReg expr1- (reg2, exp2) <- getSomeReg expr2- let format = case w of- W32 -> VecFormat l FmtFloat W32- W64 -> VecFormat l FmtDouble W64- _ -> pprPanic "Operation not supported for width " (ppr w)- code dst = case op of- VA_Add -> arithInstr VADD- VA_Sub -> arithInstr VSUB- VA_Mul -> arithInstr VMUL- VA_Div -> arithInstr VDIV- where- -- opcode src2 src1 dst <==> dst = src1 `opcode` src2- arithInstr instr = exp1 `appOL` exp2 `snocOL`- (instr format (OpReg reg2) reg1 dst)- return (Any format code)-- vector_float_op_sse :: VectorArithInstns- -> Length- -> Width- -> CmmExpr- -> CmmExpr- -> NatM Register- vector_float_op_sse op l w expr1 expr2 = do- (reg1, exp1) <- getSomeReg expr1- (reg2, exp2) <- getSomeReg expr2- let format = case w of- W32 -> VecFormat l FmtFloat W32- W64 -> VecFormat l FmtDouble W64- _ -> pprPanic "Operation not supported for width " (ppr w)- code dst = case op of- VA_Add -> arithInstr ADD- VA_Sub -> arithInstr SUB- VA_Mul -> arithInstr MUL- VA_Div -> arithInstr FDIV- where- -- opcode src2 src1 <==> src1 = src1 `opcode` src2- arithInstr instr- = exp1 `appOL` exp2 `snocOL`- (MOVU format (OpReg reg1) (OpReg dst)) `snocOL`- (instr format (OpReg reg2) (OpReg dst))- return (Any format code) --------------------- vector_float_unpack :: Length- -> Width- -> CmmExpr- -> CmmExpr- -> NatM Register- vector_float_unpack l W32 expr (CmmLit lit)- = do- (r, exp) <- getSomeReg expr- let format = VecFormat l FmtFloat W32- imm = litToImm lit- code dst- = case lit of- CmmInt 0 _ -> exp `snocOL` (VMOVU format (OpReg r) (OpReg dst))- CmmInt _ _ -> exp `snocOL` (VPSHUFD format (OpImm imm) (OpReg r) dst)- _ -> panic "Error in offset while unpacking"- return (Any format code)- vector_float_unpack l W64 expr (CmmLit lit)- = do- dflags <- getDynFlags- (r, exp) <- getSomeReg expr- let format = VecFormat l FmtDouble W64- addr = spRel dflags 0- code dst- = case lit of- CmmInt 0 _ -> exp `snocOL`- (MOVL format (OpReg r) (OpAddr addr)) `snocOL`- (MOV FF64 (OpAddr addr) (OpReg dst))- CmmInt 1 _ -> exp `snocOL`- (MOVH format (OpReg r) (OpAddr addr)) `snocOL`- (MOV FF64 (OpAddr addr) (OpReg dst))- _ -> panic "Error in offset while unpacking"- return (Any format code)- vector_float_unpack _ w c e- = pprPanic "Unpack not supported for : " (ppr c $$ ppr e $$ ppr w)- ------------------------- vector_float_unpack_sse :: Length- -> Width- -> CmmExpr- -> CmmExpr- -> NatM Register- vector_float_unpack_sse l W32 expr (CmmLit lit)- = do- (r,exp) <- getSomeReg expr- let format = VecFormat l FmtFloat W32- imm = litToImm lit- code dst- = case lit of- CmmInt 0 _ -> exp `snocOL` (MOVU format (OpReg r) (OpReg dst))- CmmInt _ _ -> exp `snocOL` (PSHUFD format (OpImm imm) (OpReg r) dst)- _ -> panic "Error in offset while unpacking"- return (Any format code)- vector_float_unpack_sse _ w c e- = pprPanic "Unpack not supported for : " (ppr c $$ ppr e $$ ppr w)- ------------------------ vector_float_broadcast_avx :: Length- -> Width- -> CmmExpr- -> CmmExpr- -> NatM Register- vector_float_broadcast_avx len W32 expr1 expr2- = do- dflags <- getDynFlags- fn <- getAnyReg expr1- (r', exp) <- getSomeReg expr2- let f = VecFormat len FmtFloat W32- addr = spRel dflags 0- in return $ Any f (\r -> exp `appOL`- (fn r) `snocOL`- (MOVU f (OpReg r') (OpAddr addr)) `snocOL`- (VBROADCAST f addr r))- vector_float_broadcast_avx len W64 expr1 expr2- = do- dflags <- getDynFlags- fn <- getAnyReg expr1- (r', exp) <- getSomeReg expr2- let f = VecFormat len FmtDouble W64- addr = spRel dflags 0- in return $ Any f (\r -> exp `appOL`- (fn r) `snocOL`- (MOVU f (OpReg r') (OpAddr addr)) `snocOL`- (MOVL f (OpAddr addr) (OpReg r)) `snocOL`- (MOVH f (OpAddr addr) (OpReg r)))- vector_float_broadcast_avx _ _ c _- = pprPanic "Broadcast not supported for : " (ppr c)- ------------------------ vector_float_broadcast_sse :: Length- -> Width- -> CmmExpr- -> CmmExpr- -> NatM Register- vector_float_broadcast_sse len W32 expr1 expr2- = do- dflags <- getDynFlags- fn <- getAnyReg expr1 -- destination- (r, exp) <- getSomeReg expr2 -- source- let f = VecFormat len FmtFloat W32- addr = spRel dflags 0- code dst = exp `appOL`- (fn dst) `snocOL`- (MOVU f (OpReg r) (OpAddr addr)) `snocOL`- (insertps 0) `snocOL`- (insertps 16) `snocOL`- (insertps 32) `snocOL`- (insertps 48)- where- insertps off =- INSERTPS f (OpImm $ litToImm $ CmmInt off W32) (OpAddr addr) dst-- in return $ Any f code- vector_float_broadcast_sse _ _ c _- = pprPanic "Broadcast not supported for : " (ppr c)- ----------------------- sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register sub_code rep x (CmmLit (CmmInt y _)) | is32BitInteger (-y) = add_int rep x (-y)@@ -1326,21 +983,6 @@ return (Fixed format result code) -getRegister' _ _ (CmmLoad mem pk)- | isVecType pk = do- use_avx <- avxEnabled- use_sse <- sseEnabled- Amode addr mem_code <- getAmode mem- let format = cmmTypeFormat pk- code dst- | use_avx = mem_code `snocOL`- VMOVU format (OpAddr addr) (OpReg dst)- | use_sse = mem_code `snocOL`- MOVU format (OpAddr addr) (OpReg dst)- | otherwise = pprPanic (unlines ["avx or sse flag not enabled",- "for loading to "])- (ppr pk)- return (Any format code) getRegister' _ _ (CmmLoad mem pk) | isFloatType pk@@ -1407,24 +1049,10 @@ -- small memory model (see gcc docs, -mcmodel=small). getRegister' dflags _ (CmmLit lit)- | isVecType cmmtype = vectorRegister cmmtype- | otherwise = standardRegister cmmtype- where- cmmtype = cmmLitType dflags lit- vectorRegister ctype- = do- --NOTE:- -- This operation is only used to zero a register. For loading a- -- vector literal there are pack and broadcast operations- let format = cmmTypeFormat ctype- code dst = unitOL (XOR format (OpReg dst) (OpReg dst))- return (Any format code)- standardRegister ctype- = do- let format = cmmTypeFormat ctype- imm = litToImm lit- code dst = unitOL (MOV format (OpImm imm) (OpReg dst))- return (Any format code)+ = do let format = cmmTypeFormat (cmmLitType dflags lit)+ imm = litToImm lit+ code dst = unitOL (MOV format (OpImm imm) (OpReg dst))+ return (Any format code) getRegister' _ _ other | isVecExpr other = needLlvm@@ -1490,15 +1118,9 @@ return (reg, code) reg2reg :: Format -> Reg -> Reg -> Instr-reg2reg format@(VecFormat _ FmtFloat W32) src dst- = VMOVU format (OpReg src) (OpReg dst)-reg2reg format@(VecFormat _ FmtDouble W64) src dst- = VMOVU format (OpReg src) (OpReg dst)-reg2reg (VecFormat _ _ _) _ _- = panic "MOV operation not implemented for vectors"-reg2reg format src dst- = MOV format (OpReg src) (OpReg dst)+reg2reg format src dst = MOV format (OpReg src) (OpReg dst) + -------------------------------------------------------------------------------- getAmode :: CmmExpr -> NatM Amode getAmode e = do is32Bit <- is32BitPlatform@@ -1559,9 +1181,6 @@ getAmode' _ (CmmMachOp (MO_Add _) [x,y]) = x86_complex_amode x y 0 0 -getAmode' _ (CmmLit lit@(CmmFloat _ w))- = memConstant (mkAlignment $ widthInBytes w) lit- getAmode' is32Bit (CmmLit lit) | is32BitLit is32Bit lit = return (Amode (ImmAddr (litToImm lit) 0) nilOL) @@ -1942,8 +1561,7 @@ assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock -assignMem_VecCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock-assignReg_VecCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock+ -- integer assignment to memory -- specific case of adding/subtracting an integer to a particular address.@@ -2020,30 +1638,7 @@ let platform = targetPlatform dflags return (src_code (getRegisterReg platform reg)) -assignMem_VecCode pk addr src = do- (src_reg, src_code) <- getNonClobberedReg src- Amode addr addr_code <- getAmode addr- use_avx <- avxEnabled- use_sse <- sseEnabled- let- code | use_avx = src_code `appOL`- addr_code `snocOL`- (VMOVU pk (OpReg src_reg) (OpAddr addr))- | use_sse = src_code `appOL`- addr_code `snocOL`- (MOVU pk (OpReg src_reg) (OpAddr addr))- | otherwise = sorry "Please enable the -mavx or -msse flag"- return code -assignReg_VecCode format reg src = do- use_avx <- avxEnabled- use_sse <- sseEnabled- src_code <- getAnyReg src- dflags <- getDynFlags- let platform = targetPlatform dflags- flag = use_avx || use_sse- return (src_code (getVecRegisterReg platform flag format reg))- genJump :: CmmExpr{-the branch target-} -> [Reg] -> NatM InstrBlock genJump (CmmLoad mem _) regs = do@@ -3767,7 +3362,6 @@ x@II16 -> wrongFmt x x@II32 -> wrongFmt x x@II64 -> wrongFmt x- x@VecFormat {} -> wrongFmt x where wrongFmt x = panic $ "sse2NegCode: " ++ show x@@ -3782,32 +3376,28 @@ return (Any fmt code) isVecExpr :: CmmExpr -> Bool-isVecExpr (CmmMachOp (MO_V_Insert {}) _) = True-isVecExpr (CmmMachOp (MO_V_Extract {}) _) = True-isVecExpr (CmmMachOp (MO_V_Add {}) _) = True-isVecExpr (CmmMachOp (MO_V_Sub {}) _) = True-isVecExpr (CmmMachOp (MO_V_Mul {}) _) = True-isVecExpr (CmmMachOp (MO_VS_Quot {}) _) = True-isVecExpr (CmmMachOp (MO_VS_Rem {}) _) = True-isVecExpr (CmmMachOp (MO_VS_Neg {}) _) = True-isVecExpr (CmmMachOp (MO_VF_Broadcast {}) _) = True-isVecExpr (CmmMachOp (MO_VF_Insert {}) _) = True-isVecExpr (CmmMachOp (MO_VF_Extract {}) _) = True-isVecExpr (CmmMachOp (MO_VF_Add {}) _) = True-isVecExpr (CmmMachOp (MO_VF_Sub {}) _) = True-isVecExpr (CmmMachOp (MO_VF_Mul {}) _) = True-isVecExpr (CmmMachOp (MO_VF_Quot {}) _) = True-isVecExpr (CmmMachOp (MO_VF_Neg {}) _) = True-isVecExpr (CmmMachOp _ [e]) = isVecExpr e-isVecExpr _ = False+isVecExpr (CmmMachOp (MO_V_Insert {}) _) = True+isVecExpr (CmmMachOp (MO_V_Extract {}) _) = True+isVecExpr (CmmMachOp (MO_V_Add {}) _) = True+isVecExpr (CmmMachOp (MO_V_Sub {}) _) = True+isVecExpr (CmmMachOp (MO_V_Mul {}) _) = True+isVecExpr (CmmMachOp (MO_VS_Quot {}) _) = True+isVecExpr (CmmMachOp (MO_VS_Rem {}) _) = True+isVecExpr (CmmMachOp (MO_VS_Neg {}) _) = True+isVecExpr (CmmMachOp (MO_VF_Insert {}) _) = True+isVecExpr (CmmMachOp (MO_VF_Extract {}) _) = True+isVecExpr (CmmMachOp (MO_VF_Add {}) _) = True+isVecExpr (CmmMachOp (MO_VF_Sub {}) _) = True+isVecExpr (CmmMachOp (MO_VF_Mul {}) _) = True+isVecExpr (CmmMachOp (MO_VF_Quot {}) _) = True+isVecExpr (CmmMachOp (MO_VF_Neg {}) _) = True+isVecExpr (CmmMachOp _ [e]) = isVecExpr e+isVecExpr _ = False needLlvm :: NatM a needLlvm = sorry $ unlines ["The native code generator does not support vector" ,"instructions. Please use -fllvm."]--incorrectOperands :: NatM a-incorrectOperands = sorry "Incorrect number of operands" -- | This works on the invariant that all jumps in the given blocks are required. -- Starting from there we try to make a few more jumps redundant by reordering
compiler/nativeGen/X86/Instr.hs view
@@ -328,36 +328,6 @@ | CMPXCHG Format Operand Operand -- src (r), dst (r/m), eax implicit | MFENCE - -- Vector Instructions --- -- NOTE: Instructions follow the AT&T syntax- -- Constructors and deconstructors- | VBROADCAST Format AddrMode Reg- | VEXTRACT Format Operand Reg Operand- | INSERTPS Format Operand Operand Reg-- -- move operations- | VMOVU Format Operand Operand- | MOVU Format Operand Operand- | MOVL Format Operand Operand- | MOVH Format Operand Operand-- -- logic operations- | VPXOR Format Reg Reg Reg-- -- Arithmetic- | VADD Format Operand Reg Reg- | VSUB Format Operand Reg Reg- | VMUL Format Operand Reg Reg- | VDIV Format Operand Reg Reg-- -- Shuffle- | VPSHUFD Format Operand Operand Reg- | PSHUFD Format Operand Operand Reg-- -- Shift- | PSLLDQ Format Operand Reg- | PSRLDQ Format Operand Reg- data PrefetchVariant = NTA | Lvl0 | Lvl1 | Lvl2 @@ -460,31 +430,6 @@ CMPXCHG _ src dst -> usageRMM src dst (OpReg eax) MFENCE -> noUsage - -- vector instructions- VBROADCAST _ src dst -> mkRU (use_EA src []) [dst]- VEXTRACT _ off src dst -> mkRU ((use_R off []) ++ [src]) (use_R dst [])- INSERTPS _ off src dst- -> mkRU ((use_R off []) ++ (use_R src []) ++ [dst]) [dst]-- VMOVU _ src dst -> mkRU (use_R src []) (use_R dst [])- MOVU _ src dst -> mkRU (use_R src []) (use_R dst [])- MOVL _ src dst -> mkRU (use_R src []) (use_R dst [])- MOVH _ src dst -> mkRU (use_R src []) (use_R dst [])- VPXOR _ s1 s2 dst -> mkRU [s1,s2] [dst]-- VADD _ s1 s2 dst -> mkRU ((use_R s1 []) ++ [s2]) [dst]- VSUB _ s1 s2 dst -> mkRU ((use_R s1 []) ++ [s2]) [dst]- VMUL _ s1 s2 dst -> mkRU ((use_R s1 []) ++ [s2]) [dst]- VDIV _ s1 s2 dst -> mkRU ((use_R s1 []) ++ [s2]) [dst]-- VPSHUFD _ off src dst- -> mkRU (concatMap (\op -> use_R op []) [off, src]) [dst]- PSHUFD _ off src dst- -> mkRU (concatMap (\op -> use_R op []) [off, src]) [dst]-- PSLLDQ _ off dst -> mkRU (use_R off []) [dst]- PSRLDQ _ off dst -> mkRU (use_R off []) [dst]- _other -> panic "regUsage: unrecognised instr" where -- # Definitions@@ -643,32 +588,6 @@ CMPXCHG fmt src dst -> patch2 (CMPXCHG fmt) src dst MFENCE -> instr - -- vector instructions- VBROADCAST fmt src dst -> VBROADCAST fmt (lookupAddr src) (env dst)- VEXTRACT fmt off src dst- -> VEXTRACT fmt (patchOp off) (env src) (patchOp dst)- INSERTPS fmt off src dst- -> INSERTPS fmt (patchOp off) (patchOp src) (env dst)-- VMOVU fmt src dst -> VMOVU fmt (patchOp src) (patchOp dst)- MOVU fmt src dst -> MOVU fmt (patchOp src) (patchOp dst)- MOVL fmt src dst -> MOVL fmt (patchOp src) (patchOp dst)- MOVH fmt src dst -> MOVH fmt (patchOp src) (patchOp dst)- VPXOR fmt s1 s2 dst -> VPXOR fmt (env s1) (env s2) (env dst)-- VADD fmt s1 s2 dst -> VADD fmt (patchOp s1) (env s2) (env dst)- VSUB fmt s1 s2 dst -> VSUB fmt (patchOp s1) (env s2) (env dst)- VMUL fmt s1 s2 dst -> VMUL fmt (patchOp s1) (env s2) (env dst)- VDIV fmt s1 s2 dst -> VDIV fmt (patchOp s1) (env s2) (env dst)-- VPSHUFD fmt off src dst- -> VPSHUFD fmt (patchOp off) (patchOp src) (env dst)- PSHUFD fmt off src dst- -> PSHUFD fmt (patchOp off) (patchOp src) (env dst)- PSLLDQ fmt off dst- -> PSLLDQ fmt (patchOp off) (env dst)- PSRLDQ fmt off dst- -> PSRLDQ fmt (patchOp off) (env dst) _other -> panic "patchRegs: unrecognised instr" where
compiler/nativeGen/X86/Ppr.hs view
@@ -41,6 +41,7 @@ import Cmm hiding (topInfoTable) import BlockId import CLabel+import Unique ( pprUniqueAlways ) import GHC.Platform import FastString import Outputable@@ -279,7 +280,10 @@ if target32Bit platform then ppr32_reg_no f i else ppr64_reg_no f i RegReal (RealRegPair _ _) -> panic "X86.Ppr: no reg pairs on this arch"- RegVirtual v -> ppr v+ RegVirtual (VirtualRegI u) -> text "%vI_" <> pprUniqueAlways u+ RegVirtual (VirtualRegHi u) -> text "%vHi_" <> pprUniqueAlways u+ RegVirtual (VirtualRegF u) -> text "%vF_" <> pprUniqueAlways u+ RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUniqueAlways u where ppr32_reg_no :: Format -> Int -> SDoc@@ -391,11 +395,6 @@ II64 -> sLit "q" FF32 -> sLit "ss" -- "scalar single-precision float" (SSE2) FF64 -> sLit "sd" -- "scalar double-precision float" (SSE2)-- VecFormat _ FmtFloat W32 -> sLit "ps"- VecFormat _ FmtDouble W64 -> sLit "pd"- -- TODO: Add Ints and remove panic- VecFormat {} -> panic "Incorrect width" ) pprFormat_x87 :: Format -> SDoc@@ -784,41 +783,6 @@ pprInstr (DIV fmt op) = pprFormatOp (sLit "div") fmt op pprInstr (IMUL2 fmt op) = pprFormatOp (sLit "imul") fmt op --- Vector Instructions--pprInstr (VADD format s1 s2 dst)- = pprFormatOpRegReg (sLit "vadd") format s1 s2 dst-pprInstr (VSUB format s1 s2 dst)- = pprFormatOpRegReg (sLit "vsub") format s1 s2 dst-pprInstr (VMUL format s1 s2 dst)- = pprFormatOpRegReg (sLit "vmul") format s1 s2 dst-pprInstr (VDIV format s1 s2 dst)- = pprFormatOpRegReg (sLit "vdiv") format s1 s2 dst-pprInstr (VBROADCAST format from to)- = pprBroadcast (sLit "vbroadcast") format from to-pprInstr (VMOVU format from to)- = pprFormatOpOp (sLit "vmovu") format from to-pprInstr (MOVU format from to)- = pprFormatOpOp (sLit "movu") format from to-pprInstr (MOVL format from to)- = pprFormatOpOp (sLit "movl") format from to-pprInstr (MOVH format from to)- = pprFormatOpOp (sLit "movh") format from to-pprInstr (VPXOR format s1 s2 dst)- = pprXor (sLit "vpxor") format s1 s2 dst-pprInstr (VEXTRACT format offset from to)- = pprFormatOpRegOp (sLit "vextract") format offset from to-pprInstr (INSERTPS format offset addr dst)- = pprInsert (sLit "insertps") format offset addr dst-pprInstr (VPSHUFD format offset src dst)- = pprShuf (sLit "vpshufd") format offset src dst-pprInstr (PSHUFD format offset src dst)- = pprShuf (sLit "pshufd") format offset src dst-pprInstr (PSLLDQ format offset dst)- = pprShiftLeft (sLit "pslldq") format offset dst-pprInstr (PSRLDQ format offset dst)- = pprShiftRight (sLit "psrldq") format offset dst- -- x86_64 only pprInstr (MUL format op1 op2) = pprFormatOpOp (sLit "mul") format op1 op2 pprInstr (MUL2 format op) = pprFormatOp (sLit "mul") format op@@ -911,24 +875,7 @@ pprMnemonic name format = char '\t' <> ptext name <> pprFormat format <> space -pprGenMnemonic :: PtrString -> Format -> SDoc-pprGenMnemonic name _ =- char '\t' <> ptext name <> ptext (sLit "") <> space -pprBroadcastMnemonic :: PtrString -> Format -> SDoc-pprBroadcastMnemonic name format =- char '\t' <> ptext name <> pprBroadcastFormat format <> space--pprBroadcastFormat :: Format -> SDoc-pprBroadcastFormat x- = ptext (case x of- VecFormat _ FmtFloat W32 -> sLit "ss"- VecFormat _ FmtDouble W64 -> sLit "sd"- -- TODO: Add Ints and remove panic- VecFormat {} -> panic "Incorrect width"- _ -> panic "Scalar Format invading vector operation"- )- pprFormatImmOp :: PtrString -> Format -> Imm -> Operand -> SDoc pprFormatImmOp name format imm op1 = hcat [@@ -974,17 +921,8 @@ pprOperand format op2 ] -pprFormatOpRegOp :: PtrString -> Format -> Operand -> Reg -> Operand -> SDoc-pprFormatOpRegOp name format off reg1 op2- = hcat [- pprMnemonic name format,- pprOperand format off,- comma,- pprReg format reg1,- comma,- pprOperand format op2- ] + pprRegReg :: PtrString -> Reg -> Reg -> SDoc pprRegReg name reg1 reg2 = sdocWithPlatform $ \platform ->@@ -1006,17 +944,6 @@ pprReg (archWordFormat (target32Bit platform)) reg2 ] -pprFormatOpRegReg :: PtrString -> Format -> Operand -> Reg -> Reg -> SDoc-pprFormatOpRegReg name format op1 reg2 reg3- = hcat [- pprMnemonic name format,- pprOperand format op1,- comma,- pprReg format reg2,- comma,- pprReg format reg3- ]- pprCondOpReg :: PtrString -> Format -> Cond -> Operand -> Reg -> SDoc pprCondOpReg name format cond op1 reg2 = hcat [@@ -1081,68 +1008,3 @@ pprCondInstr :: PtrString -> Cond -> SDoc -> SDoc pprCondInstr name cond arg = hcat [ char '\t', ptext name, pprCond cond, space, arg]----- Custom pretty printers--- These instructions currently don't follow a uniform suffix pattern--- in their names, so we have custom pretty printers for them.--pprBroadcast :: PtrString -> Format -> AddrMode -> Reg -> SDoc-pprBroadcast name format op dst- = hcat [- pprBroadcastMnemonic name format,- pprAddr op,- comma,- pprReg format dst- ]--pprXor :: PtrString -> Format -> Reg -> Reg -> Reg -> SDoc-pprXor name format reg1 reg2 reg3- = hcat [- pprGenMnemonic name format,- pprReg format reg1,- comma,- pprReg format reg2,- comma,- pprReg format reg3- ]--pprInsert :: PtrString -> Format -> Operand -> Operand -> Reg -> SDoc-pprInsert name format off src dst- = hcat [- pprGenMnemonic name format,- pprOperand format off,- comma,- pprOperand format src,- comma,- pprReg format dst- ]--pprShuf :: PtrString -> Format -> Operand -> Operand -> Reg -> SDoc-pprShuf name format op1 op2 reg3- = hcat [- pprGenMnemonic name format,- pprOperand format op1,- comma,- pprOperand format op2,- comma,- pprReg format reg3- ]--pprShiftLeft :: PtrString -> Format -> Operand -> Reg -> SDoc-pprShiftLeft name format off reg- = hcat [- pprGenMnemonic name format,- pprOperand format off,- comma,- pprReg format reg- ]--pprShiftRight :: PtrString -> Format -> Operand -> Reg -> SDoc-pprShiftRight name format off reg- = hcat [- pprGenMnemonic name format,- pprOperand format off,- comma,- pprReg format reg- ]
compiler/nativeGen/X86/RegInfo.hs view
@@ -22,8 +22,6 @@ import X86.Regs ---TODO:--- Add VirtualRegAVX and inspect VecFormat and allocate mkVirtualReg :: Unique -> Format -> VirtualReg mkVirtualReg u format = case format of@@ -33,7 +31,6 @@ -- For now we map both to being allocated as "Double" Registers -- on X86/X86_64 FF64 -> VirtualRegD u- VecFormat {} -> VirtualRegVec u _other -> VirtualRegI u regDotColor :: Platform -> RealReg -> SDoc
compiler/nativeGen/X86/Regs.hs view
@@ -84,7 +84,6 @@ -> case vr of VirtualRegD{} -> 1 VirtualRegF{} -> 0- VirtualRegVec{} -> 1 _other -> 0
compiler/rename/RnBinds.hs view
@@ -56,6 +56,7 @@ import Outputable import UniqSet import Maybes ( orElse )+import OrdList import qualified GHC.LanguageExtensions as LangExt import Control.Monad@@ -215,19 +216,19 @@ (thing, fvs_thing) <- thing_inside (HsIPBinds x binds') fv_binds return (thing, fvs_thing `plusFV` fv_binds) -rnLocalBindsAndThen (XHsLocalBindsLR _) _ = panic "rnLocalBindsAndThen"+rnLocalBindsAndThen (XHsLocalBindsLR nec) _ = noExtCon nec rnIPBinds :: HsIPBinds GhcPs -> RnM (HsIPBinds GhcRn, FreeVars) rnIPBinds (IPBinds _ ip_binds ) = do (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds- return (IPBinds noExt ip_binds', plusFVs fvs_s)-rnIPBinds (XHsIPBinds _) = panic "rnIPBinds"+ return (IPBinds noExtField ip_binds', plusFVs fvs_s)+rnIPBinds (XHsIPBinds nec) = noExtCon nec rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, FreeVars) rnIPBind (IPBind _ ~(Left n) expr) = do (expr',fvExpr) <- rnLExpr expr- return (IPBind noExt (Left n) expr', fvExpr)-rnIPBind (XIPBind _) = panic "rnIPBind"+ return (IPBind noExtField (Left n) expr', fvExpr)+rnIPBind (XIPBind nec) = noExtCon nec {- ************************************************************************@@ -422,19 +423,19 @@ rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name }) = do { name <- applyNameMaker name_maker rdr_name ; return (bind { fun_id = name- , fun_ext = noExt }) }+ , fun_ext = noExtField }) } rnBindLHS name_maker _ (PatSynBind x psb@PSB{ psb_id = rdrname }) | isTopRecNameMaker name_maker = do { addLocM checkConName rdrname ; name <- lookupLocatedTopBndrRn rdrname -- Should be in scope already- ; return (PatSynBind x psb{ psb_ext = noExt, psb_id = name }) }+ ; return (PatSynBind x psb{ psb_ext = noExtField, psb_id = name }) } | otherwise -- Pattern synonym, not at top level = do { addErr localPatternSynonymErr -- Complain, but make up a fake -- name so that we can carry on ; name <- applyNameMaker name_maker rdrname- ; return (PatSynBind x psb{ psb_ext = noExt, psb_id = name }) }+ ; return (PatSynBind x psb{ psb_ext = noExtField, psb_id = name }) } where localPatternSynonymErr :: SDoc localPatternSynonymErr@@ -568,7 +569,7 @@ -- Dependency analysis; this is important so that -- unused-binding reporting is accurate depAnalBinds binds_w_dus- = (map get_binds sccs, map get_du sccs)+ = (map get_binds sccs, toOL $ map get_du sccs) where sccs = depAnal (\(_, defs, _) -> defs) (\(_, _, uses) -> nonDetEltsUniqSet uses)@@ -629,7 +630,7 @@ add_one_sig env (L loc (FixitySig _ names fixity)) = foldlM add_one env [ (loc,name_loc,name,fixity) | L name_loc name <- names ]- add_one_sig _ (L _ (XFixitySig _)) = panic "makeMiniFixityEnv"+ add_one_sig _ (L _ (XFixitySig nec)) = noExtCon nec add_one env (loc, name_loc, name,fixity) = do { -- this fixity decl is a duplicate iff@@ -740,7 +741,7 @@ = hang (text "Illegal pattern synonym declaration") 2 (text "Use -XPatternSynonyms to enable this extension") -rnPatSynBind _ (XPatSynBind _) = panic "rnPatSynBind"+rnPatSynBind _ (XPatSynBind nec) = noExtCon nec {- Note [Renaming pattern synonym variables]@@ -895,7 +896,7 @@ = setSrcSpan loc $ do do { sel_name <- wrapLocM (lookupInstDeclBndr cls (text "method")) name -- We use the selector name as the binder- ; let bind' = bind { fun_id = sel_name, fun_ext = noExt }+ ; let bind' = bind { fun_id = sel_name, fun_ext = noExtField } ; return (L loc bind' `consBag` rest ) } -- Report error for all other forms of bindings@@ -959,13 +960,13 @@ renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, FreeVars) renameSig _ (IdSig _ x)- = return (IdSig noExt x, emptyFVs) -- Actually this never occurs+ = return (IdSig noExtField x, emptyFVs) -- Actually this never occurs renameSig ctxt sig@(TypeSig _ vs ty) = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs ; let doc = TypeSigCtx (ppr_sig_bndrs vs) ; (new_ty, fvs) <- rnHsSigWcType BindUnlessForall doc ty- ; return (TypeSig noExt new_vs new_ty, fvs) }+ ; return (TypeSig noExtField new_vs new_ty, fvs) } renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty) = do { defaultSigs_on <- xoptM LangExt.DefaultSignatures@@ -973,7 +974,7 @@ addErr (defaultSigErr sig) ; new_v <- mapM (lookupSigOccRn ctxt sig) vs ; (new_ty, fvs) <- rnHsSigType ty_ctxt ty- ; return (ClassOpSig noExt is_deflt new_v new_ty, fvs) }+ ; return (ClassOpSig noExtField is_deflt new_v new_ty, fvs) } where (v1:_) = vs ty_ctxt = GenericCtx (text "a class method signature for"@@ -981,7 +982,7 @@ renameSig _ (SpecInstSig _ src ty) = do { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx ty- ; return (SpecInstSig noExt src new_ty,fvs) }+ ; return (SpecInstSig noExtField src new_ty,fvs) } -- {-# SPECIALISE #-} pragmas can refer to imported Ids -- so, in the top-level case (when mb_names is Nothing)@@ -992,7 +993,7 @@ TopSigCtxt {} -> lookupLocatedOccRn v _ -> lookupSigOccRn ctxt sig v ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys- ; return (SpecSig noExt new_v new_ty inl, fvs) }+ ; return (SpecSig noExtField new_v new_ty inl, fvs) } where ty_ctxt = GenericCtx (text "a SPECIALISE signature for" <+> quotes (ppr v))@@ -1002,27 +1003,27 @@ renameSig ctxt sig@(InlineSig _ v s) = do { new_v <- lookupSigOccRn ctxt sig v- ; return (InlineSig noExt new_v s, emptyFVs) }+ ; return (InlineSig noExtField new_v s, emptyFVs) } renameSig ctxt (FixSig _ fsig) = do { new_fsig <- rnSrcFixityDecl ctxt fsig- ; return (FixSig noExt new_fsig, emptyFVs) }+ ; return (FixSig noExtField new_fsig, emptyFVs) } renameSig ctxt sig@(MinimalSig _ s (L l bf)) = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf- return (MinimalSig noExt s (L l new_bf), emptyFVs)+ return (MinimalSig noExtField s (L l new_bf), emptyFVs) renameSig ctxt sig@(PatSynSig _ vs ty) = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs ; (ty', fvs) <- rnHsSigType ty_ctxt ty- ; return (PatSynSig noExt new_vs ty', fvs) }+ ; return (PatSynSig noExtField new_vs ty', fvs) } where ty_ctxt = GenericCtx (text "a pattern synonym signature for" <+> ppr_sig_bndrs vs) renameSig ctxt sig@(SCCFunSig _ st v s) = do { new_v <- lookupSigOccRn ctxt sig v- ; return (SCCFunSig noExt st new_v s, emptyFVs) }+ ; return (SCCFunSig noExtField st new_v s, emptyFVs) } -- COMPLETE Sigs can refer to imported IDs which is why we use -- lookupLocatedOccRn rather than lookupSigOccRn@@ -1035,7 +1036,7 @@ -- Why 'any'? See Note [Orphan COMPLETE pragmas] addErrCtxt (text "In" <+> ppr sig) $ failWithTc orphanError - return (CompleteMatchSig noExt s (L l new_bf) new_mty, emptyFVs)+ return (CompleteMatchSig noExtField s (L l new_bf) new_mty, emptyFVs) where orphanError :: SDoc orphanError =@@ -1043,7 +1044,7 @@ text "A COMPLETE pragma must mention at least one data constructor" $$ text "or pattern synonym defined in the same module." -renameSig _ (XSig _) = panic "renameSig"+renameSig _ (XSig nec) = noExtCon nec {- Note [Orphan COMPLETE pragmas]@@ -1070,7 +1071,7 @@ ppr_sig_bndrs :: [Located RdrName] -> SDoc ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs) -okHsSig :: HsSigCtxt -> LSig a -> Bool+okHsSig :: HsSigCtxt -> LSig (GhcPass a) -> Bool okHsSig ctxt (L _ sig) = case (sig, ctxt) of (ClassOpSig {}, ClsDeclCtxt {}) -> True@@ -1111,7 +1112,7 @@ (CompleteMatchSig {}, TopSigCtxt {} ) -> True (CompleteMatchSig {}, _) -> False - (XSig _, _) -> panic "okHsSig"+ (XSig nec, _) -> noExtCon nec ------------------- findDupSigs :: [LSig GhcPs] -> [NonEmpty (Located RdrName, Sig GhcPs)]@@ -1167,7 +1168,7 @@ ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt)) ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms ; return (mkMatchGroup origin new_ms, ms_fvs) }-rnMatchGroup _ _ (XMatchGroup {}) = panic "rnMatchGroup"+rnMatchGroup _ _ (XMatchGroup nec) = noExtCon nec rnMatch :: Outputable (body GhcPs) => HsMatchContext Name -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))@@ -1187,9 +1188,9 @@ (FunRhs { mc_fun = L _ funid }, FunRhs { mc_fun = L lf _ }) -> mf { mc_fun = L lf funid } _ -> ctxt- ; return (Match { m_ext = noExt, m_ctxt = mf', m_pats = pats'+ ; return (Match { m_ext = noExtField, m_ctxt = mf', m_pats = pats' , m_grhss = grhss'}, grhss_fvs ) }}-rnMatch' _ _ (XMatch _) = panic "rnMatch'"+rnMatch' _ _ (XMatch nec) = noExtCon nec emptyCaseErr :: HsMatchContext Name -> SDoc emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt)@@ -1215,8 +1216,8 @@ rnGRHSs ctxt rnBody (GRHSs _ grhss (L l binds)) = rnLocalBindsAndThen binds $ \ binds' _ -> do (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss- return (GRHSs noExt grhss' (L l binds'), fvGRHSs)-rnGRHSs _ _ (XGRHSs _) = panic "rnGRHSs"+ return (GRHSs noExtField grhss' (L l binds'), fvGRHSs)+rnGRHSs _ _ (XGRHSs nec) = noExtCon nec rnGRHS :: HsMatchContext Name -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))@@ -1236,7 +1237,7 @@ ; unless (pattern_guards_allowed || is_standard_guard guards') (addWarn NoReason (nonStdGuardErr guards')) - ; return (GRHS noExt guards' rhs', fvs) }+ ; return (GRHS noExtField guards' rhs', fvs) } where -- Standard Haskell 1.4 guards are just a single boolean -- expression, rather than a list of qualifiers as in the@@ -1244,7 +1245,7 @@ is_standard_guard [] = True is_standard_guard [L _ (BodyStmt {})] = True is_standard_guard _ = False-rnGRHS' _ _ (XGRHS _) = panic "rnGRHS'"+rnGRHS' _ _ (XGRHS nec) = noExtCon nec {- *********************************************************@@ -1267,8 +1268,8 @@ -- return a fixity sig for each (slightly odd) rn_decl (FixitySig _ fnames fixity) = do names <- concatMapM lookup_one fnames- return (FixitySig noExt names fixity)- rn_decl (XFixitySig _) = panic "rnSrcFixityDecl"+ return (FixitySig noExtField names fixity)+ rn_decl (XFixitySig nec) = noExtCon nec lookup_one :: Located RdrName -> RnM [Located Name] lookup_one (L name_loc rdr_name)
compiler/rename/RnEnv.hs view
@@ -1658,10 +1658,10 @@ lookupSyntaxNames std_names = do { rebindable_on <- xoptM LangExt.RebindableSyntax ; if not rebindable_on then- return (map (HsVar noExt . noLoc) std_names, emptyFVs)+ return (map (HsVar noExtField . noLoc) std_names, emptyFVs) else do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names- ; return (map (HsVar noExt . noLoc) usr_names, mkFVs usr_names) } }+ ; return (map (HsVar noExtField . noLoc) usr_names, mkFVs usr_names) } } -- Error messages
compiler/rename/RnExpr.hs view
@@ -100,7 +100,7 @@ = do { this_mod <- getModule ; when (nameIsLocalOrFrom this_mod name) $ checkThLocalName name- ; return (HsVar noExt (L l name), unitFV name) }+ ; return (HsVar noExtField (L l name), unitFV name) } rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars) rnUnboundVar v@@ -112,11 +112,11 @@ ; uv <- if startsWithUnderscore occ then return (TrueExprHole occ) else OutOfScope occ <$> getGlobalRdrEnv- ; return (HsUnboundVar noExt uv, emptyFVs) }+ ; return (HsUnboundVar noExtField uv, emptyFVs) } else -- Fail immediately (qualified name) do { n <- reportUnboundName v- ; return (HsVar noExt (noLoc n), emptyFVs) } }+ ; return (HsVar noExtField (noLoc n), emptyFVs) } } rnExpr (HsVar _ (L l v)) = do { opt_DuplicateRecordFields <- xoptM LangExt.DuplicateRecordFields@@ -126,14 +126,14 @@ Just (Left name) | name == nilDataConName -- Treat [] as an ExplicitList, so that -- OverloadedLists works correctly- -> rnExpr (ExplicitList noExt Nothing [])+ -> rnExpr (ExplicitList noExtField Nothing []) | otherwise -> finishHsVar (L l name) ; Just (Right [s]) ->- return ( HsRecFld noExt (Unambiguous s (L l v) ), unitFV s) ;+ return ( HsRecFld noExtField (Unambiguous s (L l v) ), unitFV s) ; Just (Right fs@(_:_:_)) ->- return ( HsRecFld noExt (Ambiguous noExt (L l v))+ return ( HsRecFld noExtField (Ambiguous noExtField (L l v)) , mkFVs fs); Just (Right []) -> panic "runExpr/HsVar" } } @@ -290,9 +290,9 @@ where rnTupArg (L l (Present x e)) = do { (e',fvs) <- rnLExpr e ; return (L l (Present x e'), fvs) }- rnTupArg (L l (Missing _)) = return (L l (Missing noExt)+ rnTupArg (L l (Missing _)) = return (L l (Missing noExtField) , emptyFVs)- rnTupArg (L _ (XTupArg {})) = panic "rnExpr.XTupArg"+ rnTupArg (L _ (XTupArg nec)) = noExtCon nec rnExpr (ExplicitSum x alt arity expr) = do { (expr', fvs) <- rnLExpr expr@@ -304,18 +304,18 @@ ; (flds, fvs) <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds ; (flds', fvss) <- mapAndUnzipM rn_field flds ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd }- ; return (RecordCon { rcon_ext = noExt+ ; return (RecordCon { rcon_ext = noExtField , rcon_con_name = con_lname, rcon_flds = rec_binds' } , fvs `plusFV` plusFVs fvss `addOneFV` con_name) } where- mk_hs_var l n = HsVar noExt (L l n)+ mk_hs_var l n = HsVar noExtField (L l n) rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld) ; return (L l (fld { hsRecFieldArg = arg' }), fvs) } rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds }) = do { (expr', fvExpr) <- rnLExpr expr ; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds- ; return (RecordUpd { rupd_ext = noExt, rupd_expr = expr'+ ; return (RecordUpd { rupd_ext = noExtField, rupd_expr = expr' , rupd_flds = rbinds' } , fvExpr `plusFV` fvRbinds) } @@ -323,7 +323,7 @@ = do { (pty', fvTy) <- rnHsSigWcType BindUnlessForall ExprWithTySigCtx pty ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $ rnLExpr expr- ; return (ExprWithTySig noExt expr' pty', fvExpr `plusFV` fvTy) }+ ; return (ExprWithTySig noExtField expr' pty', fvExpr `plusFV` fvTy) } rnExpr (HsIf x _ p b1 b2) = do { (p', fvP) <- rnLExpr p@@ -444,7 +444,7 @@ ; return (HsCmdTop (cmd_names `zip` cmd_names') cmd', fvCmd `plusFV` cmd_fvs) }- rnCmdTop' (XCmdTop{}) = panic "rnCmdTop"+ rnCmdTop' (XCmdTop nec) = noExtCon nec rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars) rnLCmd = wrapLocFstM rnCmd@@ -518,7 +518,7 @@ ; return ( HsCmdDo x (L l stmts'), fvs ) } rnCmd cmd@(HsCmdWrap {}) = pprPanic "rnCmd" (ppr cmd)-rnCmd cmd@(XCmd {}) = pprPanic "rnCmd" (ppr cmd)+rnCmd (XCmd nec) = noExtCon nec --------------------------------------------------- type CmdNeeds = FreeVars -- Only inhabitants are@@ -550,7 +550,7 @@ methodNamesCmd (HsCmdCase _ _ matches) = methodNamesMatch matches `addOneFV` choiceAName -methodNamesCmd (XCmd {}) = panic "methodNamesCmd"+methodNamesCmd (XCmd nec) = noExtCon nec --methodNamesCmd _ = emptyFVs -- Other forms can't occur in commands, but it's not convenient@@ -563,20 +563,20 @@ = plusFVs (map do_one ms) where do_one (L _ (Match { m_grhss = grhss })) = methodNamesGRHSs grhss- do_one (L _ (XMatch _)) = panic "methodNamesMatch.XMatch"-methodNamesMatch (XMatchGroup _) = panic "methodNamesMatch"+ do_one (L _ (XMatch nec)) = noExtCon nec+methodNamesMatch (XMatchGroup nec) = noExtCon nec ------------------------------------------------- -- gaw 2004 methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars methodNamesGRHSs (GRHSs _ grhss _) = plusFVs (map methodNamesGRHS grhss)-methodNamesGRHSs (XGRHSs _) = panic "methodNamesGRHSs"+methodNamesGRHSs (XGRHSs nec) = noExtCon nec ------------------------------------------------- methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs-methodNamesGRHS (L _ (XGRHS _)) = panic "methodNamesGRHS"+methodNamesGRHS (L _ (XGRHS nec)) = noExtCon nec --------------------------------------------------- methodNamesStmts :: [Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn))] -> FreeVars@@ -598,7 +598,7 @@ methodNamesStmt ApplicativeStmt{} = emptyFVs -- ParStmt and TransStmt can't occur in commands, but it's not -- convenient to error here so we just do what's convenient-methodNamesStmt (XStmtLR {}) = panic "methodNamesStmt"+methodNamesStmt (XStmtLR nec) = noExtCon nec {- ************************************************************************@@ -811,7 +811,7 @@ -- #15607 ; (thing, fvs3) <- thing_inside []- ; return (([(L loc (LastStmt noExt body' noret ret_op), fv_expr)]+ ; return (([(L loc (LastStmt noExtField body' noret ret_op), fv_expr)] , thing), fv_expr `plusFV` fvs1 `plusFV` fvs3) } rnStmt ctxt rnBody (L loc (BodyStmt _ body _ _)) thing_inside@@ -826,7 +826,7 @@ -- Here "gd" is a guard ; (thing, fvs3) <- thing_inside []- ; return ( ([(L loc (BodyStmt noExt body' then_op guard_op), fv_expr)]+ ; return ( ([(L loc (BodyStmt noExtField body' then_op guard_op), fv_expr)] , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } rnStmt ctxt rnBody (L loc (BindStmt _ pat body _ _)) thing_inside@@ -838,7 +838,7 @@ ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do { (thing, fvs3) <- thing_inside (collectPatBinders pat')- ; return (( [( L loc (BindStmt noExt pat' body' bind_op fail_op)+ ; return (( [( L loc (BindStmt noExtField pat' body' bind_op fail_op) , fv_expr )] , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}@@ -848,7 +848,7 @@ rnStmt _ _ (L loc (LetStmt _ (L l binds))) thing_inside = do { rnLocalBindsAndThen binds $ \binds' bind_fvs -> do { (thing, fvs) <- thing_inside (collectLocalBinders binds')- ; return ( ([(L loc (LetStmt noExt (L l binds')), bind_fvs)], thing)+ ; return ( ([(L loc (LetStmt noExtField (L l binds')), bind_fvs)], thing) , fvs) } } rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside@@ -886,7 +886,7 @@ ; (bind_op, fvs2) <- lookupStmtName ctxt bindMName ; (return_op, fvs3) <- lookupStmtName ctxt returnMName ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside- ; return (([(L loc (ParStmt noExt segs' mzip_op bind_op), fvs4)], thing)+ ; return (([(L loc (ParStmt noExtField segs' mzip_op bind_op), fvs4)], thing) , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) } rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form@@ -919,7 +919,7 @@ -- See Note [TransStmt binder map] in HsExpr ; traceRn "rnStmt: implicitly rebound these used binders:" (ppr bndr_map)- ; return (([(L loc (TransStmt { trS_ext = noExt+ ; return (([(L loc (TransStmt { trS_ext = noExtField , trS_stmts = stmts', trS_bndrs = bndr_map , trS_by = by', trS_using = using', trS_form = form , trS_ret = return_op, trS_bind = bind_op@@ -928,8 +928,8 @@ rnStmt _ _ (L _ ApplicativeStmt{}) _ = panic "rnStmt: ApplicativeStmt" -rnStmt _ _ (L _ XStmtLR{}) _ =- panic "rnStmt: XStmtLR"+rnStmt _ _ (L _ (XStmtLR nec)) _ =+ noExtCon nec rnParallelStmts :: forall thing. HsStmtContext Name -> SyntaxExpr GhcRn@@ -960,7 +960,7 @@ ; let seg' = ParStmtBlock x stmts' used_bndrs return_op ; return ((seg':segs', thing), fvs) }- rn_segs _ _ (XParStmtBlock{}:_) = panic "rnParallelStmts"+ rn_segs _ _ (XParStmtBlock nec:_) = noExtCon nec cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:"@@ -980,12 +980,12 @@ = do { rebindable_on <- xoptM LangExt.RebindableSyntax ; if rebindable_on then do { fm <- lookupOccRn (nameRdrName name)- ; return (HsVar noExt (noLoc fm), unitFV fm) }+ ; return (HsVar noExtField (noLoc fm), unitFV fm) } else not_rebindable } | otherwise = not_rebindable where- not_rebindable = return (HsVar noExt (noLoc name), emptyFVs)+ not_rebindable = return (HsVar noExtField (noLoc name), emptyFVs) -- | Is this a context where we respect RebindableSyntax? -- but ListComp are never rebindable@@ -1093,23 +1093,23 @@ -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)] rn_rec_stmt_lhs _ (L loc (BodyStmt _ body a b))- = return [(L loc (BodyStmt noExt body a b), emptyFVs)]+ = return [(L loc (BodyStmt noExtField body a b), emptyFVs)] rn_rec_stmt_lhs _ (L loc (LastStmt _ body noret a))- = return [(L loc (LastStmt noExt body noret a), emptyFVs)]+ = return [(L loc (LastStmt noExtField body noret a), emptyFVs)] rn_rec_stmt_lhs fix_env (L loc (BindStmt _ pat body a b)) = do -- should the ctxt be MDo instead? (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat- return [(L loc (BindStmt noExt pat' body a b), fv_pat)]+ return [(L loc (BindStmt noExtField pat' body a b), fv_pat)] rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {})))) = failWith (badIpBinds (text "an mdo expression") binds) rn_rec_stmt_lhs fix_env (L loc (LetStmt _ (L l (HsValBinds x binds)))) = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds- return [(L loc (LetStmt noExt (L l (HsValBinds x binds'))),+ return [(L loc (LetStmt noExtField (L l (HsValBinds x binds'))), -- Warning: this is bogus; see function invariant emptyFVs )]@@ -1129,10 +1129,10 @@ rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _)))) = panic "rn_rec_stmt LetStmt EmptyLocalBinds"-rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR _))))- = panic "rn_rec_stmt LetStmt XHsLocalBindsLR"-rn_rec_stmt_lhs _ (L _ (XStmtLR _))- = panic "rn_rec_stmt XStmtLR"+rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR nec))))+ = noExtCon nec+rn_rec_stmt_lhs _ (L _ (XStmtLR nec))+ = noExtCon nec rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv -> [LStmt GhcPs body]@@ -1161,13 +1161,13 @@ = do { (body', fv_expr) <- rnBody body ; (ret_op, fvs1) <- lookupSyntaxName returnMName ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,- L loc (LastStmt noExt body' noret ret_op))] }+ L loc (LastStmt noExtField body' noret ret_op))] } rn_rec_stmt rnBody _ (L loc (BodyStmt _ body _ _), _) = do { (body', fvs) <- rnBody body ; (then_op, fvs1) <- lookupSyntaxName thenMName ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,- L loc (BodyStmt noExt body' then_op noSyntaxExpr))] }+ L loc (BodyStmt noExtField body' then_op noSyntaxExpr))] } rn_rec_stmt rnBody _ (L loc (BindStmt _ pat' body _ _), fv_pat) = do { (body', fv_expr) <- rnBody body@@ -1178,7 +1178,7 @@ ; let bndrs = mkNameSet (collectPatBinders pat') fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2 ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,- L loc (BindStmt noExt pat' body' bind_op fail_op))] }+ L loc (BindStmt noExtField pat' body' bind_op fail_op))] } rn_rec_stmt _ _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))), _) = failWith (badIpBinds (text "an mdo expression") binds)@@ -1188,7 +1188,7 @@ -- fixities and unused are handled above in rnRecStmtsAndThen ; let fvs = allUses du_binds ; return [(duDefs du_binds, fvs, emptyNameSet,- L loc (LetStmt noExt (L l (HsValBinds x binds'))))] }+ L loc (LetStmt noExtField (L l (HsValBinds x binds'))))] } -- no RecStmt case because they get flattened above when doing the LHSes rn_rec_stmt _ _ stmt@(L _ (RecStmt {}), _)@@ -1200,8 +1200,8 @@ rn_rec_stmt _ _ stmt@(L _ (TransStmt {}), _) -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt) -rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR _))), _)- = panic "rn_rec_stmt: LetStmt XHsLocalBindsLR"+rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR nec))), _)+ = noExtCon nec rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))), _) = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"@@ -1209,8 +1209,8 @@ rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _) = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt) -rn_rec_stmt _ _ stmt@(L _ (XStmtLR {}), _)- = pprPanic "rn_rec_stmt: XStmtLR" (ppr stmt)+rn_rec_stmt _ _ (L _ (XStmtLR nec), _)+ = noExtCon nec rn_rec_stmts :: Outputable (body GhcPs) => (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))@@ -1647,12 +1647,12 @@ tail _tail_fvs | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail -- See Note [ApplicativeDo and strict patterns]- = mkApplicativeStmt ctxt [ApplicativeArgOne noExt pat rhs False] False tail'+ = mkApplicativeStmt ctxt [ApplicativeArgOne noExtField pat rhs False] False tail' stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_)) tail _tail_fvs | (False,tail') <- needJoin monad_names tail = mkApplicativeStmt ctxt- [ApplicativeArgOne noExt nlWildPatName rhs True] False tail'+ [ApplicativeArgOne noExtField nlWildPatName rhs True] False tail' stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs = return (s : tail, emptyNameSet)@@ -1671,9 +1671,9 @@ return (stmts, unionNameSets (fvs:fvss)) where stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt _ pat exp _ _), _))- = return (ApplicativeArgOne noExt pat exp False, emptyFVs)+ = return (ApplicativeArgOne noExtField pat exp False, emptyFVs) stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ _), _)) =- return (ApplicativeArgOne noExt nlWildPatName exp True, emptyFVs)+ return (ApplicativeArgOne noExtField nlWildPatName exp True, emptyFVs) stmtTreeArg ctxt tail_fvs tree = do let stmts = flattenStmtTree tree pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)@@ -1688,8 +1688,8 @@ return (unLoc tup, emptyNameSet) | otherwise -> do (ret,fvs) <- lookupStmtNamePoly ctxt returnMName- return (HsApp noExt (noLoc ret) tup, fvs)- return ( ApplicativeArgMany noExt stmts' mb_ret pat+ return (HsApp noExtField (noLoc ret) tup, fvs)+ return ( ApplicativeArgMany noExtField stmts' mb_ret pat , fvs1 `plusFV` fvs2) @@ -1832,7 +1832,7 @@ -- an infinite loop (#14163). go lets indep bndrs ((L loc (BindStmt _ pat body bind_op fail_op), fvs): rest) | isEmptyNameSet (bndrs `intersectNameSet` fvs) && not (isStrictPattern pat)- = go lets ((L loc (BindStmt noExt pat body bind_op fail_op), fvs) : indep)+ = go lets ((L loc (BindStmt noExtField pat body bind_op fail_op), fvs) : indep) bndrs' rest where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat) -- If we encounter a LetStmt that doesn't depend on a BindStmt in this@@ -1840,9 +1840,9 @@ -- grouping more BindStmts. -- TODO: perhaps we shouldn't do this if there are any strict bindings, -- because we might be moving evaluation earlier.- go lets indep bndrs ((L loc (LetStmt noExt binds), fvs) : rest)+ go lets indep bndrs ((L loc (LetStmt noExtField binds), fvs) : rest) | isEmptyNameSet (bndrs `intersectNameSet` fvs)- = go ((L loc (LetStmt noExt binds), fvs) : lets) indep bndrs rest+ = go ((L loc (LetStmt noExtField binds), fvs) : lets) indep bndrs rest go _ [] _ _ = Nothing go _ [_] _ _ = Nothing go lets indep _ stmts = Just (reverse lets, reverse indep, stmts)@@ -1875,7 +1875,7 @@ ; return (Just join_op, fvs) } else return (Nothing, emptyNameSet)- ; let applicative_stmt = noLoc $ ApplicativeStmt noExt+ ; let applicative_stmt = noLoc $ ApplicativeStmt noExtField (zip (fmap_op : repeat ap_op) args) mb_join ; return ( applicative_stmt : body_stmts@@ -1889,7 +1889,7 @@ needJoin _monad_names [] = (False, []) -- we're in an ApplicativeArg needJoin monad_names [L loc (LastStmt _ e _ t)] | Just arg <- isReturnApp monad_names e =- (False, [L loc (LastStmt noExt arg True t)])+ (False, [L loc (LastStmt noExtField arg True t)]) needJoin _monad_names stmts = (True, stmts) -- | @Just e@, if the expression is @return e@ or @return $ e@,@@ -1978,7 +1978,7 @@ msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> ptext (sLit "statement") , text "in" <+> pprAStmtContext ctxt ] -pprStmtCat :: Stmt a body -> SDoc+pprStmtCat :: Stmt (GhcPass a) body -> SDoc pprStmtCat (TransStmt {}) = text "transform" pprStmtCat (LastStmt {}) = text "return expression" pprStmtCat (BodyStmt {}) = text "body"@@ -1987,7 +1987,7 @@ pprStmtCat (RecStmt {}) = text "rec" pprStmtCat (ParStmt {}) = text "parallel" pprStmtCat (ApplicativeStmt {}) = panic "pprStmtCat: ApplicativeStmt"-pprStmtCat (XStmtLR {}) = panic "pprStmtCat: XStmtLR"+pprStmtCat (XStmtLR nec) = noExtCon nec ------------ emptyInvalid :: Validity -- Payload is the empty document@@ -2053,7 +2053,7 @@ RecStmt {} -> emptyInvalid LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt) ApplicativeStmt {} -> emptyInvalid- XStmtLR{} -> panic "okCompStmt"+ XStmtLR nec -> noExtCon nec --------- checkTupleSection :: [LHsTupArg GhcPs] -> RnM ()@@ -2134,7 +2134,7 @@ (nlHsApp (noLoc $ syn_expr fromStringExpr) (noLoc $ syn_expr arg_syn_expr)) let failAfterFromStringExpr :: HsExpr GhcRn =- unLoc $ mkHsLam [noLoc $ VarPat noExt $ noLoc arg_name] body+ unLoc $ mkHsLam [noLoc $ VarPat noExtField $ noLoc arg_name] body let failAfterFromStringSynExpr :: SyntaxExpr GhcRn = mkSyntaxExpr failAfterFromStringExpr return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs)
compiler/rename/RnFixity.hs view
@@ -211,4 +211,4 @@ format_ambig (elt, fix) = hang (ppr fix) 2 (pprNameProvenance elt)-lookupFieldFixityRn (XAmbiguousFieldOcc{}) = panic "lookupFieldFixityRn"+lookupFieldFixityRn (XAmbiguousFieldOcc nec) = noExtCon nec
compiler/rename/RnNames.hs view
@@ -263,7 +263,7 @@ rnImportDecl :: Module -> LImportDecl GhcPs -> RnM (LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage) rnImportDecl this_mod- (L loc decl@(ImportDecl { ideclExt = noExt+ (L loc decl@(ImportDecl { ideclExt = noExtField , ideclName = loc_imp_mod_name , ideclPkgQual = mb_pkg , ideclSource = want_boot, ideclSafe = mod_safe@@ -376,11 +376,11 @@ _ -> return () ) - let new_imp_decl = L loc (decl { ideclExt = noExt, ideclSafe = mod_safe'+ let new_imp_decl = L loc (decl { ideclExt = noExtField, ideclSafe = mod_safe' , ideclHiding = new_imp_details }) return (new_imp_decl, gbl_env, imports, mi_hpc iface)-rnImportDecl _ (L _ (XImportDecl _)) = panic "rnImportDecl"+rnImportDecl _ (L _ (XImportDecl nec)) = noExtCon nec -- | Calculate the 'ImportAvails' induced by an import of a particular -- interface, but without 'imp_mods'.@@ -723,7 +723,7 @@ = expectJust "getLocalNonValBinders/find_con_decl_fld" $ find (\ fl -> flLabel fl == lbl) flds where lbl = occNameFS (rdrNameOcc rdr)- find_con_decl_fld (L _ (XFieldOcc _)) = panic "getLocalNonValBinders"+ find_con_decl_fld (L _ (XFieldOcc nec)) = noExtCon nec new_assoc :: Bool -> LInstDecl GhcPs -> RnM ([AvailInfo], [(Name, [FieldLabel])])@@ -759,8 +759,8 @@ (avails, fldss) <- mapAndUnzipM (new_loc_di overload_ok (Just cls_nm)) adts pure (avails, concat fldss)- new_assoc _ (L _ (ClsInstD _ (XClsInstDecl _))) = panic "new_assoc"- new_assoc _ (L _ (XInstDecl _)) = panic "new_assoc"+ new_assoc _ (L _ (ClsInstD _ (XClsInstDecl nec))) = noExtCon nec+ new_assoc _ (L _ (XInstDecl nec)) = noExtCon nec new_di :: Bool -> Maybe Name -> DataFamInstDecl GhcPs -> RnM (AvailInfo, [(Name, [FieldLabel])])@@ -774,16 +774,16 @@ -- main_name is not bound here! fld_env = mk_fld_env (feqn_rhs ti_decl) sub_names flds' ; return (avail, fld_env) }- new_di _ _ (DataFamInstDecl (XHsImplicitBndrs _)) = panic "new_di"+ new_di _ _ (DataFamInstDecl (XHsImplicitBndrs nec)) = noExtCon nec new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl GhcPs -> RnM (AvailInfo, [(Name, [FieldLabel])]) new_loc_di overload_ok mb_cls (L _ d) = new_di overload_ok mb_cls d-getLocalNonValBinders _ (XHsGroup _) = panic "getLocalNonValBinders"+getLocalNonValBinders _ (XHsGroup nec) = noExtCon nec newRecordSelector :: Bool -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!"-newRecordSelector _ _ (L _ (XFieldOcc _)) = panic "newRecordSelector"+newRecordSelector _ _ (L _ (XFieldOcc nec)) = noExtCon nec newRecordSelector overload_ok (dc:_) (L loc (FieldOcc _ (L _ fld))) = do { selName <- newTopSrcBinder $ L loc $ field ; return $ qualFieldLbl { flSelector = selName } }@@ -966,7 +966,7 @@ case ie of IEVar _ (L l n) -> do (name, avail, _) <- lookup_name ie $ ieWrappedName n- return ([(IEVar noExt (L l (replaceWrappedName n name)),+ return ([(IEVar noExtField (L l (replaceWrappedName n name)), trimAvail avail name)], []) IEThingAll _ (L l tc) -> do@@ -985,7 +985,7 @@ | otherwise -> [] - renamed_ie = IEThingAll noExt (L l (replaceWrappedName tc name))+ renamed_ie = IEThingAll noExtField (L l (replaceWrappedName tc name)) sub_avails = case avail of Avail {} -> [] AvailTC name2 subs fs -> [(renamed_ie, AvailTC name2 (subs \\ [name]) fs)]@@ -1014,7 +1014,7 @@ IEThingWith xt ltc@(L l rdr_tc) wc rdr_ns rdr_fs -> ASSERT2(null rdr_fs, ppr rdr_fs) do (name, avail, mb_parent)- <- lookup_name (IEThingAbs noExt ltc) (ieWrappedName rdr_tc)+ <- lookup_name (IEThingAbs noExtField ltc) (ieWrappedName rdr_tc) let (ns,subflds) = case avail of AvailTC _ ns' subflds' -> (ns',subflds')@@ -1038,7 +1038,7 @@ case mb_parent of -- non-associated ty/cls Nothing- -> return ([(IEThingWith noExt (L l name') wc childnames'+ -> return ([(IEThingWith noExtField (L l name') wc childnames' childflds, AvailTC name (name:map unLoc childnames) (map unLoc childflds))], [])@@ -1047,10 +1047,10 @@ -- childnames' = postrn_ies childnames -- associated ty Just parent- -> return ([(IEThingWith noExt (L l name') wc childnames'+ -> return ([(IEThingWith noExtField (L l name') wc childnames' childflds, AvailTC name (map unLoc childnames) (map unLoc childflds)),- (IEThingWith noExt (L l name') wc childnames'+ (IEThingWith noExtField (L l name') wc childnames' childflds, AvailTC parent [name] [])], [])@@ -1063,9 +1063,9 @@ where mkIEThingAbs tc l (n, av, Nothing )- = (IEThingAbs noExt (L l (replaceWrappedName tc n)), trimAvail av n)+ = (IEThingAbs noExtField (L l (replaceWrappedName tc n)), trimAvail av n) mkIEThingAbs tc l (n, _, Just parent)- = (IEThingAbs noExt (L l (replaceWrappedName tc n))+ = (IEThingAbs noExtField (L l (replaceWrappedName tc n)) , AvailTC parent [n] []) handle_bad_import m = catchIELookup m $ \err -> case err of@@ -1394,7 +1394,7 @@ -- If you use 'signum' from Num, then the user may well have -- imported Num(signum). We don't want to complain that -- Num is not itself mentioned. Hence the two cases in add_unused_with.- unused_decl (L _ (XImportDecl _)) = panic "unused_decl"+ unused_decl (L _ (XImportDecl nec)) = noExtCon nec {- Note [The ImportMap]@@ -1535,25 +1535,25 @@ -- we want to say "T(..)", but if we're importing only a subset we want -- to say "T(A,B,C)". So we have to find out what the module exports. to_ie _ (Avail n)- = [IEVar noExt (to_ie_post_rn $ noLoc n)]+ = [IEVar noExtField (to_ie_post_rn $ noLoc n)] to_ie _ (AvailTC n [m] [])- | n==m = [IEThingAbs noExt (to_ie_post_rn $ noLoc n)]+ | n==m = [IEThingAbs noExtField (to_ie_post_rn $ noLoc n)] to_ie iface (AvailTC n ns fs) = case [(xs,gs) | AvailTC x xs gs <- mi_exports iface , x == n , x `elem` xs -- Note [Partial export] ] of- [xs] | all_used xs -> [IEThingAll noExt (to_ie_post_rn $ noLoc n)]+ [xs] | all_used xs -> [IEThingAll noExtField (to_ie_post_rn $ noLoc n)] | otherwise ->- [IEThingWith noExt (to_ie_post_rn $ noLoc n) NoIEWildcard+ [IEThingWith noExtField (to_ie_post_rn $ noLoc n) NoIEWildcard (map (to_ie_post_rn . noLoc) (filter (/= n) ns)) (map noLoc fs)] -- Note [Overloaded field import] _other | all_non_overloaded fs- -> map (IEVar noExt . to_ie_post_rn_var . noLoc) $ ns+ -> map (IEVar noExtField . to_ie_post_rn_var . noLoc) $ ns ++ map flSelector fs | otherwise ->- [IEThingWith noExt (to_ie_post_rn $ noLoc n) NoIEWildcard+ [IEThingWith noExtField (to_ie_post_rn $ noLoc n) NoIEWildcard (map (to_ie_post_rn . noLoc) (filter (/= n) ns)) (map noLoc fs)] where@@ -1718,7 +1718,7 @@ text "but it has none" ] dodgyMsgInsert :: forall p . IdP (GhcPass p) -> IE (GhcPass p)-dodgyMsgInsert tc = IEThingAll noExt ii+dodgyMsgInsert tc = IEThingAll noExtField ii where ii :: LIEWrappedName (IdP (GhcPass p)) ii = noLoc (IEName $ noLoc tc)
compiler/rename/RnPat.hs view
@@ -384,7 +384,7 @@ rnLPatAndThen nm lpat = wrapSrcSpanCps (rnPatAndThen nm) lpat rnPatAndThen :: NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn)-rnPatAndThen _ (WildPat _) = return (WildPat noExt)+rnPatAndThen _ (WildPat _) = return (WildPat noExtField) rnPatAndThen mk (ParPat x pat) = do { pat' <- rnLPatAndThen mk pat ; return (ParPat x pat') } rnPatAndThen mk (LazyPat x pat) = do { pat' <- rnLPatAndThen mk pat@@ -471,7 +471,7 @@ -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on. = case unLoc con == nameRdrName (dataConName nilDataCon) of True -> do { ol_flag <- liftCps $ xoptM LangExt.OverloadedLists- ; if ol_flag then rnPatAndThen mk (ListPat noExt [])+ ; if ol_flag then rnPatAndThen mk (ListPat noExtField []) else rnConPatAndThen mk con stuff} False -> rnConPatAndThen mk con stuff @@ -548,7 +548,7 @@ ; check_unused_wildcard (implicit_binders flds' <$> dd) ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) } where- mkVarPat l n = VarPat noExt (cL l n)+ mkVarPat l n = VarPat noExtField (cL l n) rn_field (dL->L l fld, n') = do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hsRecFieldArg fld) ; return (cL l (fld { hsRecFieldArg = arg' })) }@@ -747,7 +747,7 @@ then do { checkErr pun_ok (badPun (cL loc lbl)) -- Discard any module qualifier (#11662) ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)- ; return (cL loc (HsVar noExt (cL loc arg_rdr))) }+ ; return (cL loc (HsVar noExtField (cL loc arg_rdr))) } else return arg ; (arg'', fvs) <- rnLExpr arg' @@ -757,10 +757,10 @@ Right _ -> fvs lbl' = case sel of Left sel_name ->- cL loc (Unambiguous sel_name (cL loc lbl))+ cL loc (Unambiguous sel_name (cL loc lbl)) Right [sel_name] ->- cL loc (Unambiguous sel_name (cL loc lbl))- Right _ -> cL loc (Ambiguous noExt (cL loc lbl))+ cL loc (Unambiguous sel_name (cL loc lbl))+ Right _ -> cL loc (Ambiguous noExtField (cL loc lbl)) ; return (cL l (HsRecField { hsRecFieldLbl = lbl' , hsRecFieldArg = arg''
compiler/rename/RnSource.hs view
@@ -62,6 +62,7 @@ import Digraph ( SCC, flattenSCC, flattenSCCs, Node(..) , stronglyConnCompFromEdgedVerticesUniq ) import UniqSet+import OrdList import qualified GHC.LanguageExtensions as LangExt import Control.Monad@@ -197,7 +198,7 @@ last_tcg_env <- getGblEnv ; -- (I) Compute the results and return- let {rn_group = HsGroup { hs_ext = noExt,+ let {rn_group = HsGroup { hs_ext = noExtField, hs_valds = rn_val_decls, hs_splcds = rn_splice_decls, hs_tyclds = rn_tycl_decls,@@ -217,7 +218,7 @@ src_fvs5, src_fvs6, src_fvs7] ; -- It is tiresome to gather the binders from type and class decls - src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ;+ src_dus = unitOL other_def `plusDU` bind_dus `plusDU` usesOnly other_fvs ; -- Instance decls may have occurrences of things bound in bind_dus -- so we must put other_fvs last @@ -229,7 +230,7 @@ traceRn "finish Dus" (ppr src_dus ) ; return (final_tcg_env, rn_group) }}}}-rnSrcDecls (XHsGroup _) = panic "rnSrcDecls"+rnSrcDecls (XHsGroup nec) = noExtCon nec addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv -- This function could be defined lower down in the module hierarchy,@@ -297,7 +298,7 @@ = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc) rdr_names ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] }- rn_deprec (XWarnDecl _) = panic "rnSrcWarnDecls"+ rn_deprec (XWarnDecl nec) = noExtCon nec what = text "deprecation" @@ -331,9 +332,9 @@ do { (provenance', provenance_fvs) <- rnAnnProvenance provenance ; (expr', expr_fvs) <- setStage (Splice Untyped) $ rnLExpr expr- ; return (HsAnnotation noExt s provenance' expr',+ ; return (HsAnnotation noExtField s provenance' expr', provenance_fvs `plusFV` expr_fvs) }-rnAnnDecl (XAnnDecl _) = panic "rnAnnDecl"+rnAnnDecl (XAnnDecl nec) = noExtCon nec rnAnnProvenance :: AnnProvenance RdrName -> RnM (AnnProvenance Name, FreeVars)@@ -352,10 +353,10 @@ rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars) rnDefaultDecl (DefaultDecl _ tys) = do { (tys', fvs) <- rnLHsTypes doc_str tys- ; return (DefaultDecl noExt tys', fvs) }+ ; return (DefaultDecl noExtField tys', fvs) } where doc_str = DefaultDeclCtx-rnDefaultDecl (XDefaultDecl _) = panic "rnDefaultDecl"+rnDefaultDecl (XDefaultDecl nec) = noExtCon nec {- *********************************************************@@ -375,14 +376,14 @@ ; let unitId = thisPackage $ hsc_dflags topEnv spec' = patchForeignImport unitId spec - ; return (ForeignImport { fd_i_ext = noExt+ ; return (ForeignImport { fd_i_ext = noExtField , fd_name = name', fd_sig_ty = ty' , fd_fi = spec' }, fvs) } rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec }) = do { name' <- lookupLocatedOccRn name ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty- ; return (ForeignExport { fd_e_ext = noExt+ ; return (ForeignExport { fd_e_ext = noExtField , fd_name = name', fd_sig_ty = ty' , fd_fe = spec } , fvs `addOneFV` unLoc name') }@@ -390,7 +391,7 @@ -- we add it to the free-variable list. It might, for example, -- be imported from another module -rnHsForeignDecl (XForeignDecl _) = panic "rnHsForeignDecl"+rnHsForeignDecl (XForeignDecl nec) = noExtCon nec -- | For Windows DLLs we need to know what packages imported symbols are from -- to generate correct calls. Imported symbols are tagged with the current@@ -425,19 +426,19 @@ rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars) rnSrcInstDecl (TyFamInstD { tfid_inst = tfi }) = do { (tfi', fvs) <- rnTyFamInstDecl NonAssocTyFamEqn tfi- ; return (TyFamInstD { tfid_ext = noExt, tfid_inst = tfi' }, fvs) }+ ; return (TyFamInstD { tfid_ext = noExtField, tfid_inst = tfi' }, fvs) } rnSrcInstDecl (DataFamInstD { dfid_inst = dfi }) = do { (dfi', fvs) <- rnDataFamInstDecl NonAssocTyFamEqn dfi- ; return (DataFamInstD { dfid_ext = noExt, dfid_inst = dfi' }, fvs) }+ ; return (DataFamInstD { dfid_ext = noExtField, dfid_inst = dfi' }, fvs) } rnSrcInstDecl (ClsInstD { cid_inst = cid }) = do { traceRn "rnSrcIstDecl {" (ppr cid) ; (cid', fvs) <- rnClsInstDecl cid ; traceRn "rnSrcIstDecl end }" empty- ; return (ClsInstD { cid_d_ext = noExt, cid_inst = cid' }, fvs) }+ ; return (ClsInstD { cid_d_ext = noExtField, cid_inst = cid' }, fvs) } -rnSrcInstDecl (XInstDecl _) = panic "rnSrcInstDecl"+rnSrcInstDecl (XInstDecl nec) = noExtCon nec -- | Warn about non-canonical typeclass instance declarations --@@ -647,7 +648,7 @@ ; let all_fvs = meth_fvs `plusFV` more_fvs `plusFV` inst_fvs- ; return (ClsInstDecl { cid_ext = noExt+ ; return (ClsInstDecl { cid_ext = noExtField , cid_poly_ty = inst_ty', cid_binds = mbinds' , cid_sigs = uprags', cid_tyfam_insts = ats' , cid_overlap_mode = oflag@@ -663,7 +664,7 @@ -- the instance context after renaming. This is a bit -- strange, but should not matter (and it would be more work -- to remove the context).-rnClsInstDecl (XClsInstDecl _) = panic "rnClsInstDecl"+rnClsInstDecl (XClsInstDecl nec) = noExtCon nec rnFamInstEqn :: HsDocContext -> AssocTyFamInfo@@ -745,15 +746,15 @@ ; return (HsIB { hsib_ext = all_imp_var_names -- Note [Wildcards in family instances] , hsib_body- = FamEqn { feqn_ext = noExt+ = FamEqn { feqn_ext = noExtField , feqn_tycon = tycon' , feqn_bndrs = bndrs' <$ mb_bndrs , feqn_pats = pats' , feqn_fixity = fixity , feqn_rhs = payload' } }, all_fvs) }-rnFamInstEqn _ _ _ (HsIB _ (XFamEqn _)) _ = panic "rnFamInstEqn"-rnFamInstEqn _ _ _ (XHsImplicitBndrs _) _ = panic "rnFamInstEqn"+rnFamInstEqn _ _ _ (HsIB _ (XFamEqn nec)) _ = noExtCon nec+rnFamInstEqn _ _ _ (XHsImplicitBndrs nec) _ = noExtCon nec rnTyFamInstDecl :: AssocTyFamInfo -> TyFamInstDecl GhcPs@@ -801,8 +802,8 @@ withHsDocContext (TyFamilyCtx fam_rdr_name) $ wrongTyFamName fam_name tycon' ; pure (eqn', fvs) }-rnTyFamInstEqn _ _ (HsIB _ (XFamEqn _)) = panic "rnTyFamInstEqn"-rnTyFamInstEqn _ _ (XHsImplicitBndrs _) = panic "rnTyFamInstEqn"+rnTyFamInstEqn _ _ (HsIB _ (XFamEqn nec)) = noExtCon nec+rnTyFamInstEqn _ _ (XHsImplicitBndrs nec) = noExtCon nec rnTyFamDefltDecl :: Name -> TyFamDefltDecl GhcPs@@ -819,10 +820,10 @@ ; (eqn', fvs) <- rnFamInstEqn (TyDataCtx tycon) atfi rhs_kvs eqn rnDataDefn ; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) }-rnDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn _)))- = panic "rnDataFamInstDecl"-rnDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs _))- = panic "rnDataFamInstDecl"+rnDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn nec)))+ = noExtCon nec+rnDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs nec))+ = noExtCon nec -- Renaming of the associated types in instances. @@ -970,14 +971,13 @@ = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving ; unless standalone_deriv_ok (addErr standaloneDerivErr) ; (mds', ty', fvs)- <- rnLDerivStrategy DerivDeclCtx mds $ \strat_tvs ppr_via_ty ->- rnAndReportFloatingViaTvs strat_tvs loc ppr_via_ty "instance" $+ <- rnLDerivStrategy DerivDeclCtx mds $ rnHsSigWcType BindUnlessForall DerivDeclCtx ty ; warnNoDerivStrat mds' loc- ; return (DerivDecl noExt ty' mds' overlap, fvs) }+ ; return (DerivDecl noExtField ty' mds' overlap, fvs) } where loc = getLoc $ hsib_body $ hswc_body ty-rnSrcDerivDecl (XDerivDecl _) = panic "rnSrcDerivDecl"+rnSrcDerivDecl (XDerivDecl nec) = noExtCon nec standaloneDerivErr :: SDoc standaloneDerivErr@@ -996,10 +996,10 @@ rnHsRuleDecls (HsRules { rds_src = src , rds_rules = rules }) = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules- ; return (HsRules { rds_ext = noExt+ ; return (HsRules { rds_ext = noExtField , rds_src = src , rds_rules = rn_rules }, fvs) }-rnHsRuleDecls (XRuleDecls _) = panic "rnHsRuleDecls"+rnHsRuleDecls (XRuleDecls nec) = noExtCon nec rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars) rnHsRuleDecl (HsRule { rd_name = rule_name@@ -1028,9 +1028,9 @@ where get_var (RuleBndrSig _ v _) = v get_var (RuleBndr _ v) = v- get_var (XRuleBndr _) = panic "rnHsRuleDecl"+ get_var (XRuleBndr nec) = noExtCon nec in_rule = text "in the rule" <+> pprFullRuleName rule_name-rnHsRuleDecl (XRuleDecl _) = panic "rnHsRuleDecl"+rnHsRuleDecl (XRuleDecl nec) = noExtCon nec bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs -> [LRuleBndr GhcPs] -> [Name]@@ -1042,13 +1042,13 @@ where go ((dL->L l (RuleBndr _ (dL->L loc _))) : vars) (n : ns) thing_inside = go vars ns $ \ vars' ->- thing_inside (cL l (RuleBndr noExt (cL loc n)) : vars')+ thing_inside (cL l (RuleBndr noExtField (cL loc n)) : vars') go ((dL->L l (RuleBndrSig _ (dL->L loc _) bsig)) : vars) (n : ns) thing_inside = rnHsSigWcTypeScoped bind_free_tvs doc bsig $ \ bsig' -> go vars ns $ \ vars' ->- thing_inside (cL l (RuleBndrSig noExt (cL loc n) bsig') : vars')+ thing_inside (cL l (RuleBndrSig noExtField (cL loc n) bsig') : vars') go [] [] thing_inside = thing_inside [] go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)@@ -1305,13 +1305,13 @@ first_group | null init_inst_ds = []- | otherwise = [TyClGroup { group_ext = noExt+ | otherwise = [TyClGroup { group_ext = noExtField , group_tyclds = [] , group_roles = [] , group_instds = init_inst_ds }] - ((final_inst_ds, orphan_roles), groups)- = mapAccumL mk_group (rest_inst_ds, role_annot_env) tycl_sccs+ (final_inst_ds, groups)+ = mapAccumL (mk_group role_annot_env) rest_inst_ds tycl_sccs all_fvs = plusFV (foldr (plusFV . snd) emptyFVs tycls_w_fvs)@@ -1319,25 +1319,24 @@ all_groups = first_group ++ groups - ; ASSERT2( null final_inst_ds, ppr instds_w_fvs $$ ppr inst_ds_map+ ; MASSERT2( null final_inst_ds, ppr instds_w_fvs $$ ppr inst_ds_map $$ ppr (flattenSCCs tycl_sccs) $$ ppr final_inst_ds )- mapM_ orphanRoleAnnotErr (nameEnvElts orphan_roles) ; traceRn "rnTycl dependency analysis made groups" (ppr all_groups) ; return (all_groups, all_fvs) } where- mk_group :: (InstDeclFreeVarsMap, RoleAnnotEnv)+ mk_group :: RoleAnnotEnv+ -> InstDeclFreeVarsMap -> SCC (LTyClDecl GhcRn)- -> ( (InstDeclFreeVarsMap, RoleAnnotEnv)- , TyClGroup GhcRn )- mk_group (inst_map, role_env) scc- = ((inst_map', role_env'), group)+ -> (InstDeclFreeVarsMap, TyClGroup GhcRn)+ mk_group role_env inst_map scc+ = (inst_map', group) where tycl_ds = flattenSCC scc bndrs = map (tcdName . unLoc) tycl_ds+ roles = getRoleAnnots bndrs role_env (inst_ds, inst_map') = getInsts bndrs inst_map- (roles, role_env') = getRoleAnnots bndrs role_env- group = TyClGroup { group_ext = noExt+ group = TyClGroup { group_ext = noExtField , group_tyclds = tycl_ds , group_roles = roles , group_instds = inst_ds }@@ -1404,8 +1403,8 @@ tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names) (text "role annotation") tycon- ; return $ RoleAnnotDecl noExt tycon' roles }- rn_role_annot1 (XRoleAnnotDecl _) = panic "rnRoleAnnots"+ ; return $ RoleAnnotDecl noExtField tycon' roles }+ rn_role_annot1 (XRoleAnnotDecl nec) = noExtCon nec dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM () dupRoleAnnotErr list@@ -1422,16 +1421,7 @@ cmp_annot (dL->L loc1 _) (dL->L loc2 _) = loc1 `compare` loc2 -orphanRoleAnnotErr :: LRoleAnnotDecl GhcRn -> RnM ()-orphanRoleAnnotErr (dL->L loc decl)- = addErrAt loc $- hang (text "Role annotation for a type previously declared:")- 2 (ppr decl) $$- parens (text "The role annotation must be given where" <+>- quotes (ppr $ roleAnnotDeclName decl) <+>- text "is declared.") - {- Note [Role annotations in the renamer] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We must ensure that a type's role annotation is put in the same group as the@@ -1446,21 +1436,8 @@ of one another. The renaming process, as usual, might identify and report errors for unbound-names. We exclude the annotations for unbound names in the annotation-environment to avoid spurious errors for orphaned annotations.--We then (in rnTyClDecls) do a check for orphan role annotations (role-annotations without an accompanying type decl). The check works by folding-over components (of type [[Either (TyClDecl Name) (InstDecl Name)]]), selecting-out the relevant role declarations for each group, as well as diminishing the-annotation environment. After the fold is complete, anything left over in the-name environment must be an orphan, and errors are generated.--An earlier version of this algorithm short-cut the orphan check by renaming-only with names declared in this module. But, this check is insufficient in-the case of staged module compilation (Template Haskell, GHCi).-See #8485. With the new lookup process (which includes types declared in other-modules), we get better error messages, too.+names. This is done by using lookupSigCtxtOccRn in rnRoleAnnots (using+lookupGlobalOccRn led to #8485). -} @@ -1523,7 +1500,7 @@ -- in a class decl rnTyClDecl (FamDecl { tcdFam = decl }) = do { (decl', fvs) <- rnFamDecl Nothing decl- ; return (FamDecl noExt decl', fvs) }+ ; return (FamDecl noExtField decl', fvs) } rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs })@@ -1628,7 +1605,7 @@ where cls_doc = ClassDeclCtx lcls -rnTyClDecl (XTyClDecl _) = panic "rnTyClDecl"+rnTyClDecl (XTyClDecl nec) = noExtCon nec -- Does the data type declaration include a CUSK? dataDeclHasCUSK :: LHsQTyVars pass -> NewOrData -> Bool -> Bool -> RnM Bool@@ -1696,7 +1673,7 @@ ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV` con_fvs `plusFV` sig_fvs- ; return ( HsDataDefn { dd_ext = noExt+ ; return ( HsDataDefn { dd_ext = noExtField , dd_ND = new_or_data, dd_cType = cType , dd_ctxt = context', dd_kindSig = m_sig' , dd_cons = condecls'@@ -1714,7 +1691,7 @@ multipleDerivClausesErr ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds ; return (cL loc ds', fvs) }-rnDataDefn _ (XHsDataDefn _) = panic "rnDataDefn"+rnDataDefn _ (XHsDataDefn nec) = noExtCon nec warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn) -> SrcSpan@@ -1743,46 +1720,37 @@ -> RnM (LHsDerivingClause GhcRn, FreeVars) rnLHsDerivingClause doc (dL->L loc (HsDerivingClause- { deriv_clause_ext = noExt+ { deriv_clause_ext = noExtField , deriv_clause_strategy = dcs , deriv_clause_tys = (dL->L loc' dct) })) = do { (dcs', dct', fvs)- <- rnLDerivStrategy doc dcs $ \strat_tvs ppr_via_ty ->- mapFvRn (rn_deriv_ty strat_tvs ppr_via_ty) dct+ <- rnLDerivStrategy doc dcs $ mapFvRn (rnHsSigType doc) dct ; warnNoDerivStrat dcs' loc- ; pure ( cL loc (HsDerivingClause { deriv_clause_ext = noExt+ ; pure ( cL loc (HsDerivingClause { deriv_clause_ext = noExtField , deriv_clause_strategy = dcs' , deriv_clause_tys = cL loc' dct' }) , fvs ) }- where- rn_deriv_ty :: [Name] -> SDoc -> LHsSigType GhcPs- -> RnM (LHsSigType GhcRn, FreeVars)- rn_deriv_ty strat_tvs ppr_via_ty deriv_ty@(HsIB {hsib_body = dL->L loc _}) =- rnAndReportFloatingViaTvs strat_tvs loc ppr_via_ty "class" $- rnHsSigType doc deriv_ty- rn_deriv_ty _ _ (XHsImplicitBndrs _) = panic "rn_deriv_ty"-rnLHsDerivingClause _ (dL->L _ (XHsDerivingClause _))- = panic "rnLHsDerivingClause"+rnLHsDerivingClause _ (dL->L _ (XHsDerivingClause nec))+ = noExtCon nec rnLHsDerivingClause _ _ = panic "rnLHsDerivingClause: Impossible Match" -- due to #15884 rnLDerivStrategy :: forall a. HsDocContext -> Maybe (LDerivStrategy GhcPs)- -> ([Name] -- The tyvars bound by the via type- -> SDoc -- The pretty-printed via type (used for- -- error message reporting)- -> RnM (a, FreeVars))+ -> RnM (a, FreeVars) -> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars) rnLDerivStrategy doc mds thing_inside = case mds of Nothing -> boring_case Nothing- Just ds -> do (ds', thing, fvs) <- rn_deriv_strat ds- pure (Just ds', thing, fvs)+ Just (dL->L loc ds) ->+ setSrcSpan loc $ do+ (ds', thing, fvs) <- rn_deriv_strat ds+ pure (Just (cL loc ds'), thing, fvs) where- rn_deriv_strat :: LDerivStrategy GhcPs- -> RnM (LDerivStrategy GhcRn, a, FreeVars)- rn_deriv_strat (dL->L loc ds) = do+ rn_deriv_strat :: DerivStrategy GhcPs+ -> RnM (DerivStrategy GhcRn, a, FreeVars)+ rn_deriv_strat ds = do let extNeeded :: LangExt.Extension extNeeded | ViaStrategy{} <- ds@@ -1794,9 +1762,9 @@ failWith $ illegalDerivStrategyErr ds case ds of- StockStrategy -> boring_case (cL loc StockStrategy)- AnyclassStrategy -> boring_case (cL loc AnyclassStrategy)- NewtypeStrategy -> boring_case (cL loc NewtypeStrategy)+ StockStrategy -> boring_case StockStrategy+ AnyclassStrategy -> boring_case AnyclassStrategy+ NewtypeStrategy -> boring_case NewtypeStrategy ViaStrategy via_ty -> do (via_ty', fvs1) <- rnHsSigType doc via_ty let HsIB { hsib_ext = via_imp_tvs@@ -1804,65 +1772,13 @@ (via_exp_tv_bndrs, _, _) = splitLHsSigmaTy via_body via_exp_tvs = hsLTyVarNames via_exp_tv_bndrs via_tvs = via_imp_tvs ++ via_exp_tvs- (thing, fvs2) <- extendTyVarEnvFVRn via_tvs $- thing_inside via_tvs (ppr via_ty')- pure (cL loc (ViaStrategy via_ty'), thing, fvs1 `plusFV` fvs2)-- boring_case :: mds- -> RnM (mds, a, FreeVars)- boring_case mds = do- (thing, fvs) <- thing_inside [] empty- pure (mds, thing, fvs)---- | Errors if a @via@ type binds any floating type variables.--- See @Note [Floating `via` type variables]@-rnAndReportFloatingViaTvs- :: forall a. Outputable a- => [Name] -- ^ The bound type variables from a @via@ type.- -> SrcSpan -- ^ The source span (for error reporting only).- -> SDoc -- ^ The pretty-printed @via@ type (for error reporting only).- -> String -- ^ A description of what the @via@ type scopes over- -- (for error reporting only).- -> RnM (a, FreeVars) -- ^ The thing the @via@ type scopes over.- -> RnM (a, FreeVars)-rnAndReportFloatingViaTvs tv_names loc ppr_via_ty via_scope_desc thing_inside- = do (thing, thing_fvs) <- thing_inside- setSrcSpan loc $ mapM_ (report_floating_via_tv thing thing_fvs) tv_names- pure (thing, thing_fvs)- where- report_floating_via_tv :: a -> FreeVars -> Name -> RnM ()- report_floating_via_tv thing used_names tv_name- = unless (tv_name `elemNameSet` used_names) $ addErr $ vcat- [ text "Type variable" <+> quotes (ppr tv_name) <+>- text "is bound in the" <+> quotes (text "via") <+>- text "type" <+> quotes ppr_via_ty- , text "but is not mentioned in the derived" <+>- text via_scope_desc <+> quotes (ppr thing) <>- text ", which is illegal" ]--{--Note [Floating `via` type variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Imagine the following `deriving via` clause:-- data Quux- deriving Eq via (Const a Quux)--This should be rejected. Why? Because it would generate the following instance:-- instance Eq Quux where- (==) = coerce @(Quux -> Quux -> Bool)- @(Const a Quux -> Const a Quux -> Bool)- (==) :: Const a Quux -> Const a Quux -> Bool--This instance is ill-formed, as the `a` in `Const a Quux` is unbound. The-problem is that `a` is never used anywhere in the derived class `Eq`. Since-`a` is bound but has no use sites, we refer to it as "floating".+ (thing, fvs2) <- extendTyVarEnvFVRn via_tvs thing_inside+ pure (ViaStrategy via_ty', thing, fvs1 `plusFV` fvs2) -We use the rnAndReportFloatingViaTvs function to check that any type renamed-within the context of the `via` deriving strategy actually uses all bound-`via` type variables, and if it doesn't, it throws an error.--}+ boring_case :: ds -> RnM (ds, a, FreeVars)+ boring_case ds = do+ (thing, fvs) <- thing_inside+ pure (ds, thing, fvs) badGadtStupidTheta :: HsDocContext -> SDoc badGadtStupidTheta _@@ -1905,7 +1821,7 @@ injectivity ; return ( (tyvars', res_sig', injectivity') , fv_kind ) } ; (info', fv2) <- rn_info tycon' info- ; return (FamilyDecl { fdExt = noExt+ ; return (FamilyDecl { fdExt = noExtField , fdLName = tycon', fdTyVars = tyvars' , fdFixity = fixity , fdInfo = info', fdResultSig = res_sig'@@ -1928,16 +1844,16 @@ = return (ClosedTypeFamily Nothing, emptyFVs) rn_info _ OpenTypeFamily = return (OpenTypeFamily, emptyFVs) rn_info _ DataFamily = return (DataFamily, emptyFVs)-rnFamDecl _ (XFamilyDecl _) = panic "rnFamDecl"+rnFamDecl _ (XFamilyDecl nec) = noExtCon nec rnFamResultSig :: HsDocContext -> FamilyResultSig GhcPs -> RnM (FamilyResultSig GhcRn, FreeVars) rnFamResultSig _ (NoSig _)- = return (NoSig noExt, emptyFVs)+ = return (NoSig noExtField, emptyFVs) rnFamResultSig doc (KindSig _ kind) = do { (rndKind, ftvs) <- rnLHsKind doc kind- ; return (KindSig noExt rndKind, ftvs) }+ ; return (KindSig noExtField rndKind, ftvs) } rnFamResultSig doc (TyVarSig _ tvbndr) = do { -- `TyVarSig` tells us that user named the result of a type family by -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to@@ -1959,8 +1875,8 @@ ; bindLHsTyVarBndr doc Nothing -- This might be a lie, but it's used for -- scoping checks that are irrelevant here tvbndr $ \ tvbndr' ->- return (TyVarSig noExt tvbndr', unitFV (hsLTyVarName tvbndr')) }-rnFamResultSig _ (XFamilyResultSig _) = panic "rnFamResultSig"+ return (TyVarSig noExtField tvbndr', unitFV (hsLTyVarName tvbndr')) }+rnFamResultSig _ (XFamilyResultSig nec) = noExtCon nec -- Note [Renaming injectivity annotation] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2111,7 +2027,7 @@ [ text "ex_tvs:" <+> ppr ex_tvs , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ]) - ; return (decl { con_ext = noExt+ ; 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' },@@ -2164,13 +2080,13 @@ , hsq_explicit = explicit_tkvs } ; traceRn "rnConDecl2" (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs)- ; return (decl { con_g_ext = noExt, con_names = new_names+ ; return (decl { con_g_ext = noExtField, con_names = new_names , con_qvars = new_qtvs, con_mb_cxt = new_cxt , con_args = args', con_res_ty = res_ty' , con_doc = mb_doc' }, all_fvs) } } -rnConDecl (XConDecl _) = panic "rnConDecl"+rnConDecl (XConDecl nec) = noExtCon nec rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs)@@ -2232,7 +2148,7 @@ bnd_name <- newTopSrcBinder (cL bind_loc n) let rnames = map recordPatSynSelectorId as mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs- mkFieldOcc (dL->L l name) = cL l (FieldOcc noExt (cL l name))+ mkFieldOcc (dL->L l name) = cL l (FieldOcc noExtField (cL l name)) field_occs = map mkFieldOcc rnames flds <- mapM (newRecordSelector False [bnd_name]) field_occs return ((bnd_name, flds): names)@@ -2365,13 +2281,13 @@ = addl (gp { hs_ruleds = cL l d : ts }) ds add gp l (DocD _ d) ds = addl (gp { hs_docs = (cL l d) : (hs_docs gp) }) ds-add (HsGroup {}) _ (SpliceD _ (XSpliceDecl _)) _ = panic "RnSource.add"-add (HsGroup {}) _ (XHsDecl _) _ = panic "RnSource.add"-add (XHsGroup _) _ _ _ = panic "RnSource.add"+add (HsGroup {}) _ (SpliceD _ (XSpliceDecl nec)) _ = noExtCon nec+add (HsGroup {}) _ (XHsDecl nec) _ = noExtCon nec+add (XHsGroup nec) _ _ _ = noExtCon nec add_tycld :: LTyClDecl (GhcPass p) -> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]-add_tycld d [] = [TyClGroup { group_ext = noExt+add_tycld d [] = [TyClGroup { group_ext = noExtField , group_tyclds = [d] , group_roles = [] , group_instds = []@@ -2379,11 +2295,11 @@ ] add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss) = ds { group_tyclds = d : tyclds } : dss-add_tycld _ (XTyClGroup _: _) = panic "add_tycld"+add_tycld _ (XTyClGroup nec: _) = noExtCon nec add_instd :: LInstDecl (GhcPass p) -> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]-add_instd d [] = [TyClGroup { group_ext = noExt+add_instd d [] = [TyClGroup { group_ext = noExtField , group_tyclds = [] , group_roles = [] , group_instds = [d]@@ -2391,11 +2307,11 @@ ] add_instd d (ds@(TyClGroup { group_instds = instds }):dss) = ds { group_instds = d : instds } : dss-add_instd _ (XTyClGroup _: _) = panic "add_instd"+add_instd _ (XTyClGroup nec: _) = noExtCon nec add_role_annot :: LRoleAnnotDecl (GhcPass p) -> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]-add_role_annot d [] = [TyClGroup { group_ext = noExt+add_role_annot d [] = [TyClGroup { group_ext = noExtField , group_tyclds = [] , group_roles = [d] , group_instds = []@@ -2403,7 +2319,7 @@ ] add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest) = tycls { group_roles = d : roles } : rest-add_role_annot _ (XTyClGroup _: _) = panic "add_role_annot"+add_role_annot _ (XTyClGroup nec: _) = noExtCon nec add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a add_bind b (ValBinds x bs sigs) = ValBinds x (bs `snocBag` b) sigs
compiler/rename/RnSplice.hs view
@@ -104,7 +104,7 @@ ; (body', fvs_e) <- setStage (Brack cur_stage RnPendingTyped) $ rn_bracket cur_stage br_body- ; return (HsBracket noExt body', fvs_e) }+ ; return (HsBracket noExtField body', fvs_e) } False -> do { traceRn "Renaming untyped TH bracket" empty ; ps_var <- newMutVar []@@ -112,7 +112,7 @@ setStage (Brack cur_stage (RnPendingUntyped ps_var)) $ rn_bracket cur_stage br_body ; pendings <- readMutVar ps_var- ; return (HsRnBracketOut noExt body' pendings, fvs_e) }+ ; return (HsRnBracketOut noExtField body' pendings, fvs_e) } } rn_bracket :: ThStage -> HsBracket GhcPs -> RnM (HsBracket GhcRn, FreeVars)@@ -180,7 +180,7 @@ rn_bracket _ (TExpBr x e) = do { (e', fvs) <- rnLExpr e ; return (TExpBr x e', fvs) } -rn_bracket _ (XBracket {}) = panic "rn_bracket: unexpected XBracket"+rn_bracket _ (XBracket nec) = noExtCon nec quotationCtxtDoc :: HsBracket GhcPs -> SDoc quotationCtxtDoc br_body@@ -303,7 +303,7 @@ HsTypedSplice {} -> pprPanic "runRnSplice" (ppr splice) HsSpliced {} -> pprPanic "runRnSplice" (ppr splice) HsSplicedT {} -> pprPanic "runRnSplice" (ppr splice)- XSplice {} -> pprPanic "runRnSplice" (ppr splice)+ XSplice nec -> noExtCon nec -- Typecheck the expression ; meta_exp_ty <- tcMetaTy meta_ty_name@@ -352,8 +352,8 @@ = pprPanic "makePending" (ppr splice) makePending _ splice@(HsSplicedT {}) = pprPanic "makePending" (ppr splice)-makePending _ splice@(XSplice {})- = pprPanic "makePending" (ppr splice)+makePending _ (XSplice nec)+ = noExtCon nec ------------------ mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString@@ -361,13 +361,13 @@ -- Return the expression (quoter "...quote...") -- which is what we must run in a quasi-quote mkQuasiQuoteExpr flavour quoter q_span quote- = cL q_span $ HsApp noExt (cL q_span- $ HsApp noExt (cL q_span (HsVar noExt (cL q_span quote_selector)))- quoterExpr)+ = cL q_span $ HsApp noExtField (cL q_span+ $ HsApp noExtField (cL q_span (HsVar noExtField (cL q_span quote_selector)))+ quoterExpr) quoteExpr where- quoterExpr = cL q_span $! HsVar noExt $! (cL q_span quoter)- quoteExpr = cL q_span $! HsLit noExt $! HsString NoSourceText quote+ quoterExpr = cL q_span $! HsVar noExtField $! (cL q_span quoter)+ quoteExpr = cL q_span $! HsLit noExtField $! HsString NoSourceText quote quote_selector = case flavour of UntypedExpSplice -> quoteExpName UntypedPatSplice -> quotePatName@@ -404,7 +404,7 @@ rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice) rnSplice splice@(HsSplicedT {}) = pprPanic "rnSplice" (ppr splice)-rnSplice splice@(XSplice {}) = pprPanic "rnSplice" (ppr splice)+rnSplice (XSplice nec) = noExtCon nec --------------------- rnSpliceExpr :: HsSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars)@@ -413,7 +413,7 @@ where pend_expr_splice :: HsSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn) pend_expr_splice rn_splice- = (makePending UntypedExpSplice rn_splice, HsSpliceE noExt rn_splice)+ = (makePending UntypedExpSplice rn_splice, HsSpliceE noExtField rn_splice) run_expr_splice :: HsSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars) run_expr_splice rn_splice@@ -426,7 +426,7 @@ , isLocalGRE gre] lcl_names = mkNameSet (localRdrEnvElts lcl_rdr) - ; return (HsSpliceE noExt rn_splice, lcl_names `plusFV` gbl_names) }+ ; return (HsSpliceE noExtField rn_splice, lcl_names `plusFV` gbl_names) } | otherwise -- Run it here, see Note [Running splices in the Renamer] = do { traceRn "rnSpliceExpr: untyped expression splice" empty@@ -434,8 +434,8 @@ runRnSplice UntypedExpSplice runMetaE ppr rn_splice ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr) -- See Note [Delaying modFinalizers in untyped splices].- ; return ( HsPar noExt $ HsSpliceE noExt- . HsSpliced noExt (ThModFinalizers mod_finalizers)+ ; return ( HsPar noExtField $ HsSpliceE noExtField+ . HsSpliced noExtField (ThModFinalizers mod_finalizers) . HsSplicedExpr <$> lexpr3 , fvs)@@ -538,7 +538,7 @@ where pend_type_splice rn_splice = ( makePending UntypedTypeSplice rn_splice- , HsSpliceTy noExt rn_splice)+ , HsSpliceTy noExtField rn_splice) run_type_splice rn_splice = do { traceRn "rnSpliceType: untyped type splice" empty@@ -548,8 +548,9 @@ ; checkNoErrs $ rnLHsType doc hs_ty2 } -- checkNoErrs: see Note [Renamer errors] -- See Note [Delaying modFinalizers in untyped splices].- ; return ( HsParTy noExt $ HsSpliceTy noExt- . HsSpliced noExt (ThModFinalizers mod_finalizers)+ ; return ( HsParTy noExtField+ $ HsSpliceTy noExtField+ . HsSpliced noExtField (ThModFinalizers mod_finalizers) . HsSplicedTy <$> hs_ty3 , fvs@@ -608,7 +609,7 @@ (PendingRnSplice, Either b (Pat GhcRn)) pend_pat_splice rn_splice = (makePending UntypedPatSplice rn_splice- , Right (SplicePat noExt rn_splice))+ , Right (SplicePat noExtField rn_splice)) run_pat_splice :: HsSplice GhcRn -> RnM (Either (Pat GhcPs) (Pat GhcRn), FreeVars)@@ -617,8 +618,8 @@ ; (pat, mod_finalizers) <- runRnSplice UntypedPatSplice runMetaP ppr rn_splice -- See Note [Delaying modFinalizers in untyped splices].- ; return ( Left $ ParPat noExt $ ((SplicePat noExt)- . HsSpliced noExt (ThModFinalizers mod_finalizers)+ ; return ( Left $ ParPat noExtField $ ((SplicePat noExtField)+ . HsSpliced noExtField (ThModFinalizers mod_finalizers) . HsSplicedPat) `onHasSrcSpan` pat , emptyFVs@@ -633,10 +634,10 @@ where pend_decl_splice rn_splice = ( makePending UntypedDeclSplice rn_splice- , SpliceDecl noExt (cL loc rn_splice) flg)+ , SpliceDecl noExtField (cL loc rn_splice) flg) - run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice)-rnSpliceDecl (XSpliceDecl _) = panic "rnSpliceDecl"+ run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice)+rnSpliceDecl (XSpliceDecl nec) = noExtCon nec rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars) -- Declaration splice at the very top level of the module
compiler/rename/RnTypes.hs view
@@ -137,10 +137,10 @@ , hsib_body = hs_ty' } ; (res, fvs2) <- thing_inside sig_ty' ; return (res, fvs1 `plusFV` fvs2) } }-rn_hs_sig_wc_type _ _ (HsWC _ (XHsImplicitBndrs _)) _- = panic "rn_hs_sig_wc_type"-rn_hs_sig_wc_type _ _ (XHsWildCardBndrs _) _- = panic "rn_hs_sig_wc_type"+rn_hs_sig_wc_type _ _ (HsWC _ (XHsImplicitBndrs nec)) _+ = noExtCon nec+rn_hs_sig_wc_type _ _ (XHsWildCardBndrs nec) _+ = noExtCon nec rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars) rnHsWcType ctxt (HsWC { hswc_body = hs_ty })@@ -149,7 +149,7 @@ ; (wcs, hs_ty', fvs) <- rnWcBody ctxt nwc_rdrs hs_ty ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = hs_ty' } ; return (sig_ty', fvs) }-rnHsWcType _ (XHsWildCardBndrs _) = panic "rnHsWcType"+rnHsWcType _ (XHsWildCardBndrs nec) = noExtCon nec rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType GhcPs -> RnM ([Name], LHsType GhcRn, FreeVars)@@ -174,7 +174,7 @@ , hst_body = hs_body }) = bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc hs_ty) Nothing tvs $ \ tvs' -> do { (hs_body', fvs) <- rn_lty env hs_body- ; return (HsForAllTy { hst_fvf = fvf, hst_xforall = noExt+ ; return (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField , hst_bndrs = tvs', hst_body = hs_body' } , fvs) } @@ -184,16 +184,16 @@ , (dL->L lx (HsWildCardTy _)) <- ignoreParens hs_ctxt_last = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1 ; setSrcSpan lx $ checkExtraConstraintWildCard env hs_ctxt1- ; let hs_ctxt' = hs_ctxt1' ++ [cL lx (HsWildCardTy noExt)]+ ; let hs_ctxt' = hs_ctxt1' ++ [cL lx (HsWildCardTy noExtField)] ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty- ; return (HsQualTy { hst_xqual = noExt+ ; return (HsQualTy { hst_xqual = noExtField , hst_ctxt = cL cx hs_ctxt', hst_body = hs_ty' } , fvs1 `plusFV` fvs2) } | otherwise = do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty- ; return (HsQualTy { hst_xqual = noExt+ ; return (HsQualTy { hst_xqual = noExtField , hst_ctxt = cL cx hs_ctxt' , hst_body = hs_ty' } , fvs1 `plusFV` fvs2) }@@ -307,7 +307,7 @@ ; return ( HsIB { hsib_ext = vars , hsib_body = body' } , fvs ) } }-rnHsSigType _ (XHsImplicitBndrs _) = panic "rnHsSigType"+rnHsSigType _ (XHsImplicitBndrs nec) = noExtCon nec rnImplicitBndrs :: Bool -- True <=> bring into scope any free type variables -- E.g. f :: forall a. a->b@@ -487,7 +487,7 @@ ; bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc ty) Nothing tyvars $ \ tyvars' -> do { (tau', fvs) <- rnLHsTyKi env tau- ; return ( HsForAllTy { hst_fvf = fvf, hst_xforall = noExt+ ; return ( HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField , hst_bndrs = tyvars' , hst_body = tau' } , fvs) } } @@ -495,7 +495,7 @@ = do { checkPolyKinds env ty -- See Note [QualTy in kinds] ; (ctxt', fvs1) <- rnTyKiContext env lctxt ; (tau', fvs2) <- rnLHsTyKi env tau- ; return (HsQualTy { hst_xqual = noExt, hst_ctxt = ctxt'+ ; return (HsQualTy { hst_xqual = noExtField, hst_ctxt = ctxt' , hst_body = tau' } , fvs1 `plusFV` fvs2) } @@ -508,7 +508,7 @@ -- Any type variable at the kind level is illegal without the use -- of PolyKinds (see #14710) ; name <- rnTyVar env rdr_name- ; return (HsTyVar noExt ip (cL loc name), unitFV name) }+ ; return (HsTyVar noExtField ip (cL loc name), unitFV name) } rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2) = setSrcSpan (getLoc l_op) $@@ -516,23 +516,23 @@ ; fix <- lookupTyFixityRn l_op' ; (ty1', fvs2) <- rnLHsTyKi env ty1 ; (ty2', fvs3) <- rnLHsTyKi env ty2- ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy noExt t1 l_op' t2)+ ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy noExtField t1 l_op' t2) (unLoc l_op') fix ty1' ty2' ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) } rnHsTyKi env (HsParTy _ ty) = do { (ty', fvs) <- rnLHsTyKi env ty- ; return (HsParTy noExt ty', fvs) }+ ; return (HsParTy noExtField ty', fvs) } rnHsTyKi env (HsBangTy _ b ty) = do { (ty', fvs) <- rnLHsTyKi env ty- ; return (HsBangTy noExt b ty', fvs) }+ ; return (HsBangTy noExtField b ty', fvs) } rnHsTyKi env ty@(HsRecTy _ flds) = do { let ctxt = rtke_ctxt env ; fls <- get_fields ctxt ; (flds', fvs) <- rnConDeclFields ctxt fls flds- ; return (HsRecTy noExt flds', fvs) }+ ; return (HsRecTy noExtField flds', fvs) } where get_fields (ConDeclCtx names) = concatMapM (lookupConstructorFields . unLoc) names@@ -549,7 +549,7 @@ -- when we find return :: forall m. Monad m -> forall a. a -> m a -- Check for fixity rearrangements- ; res_ty <- mkHsOpTyRn (HsFunTy noExt) funTyConName funTyFixity ty1' ty2'+ ; res_ty <- mkHsOpTyRn (HsFunTy noExtField) funTyConName funTyFixity ty1' ty2' ; return (res_ty, fvs1 `plusFV` fvs2) } rnHsTyKi env listTy@(HsListTy _ ty)@@ -557,7 +557,7 @@ ; when (not data_kinds && isRnKindLevel env) (addErr (dataKindsErr env listTy)) ; (ty', fvs) <- rnLHsTyKi env ty- ; return (HsListTy noExt ty', fvs) }+ ; return (HsListTy noExtField ty', fvs) } rnHsTyKi env t@(HsKindSig _ ty k) = do { checkPolyKinds env t@@ -565,7 +565,7 @@ ; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty) ; (ty', fvs1) <- rnLHsTyKi env ty ; (k', fvs2) <- rnLHsTyKi (env { rtke_level = KindLevel }) k- ; return (HsKindSig noExt ty' k', fvs1 `plusFV` fvs2) }+ ; return (HsKindSig noExtField ty' k', fvs1 `plusFV` fvs2) } -- Unboxed tuples are allowed to have poly-typed arguments. These -- sometimes crop up as a result of CPR worker-wrappering dictionaries.@@ -574,14 +574,14 @@ ; when (not data_kinds && isRnKindLevel env) (addErr (dataKindsErr env tupleTy)) ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys- ; return (HsTupleTy noExt tup_con tys', fvs) }+ ; return (HsTupleTy noExtField tup_con tys', fvs) } rnHsTyKi env sumTy@(HsSumTy _ tys) = do { data_kinds <- xoptM LangExt.DataKinds ; when (not data_kinds && isRnKindLevel env) (addErr (dataKindsErr env sumTy)) ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys- ; return (HsSumTy noExt tys', fvs) }+ ; return (HsSumTy noExtField tys', fvs) } -- Ensure that a type-level integer is nonnegative (#8306, #8412) rnHsTyKi env tyLit@(HsTyLit _ t)@@ -589,7 +589,7 @@ ; unless data_kinds (addErr (dataKindsErr env tyLit)) ; when (negLit t) (addErr negLitErr) ; checkPolyKinds env tyLit- ; return (HsTyLit noExt t, emptyFVs) }+ ; return (HsTyLit noExtField t, emptyFVs) } where negLit (HsStrTy _ _) = False negLit (HsNumTy _ i) = i < 0@@ -598,7 +598,7 @@ rnHsTyKi env (HsAppTy _ ty1 ty2) = do { (ty1', fvs1) <- rnLHsTyKi env ty1 ; (ty2', fvs2) <- rnLHsTyKi env ty2- ; return (HsAppTy noExt ty1' ty2', fvs1 `plusFV` fvs2) }+ ; return (HsAppTy noExtField ty1' ty2', fvs1 `plusFV` fvs2) } rnHsTyKi env (HsAppKindTy l ty k) = do { kind_app <- xoptM LangExt.TypeApplications@@ -610,10 +610,10 @@ rnHsTyKi env t@(HsIParamTy _ n ty) = do { notInKinds env t ; (ty', fvs) <- rnLHsTyKi env ty- ; return (HsIParamTy noExt n ty', fvs) }+ ; return (HsIParamTy noExtField n ty', fvs) } rnHsTyKi _ (HsStarTy _ isUni)- = return (HsStarTy noExt isUni, emptyFVs)+ = return (HsStarTy noExtField isUni, emptyFVs) rnHsTyKi _ (HsSpliceTy _ sp) = rnSpliceType sp@@ -621,7 +621,7 @@ rnHsTyKi env (HsDocTy _ ty haddock_doc) = do { (ty', fvs) <- rnLHsTyKi env ty ; haddock_doc' <- rnLHsDoc haddock_doc- ; return (HsDocTy noExt ty' haddock_doc', fvs) }+ ; return (HsDocTy noExtField ty' haddock_doc', fvs) } rnHsTyKi _ (XHsType (NHsCoreTy ty)) = return (XHsType (NHsCoreTy ty), emptyFVs)@@ -633,18 +633,18 @@ ; data_kinds <- xoptM LangExt.DataKinds ; unless data_kinds (addErr (dataKindsErr env ty)) ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys- ; return (HsExplicitListTy noExt ip tys', fvs) }+ ; return (HsExplicitListTy noExtField ip tys', fvs) } rnHsTyKi env ty@(HsExplicitTupleTy _ tys) = do { checkPolyKinds env ty ; data_kinds <- xoptM LangExt.DataKinds ; unless data_kinds (addErr (dataKindsErr env ty)) ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys- ; return (HsExplicitTupleTy noExt tys', fvs) }+ ; return (HsExplicitTupleTy noExtField tys', fvs) } rnHsTyKi env (HsWildCardTy _) = do { checkAnonWildCard env- ; return (HsWildCardTy noExt, emptyFVs) }+ ; return (HsWildCardTy noExtField, emptyFVs) } -------------- rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name@@ -1000,7 +1000,7 @@ $ thing_inside (cL loc (KindedTyVar x (cL lv tv_nm) kind')) ; return (b, fvs1 `plusFV` fvs2) } -bindLHsTyVarBndr _ _ (dL->L _ (XTyVarBndr{})) _ = panic "bindLHsTyVarBndr"+bindLHsTyVarBndr _ _ (dL->L _ (XTyVarBndr nec)) _ = noExtCon nec bindLHsTyVarBndr _ _ _ _ = panic "bindLHsTyVarBndr: Impossible Match" -- due to #15884 @@ -1042,7 +1042,7 @@ = do { let new_names = map (fmap lookupField) names ; (new_ty, fvs) <- rnLHsTyKi env ty ; new_haddock_doc <- rnMbLHsDoc haddock_doc- ; return (cL l (ConDeclField noExt new_names new_ty new_haddock_doc)+ ; return (cL l (ConDeclField noExtField new_names new_ty new_haddock_doc) , fvs) } where lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn@@ -1051,8 +1051,8 @@ where lbl = occNameFS $ rdrNameOcc rdr fl = expectJust "rnField" $ lookupFsEnv fl_env lbl- lookupField (XFieldOcc{}) = panic "rnField"-rnField _ _ (dL->L _ (XConDeclField _)) = panic "rnField"+ lookupField (XFieldOcc nec) = noExtCon nec+rnField _ _ (dL->L _ (XConDeclField nec)) = noExtCon nec rnField _ _ _ = panic "rnField: Impossible Match" -- due to #15884 @@ -1088,15 +1088,15 @@ -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> RnM (HsType GhcRn) -mkHsOpTyRn mk1 pp_op1 fix1 ty1 (dL->L loc2 (HsOpTy noExt ty21 op2 ty22))+mkHsOpTyRn mk1 pp_op1 fix1 ty1 (dL->L loc2 (HsOpTy noExtField ty21 op2 ty22)) = do { fix2 <- lookupTyFixityRn op2 ; mk_hs_op_ty mk1 pp_op1 fix1 ty1- (\t1 t2 -> HsOpTy noExt t1 op2 t2)+ (\t1 t2 -> HsOpTy noExtField t1 op2 t2) (unLoc op2) fix2 ty21 ty22 loc2 } mkHsOpTyRn mk1 pp_op1 fix1 ty1 (dL->L loc2 (HsFunTy _ ty21 ty22)) = mk_hs_op_ty mk1 pp_op1 fix1 ty1- (HsFunTy noExt) funTyConName funTyFixity ty21 ty22 loc2+ (HsFunTy noExtField) funTyConName funTyFixity ty21 ty22 loc2 mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment = return (mk1 ty1 ty2)@@ -1148,7 +1148,7 @@ | associate_right = do new_e <- mkOpAppRn neg_arg op2 fix2 e2- return (NegApp noExt (cL loc' new_e) neg_name)+ return (NegApp noExtField (cL loc' new_e) neg_name) where loc' = combineLocs neg_arg e2 (nofix_error, associate_right) = compareFixity negateFixity fix2@@ -1210,7 +1210,7 @@ -> RnM (HsExpr (GhcPass id)) mkNegAppRn neg_arg neg_name = ASSERT( not_op_app (unLoc neg_arg) )- return (NegApp noExt neg_arg neg_name)+ return (NegApp noExtField neg_arg neg_name) not_op_app :: HsExpr id -> Bool not_op_app (OpApp {}) = False@@ -1234,7 +1234,7 @@ | associate_right = do new_c <- mkOpFormRn a12 op2 fix2 a2- return (HsCmdArrForm noExt op1 f (Just fix1)+ return (HsCmdArrForm noExtField op1 f (Just fix1) [a11, cL loc (HsCmdTop [] (cL loc new_c))]) -- TODO: locs are wrong where@@ -1242,7 +1242,7 @@ -- Default case mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment- = return (HsCmdArrForm noExt op Infix (Just fix) [arg1, arg2])+ = return (HsCmdArrForm noExtField op Infix (Just fix) [arg1, arg2]) --------------------------------------@@ -1296,7 +1296,7 @@ -- but the second eqn has no args (an error, but not discovered -- until the type checker). So we don't want to crash on the -- second eqn.-checkPrecMatch _ (XMatchGroup {}) = panic "checkPrecMatch"+checkPrecMatch _ (XMatchGroup nec) = noExtCon nec checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) () checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do@@ -1677,7 +1677,7 @@ extractDataDefnKindVars :: HsDataDefn GhcPs -> FreeKiTyVarsNoDups extractDataDefnKindVars (HsDataDefn { dd_kindSig = ksig }) = maybe [] extractHsTyRdrTyVars ksig-extractDataDefnKindVars (XHsDataDefn _) = panic "extractDataDefnKindVars"+extractDataDefnKindVars (XHsDataDefn nec) = noExtCon nec extract_lctxt :: LHsContext GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
compiler/simplCore/SetLevels.hs view
@@ -88,7 +88,8 @@ import Demand ( StrictSig, Demand, isStrictDmd, splitStrictSig, increaseStrictSigArity ) import Name ( getOccName, mkSystemVarName ) import OccName ( occNameString )-import Type ( Type, mkLamTypes, splitTyConApp_maybe, tyCoVarsOfType, closeOverKindsDSet )+import Type ( Type, mkLamTypes, splitTyConApp_maybe, tyCoVarsOfType+ , isUnliftedType, closeOverKindsDSet ) import BasicTypes ( Arity, RecFlag(..), isRec ) import DataCon ( dataConOrigResTy ) import TysWiredIn@@ -1098,12 +1099,20 @@ | floatTopLvlOnly env && not (isTopLvl dest_lvl) -- Only floating to the top level is allowed. || not (profitableFloat env dest_lvl)- = do { let bind_lvl = incMinorLvl (le_ctxt_lvl env)+ || (isTopLvl dest_lvl && any (isUnliftedType . idType) bndrs)+ -- This isUnliftedType stuff is the same test as in the non-rec case+ -- You might wonder whether we can have a recursive binding for+ -- an unlifted value -- but we can if it's a /join binding/ (#16978)+ -- (Ultimately I think we should not use SetLevels to+ -- float join bindings at all, but that's another story.)+ = -- No float+ do { let bind_lvl = incMinorLvl (le_ctxt_lvl env) (env', bndrs') = substAndLvlBndrs Recursive env bind_lvl bndrs lvl_rhs (b,r) = lvlRhs env' Recursive is_bot (isJoinId_maybe b) r ; rhss' <- mapM lvl_rhs pairs ; return (Rec (bndrs' `zip` rhss'), env') } + -- Otherwise we are going to float | null abs_vars = do { (new_env, new_bndrs) <- cloneLetVars Recursive env dest_lvl bndrs ; new_rhss <- mapM (do_rhs new_env) pairs
compiler/simplCore/SimplEnv.hs view
@@ -667,7 +667,9 @@ -- Get the most up-to-date thing from the in-scope set -- Even though it isn't in the substitution, it may be in- -- the in-scope set with better IdInfo+ -- the in-scope set with better IdInfo.+ --+ -- See also Note [In-scope set as a substitution] in Simplify. refineFromInScope :: InScopeSet -> Var -> Var refineFromInScope in_scope v
compiler/simplCore/Simplify.hs view
@@ -118,6 +118,40 @@ we should eta expand wherever we find a (value) lambda? Then the eta expansion at a let RHS can concentrate solely on the PAP case. +Note [In-scope set as a substitution]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As per Note [Lookups in in-scope set], an in-scope set can act as+a substitution. Specifically, it acts as a substitution from variable to+variables /with the same unique/.++Why do we need this? Well, during the course of the simplifier, we may want to+adjust inessential properties of a variable. For instance, when performing a+beta-reduction, we change++ (\x. e) u ==> let x = u in e++We typically want to add an unfolding to `x` so that it inlines to (the+simplification of) `u`.++We do that by adding the unfolding to the binder `x`, which is added to the+in-scope set. When simplifying occurrences of `x` (every occurrence!), they are+replaced by their “updated” version from the in-scope set, hence inherit the+unfolding. This happens in `SimplEnv.substId`.++Another example. Consider++ case x of y { Node a b -> ...y...+ ; Leaf v -> ...y... }++In the Node branch want y's unfolding to be (Node a b); in the Leaf branch we+want y's unfolding to be (Leaf v). We achieve this by adding the appropriate+unfolding to y, and re-adding it to the in-scope set. See the calls to+`addBinderUnfolding` in `Simplify.addAltUnfoldings` and elsewhere.++It's quite convenient. This way we don't need to manipulate the substitution all+the time: every update to a binder is automatically reflected to its bound+occurrences.+ ************************************************************************ * * \subsection{Bindings}@@ -659,6 +693,7 @@ final_rhs (idType new_bndr) old_unf ; let final_bndr = addLetBndrInfo new_bndr new_arity is_bot new_unfolding+ -- See Note [In-scope set as a substitution] ; if postInlineUnconditionally env top_lvl final_bndr occ_info final_rhs
compiler/simplStg/StgLiftLams/Transformation.hs view
@@ -107,12 +107,12 @@ liftRhs Nothing (StgRhsClosure _ ccs upd infos body) = do -- This RHS wasn't lifted. withSubstBndrs (map binderInfoBndr infos) $ \bndrs' ->- StgRhsClosure noExtSilent ccs upd bndrs' <$> liftExpr body+ StgRhsClosure noExtFieldSilent ccs upd bndrs' <$> liftExpr body liftRhs (Just former_fvs) (StgRhsClosure _ ccs upd infos body) = do -- This RHS was lifted. Insert extra binders for @former_fvs@. withSubstBndrs (map binderInfoBndr infos) $ \bndrs' -> do let bndrs'' = dVarSetElems former_fvs ++ bndrs'- StgRhsClosure noExtSilent ccs upd bndrs'' <$> liftExpr body+ StgRhsClosure noExtFieldSilent ccs upd bndrs'' <$> liftExpr body liftArgs :: InStgArg -> LiftM OutStgArg liftArgs a@(StgLitArg _) = pure a@@ -142,13 +142,13 @@ body' <- liftExpr body case mb_bind' of Nothing -> pure body' -- withLiftedBindPairs decided to lift it and already added floats- Just bind' -> pure (StgLet noExtSilent bind' body')+ Just bind' -> pure (StgLet noExtFieldSilent bind' body') liftExpr (StgLetNoEscape scope bind body) = withLiftedBind NotTopLevel bind scope $ \mb_bind' -> do body' <- liftExpr body case mb_bind' of Nothing -> pprPanic "stgLiftLams" (text "Should never decide to lift LNEs")- Just bind' -> pure (StgLetNoEscape noExtSilent bind' body')+ Just bind' -> pure (StgLetNoEscape noExtFieldSilent bind' body') liftAlt :: LlStgAlt -> LiftM OutStgAlt liftAlt (con, infos, rhs) = withSubstBndrs (map binderInfoBndr infos) $ \bndrs' ->
compiler/stgSyn/CoreToStg.hs view
@@ -644,8 +644,8 @@ -- Compute the new let-expression let- new_let | isJoinBind bind = StgLetNoEscape noExtSilent bind2 body2- | otherwise = StgLet noExtSilent bind2 body2+ new_let | isJoinBind bind = StgLetNoEscape noExtFieldSilent bind2 body2+ | otherwise = StgLet noExtFieldSilent bind2 body2 return new_let where@@ -688,7 +688,7 @@ mkTopStgRhs dflags this_mod ccs bndr rhs | StgLam bndrs body <- rhs = -- StgLam can't have empty arguments, so not CAF- ( StgRhsClosure noExtSilent+ ( StgRhsClosure noExtFieldSilent dontCareCCS ReEntrant (toList bndrs) body@@ -704,19 +704,19 @@ -- Otherwise it's a CAF, see Note [Cost-centre initialization plan]. | gopt Opt_AutoSccsOnIndividualCafs dflags- = ( StgRhsClosure noExtSilent+ = ( StgRhsClosure noExtFieldSilent caf_ccs upd_flag [] rhs , collectCC caf_cc caf_ccs ccs ) | otherwise- = ( StgRhsClosure noExtSilent+ = ( StgRhsClosure noExtFieldSilent all_cafs_ccs upd_flag [] rhs , ccs ) where- (_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs+ unticked_rhs = stripStgTicksTopE (not . tickishIsCode) rhs upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry | otherwise = Updatable@@ -738,14 +738,14 @@ mkStgRhs :: Id -> StgExpr -> StgRhs mkStgRhs bndr rhs | StgLam bndrs body <- rhs- = StgRhsClosure noExtSilent+ = StgRhsClosure noExtFieldSilent currentCCS ReEntrant (toList bndrs) body | isJoinId bndr -- must be a nullary join point = ASSERT(idJoinArity bndr == 0)- StgRhsClosure noExtSilent+ StgRhsClosure noExtFieldSilent currentCCS ReEntrant -- ignored for LNE [] rhs@@ -754,11 +754,11 @@ = StgRhsCon currentCCS con args | otherwise- = StgRhsClosure noExtSilent+ = StgRhsClosure noExtFieldSilent currentCCS upd_flag [] rhs where- (_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs+ unticked_rhs = stripStgTicksTopE (not . tickishIsCode) rhs upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry | otherwise = Updatable
compiler/stgSyn/StgSubst.hs view
@@ -72,7 +72,7 @@ extendInScope id (Subst in_scope env) = Subst (in_scope `extendInScopeSet` id) env -- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the--- in-scope set is such that TyCORep Note [The substitution invariant]+-- in-scope set is such that TyCoSubst Note [The substitution invariant] -- holds after extending the substitution like this. extendSubst :: Id -> Id -> Subst -> Subst extendSubst id new_id (Subst in_scope env)
compiler/stgSyn/StgSyn.hs view
@@ -25,7 +25,7 @@ GenStgAlt, AltType(..), StgPass(..), BinderP, XRhsClosure, XLet, XLetNoEscape,- NoExtSilent, noExtSilent,+ NoExtFieldSilent, noExtFieldSilent, OutputablePass, UpdateFlag(..), isUpdatable,@@ -50,7 +50,7 @@ topStgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity, isDllConApp, stgArgType,- stripStgTicksTop,+ stripStgTicksTop, stripStgTicksTopE, stgCaseBndrInScope, pprStgBinding, pprGenStgTopBindings, pprStgTopBindings@@ -163,12 +163,18 @@ stgArgType (StgLitArg lit) = literalType lit --- | Strip ticks of a given type from an STG expression+-- | Strip ticks of a given type from an STG expression. stripStgTicksTop :: (Tickish Id -> Bool) -> GenStgExpr p -> ([Tickish Id], GenStgExpr p) stripStgTicksTop p = go [] where go ts (StgTick t e) | p t = go (t:ts) e go ts other = (reverse ts, other) +-- | Strip ticks of a given type from an STG expression returning only the expression.+stripStgTicksTopE :: (Tickish Id -> Bool) -> GenStgExpr p -> GenStgExpr p+stripStgTicksTopE p = go+ where go (StgTick t e) | p t = go e+ go other = other+ -- | Given an alt type and whether the program is unarised, return whether the -- case binder is in scope. --@@ -444,19 +450,19 @@ | LiftLams | CodeGen --- | Like 'HsExpression.NoExt', but with an 'Outputable' instance that returns--- 'empty'.-data NoExtSilent = NoExtSilent+-- | Like 'HsExtension.NoExtField', but with an 'Outputable' instance that+-- returns 'empty'.+data NoExtFieldSilent = NoExtFieldSilent deriving (Data, Eq, Ord) -instance Outputable NoExtSilent where+instance Outputable NoExtFieldSilent where ppr _ = empty -- | Used when constructing a term with an unused extension point that should -- not appear in pretty-printed output at all.-noExtSilent :: NoExtSilent-noExtSilent = NoExtSilent--- TODO: Maybe move this to HsExtensions? I'm not sure about the implications+noExtFieldSilent :: NoExtFieldSilent+noExtFieldSilent = NoExtFieldSilent+-- TODO: Maybe move this to HsExtension? I'm not sure about the implications -- on build time... -- TODO: Do we really want to the extension point type families to have a closed@@ -466,17 +472,17 @@ type instance BinderP 'CodeGen = Id type family XRhsClosure (pass :: StgPass)-type instance XRhsClosure 'Vanilla = NoExtSilent+type instance XRhsClosure 'Vanilla = NoExtFieldSilent -- | Code gen needs to track non-global free vars type instance XRhsClosure 'CodeGen = DIdSet type family XLet (pass :: StgPass)-type instance XLet 'Vanilla = NoExtSilent-type instance XLet 'CodeGen = NoExtSilent+type instance XLet 'Vanilla = NoExtFieldSilent+type instance XLet 'CodeGen = NoExtFieldSilent type family XLetNoEscape (pass :: StgPass)-type instance XLetNoEscape 'Vanilla = NoExtSilent-type instance XLetNoEscape 'CodeGen = NoExtSilent+type instance XLetNoEscape 'Vanilla = NoExtFieldSilent+type instance XLetNoEscape 'CodeGen = NoExtFieldSilent stgRhsArity :: StgRhs -> Int stgRhsArity (StgRhsClosure _ _ _ bndrs _)@@ -726,7 +732,7 @@ pprGenStgBinding (StgRec pairs) = vcat [ text "Rec {"- , vcat (map ppr_bind pairs)+ , vcat (intersperse blankLine (map ppr_bind pairs)) , text "end Rec }" ] where ppr_bind (bndr, expr)
compiler/typecheck/Inst.hs view
@@ -103,7 +103,7 @@ ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta ) instCall origin ty_args theta - ; return (mkHsWrap wrap (HsVar noExt (noLoc id))) }+ ; return (mkHsWrap wrap (HsVar noExtField (noLoc id))) } {- ************************************************************************@@ -534,7 +534,7 @@ = newNonTrivialOverloadedLit orig lit res_ty where orig = LiteralOrigin lit-newOverloadedLit XOverLit{} _ = panic "newOverloadedLit"+newOverloadedLit (XOverLit nec) _ = noExtCon nec -- Does not handle things that 'shortCutLit' can handle. See also -- newOverloadedLit in TcUnify@@ -566,7 +566,7 @@ mkOverLit (HsFractional r) = do { rat_ty <- tcMetaTy rationalTyConName- ; return (HsRat noExt r rat_ty) }+ ; return (HsRat noExtField r rat_ty) } mkOverLit (HsIsString src s) = return (HsString src s)
compiler/typecheck/TcAnnotations.hs view
@@ -66,7 +66,7 @@ where safeHsErr = vcat [ text "Annotations are not compatible with Safe Haskell." , text "See https://gitlab.haskell.org/ghc/ghc/issues/10826" ]-tcAnnotation (L _ (XAnnDecl _)) = panic "tcAnnotation"+tcAnnotation (L _ (XAnnDecl nec)) = noExtCon nec annProvenanceToTarget :: Module -> AnnProvenance Name -> AnnTarget Name
compiler/typecheck/TcArrows.hs view
@@ -126,7 +126,7 @@ do { cmd' <- tcCmd env cmd cmd_ty ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names') cmd') }-tcCmdTop _ (L _ XCmdTop{}) _ = panic "tcCmdTop"+tcCmdTop _ (L _ (XCmdTop nec)) _ = noExtCon nec ---------------------------------------- tcCmd :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTcId)@@ -254,7 +254,7 @@ tcPats LambdaExpr pats (map mkCheckExpType arg_tys) $ tc_grhss grhss cmd_stk' (mkCheckExpType res_ty) - ; let match' = L mtch_loc (Match { m_ext = noExt+ ; let match' = L mtch_loc (Match { m_ext = noExtField , m_ctxt = LambdaExpr, m_pats = pats' , m_grhss = grhss' }) arg_tys = map hsLPatType pats'@@ -271,14 +271,14 @@ = do { (binds', grhss') <- tcLocalBinds binds $ mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss ; return (GRHSs x grhss' (L l binds')) }- tc_grhss (XGRHSs _) _ _ = panic "tc_grhss"+ tc_grhss (XGRHSs nec) _ _ = noExtCon nec tc_grhs stk_ty res_ty (GRHS x guards body) = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $ \ res_ty -> tcCmd env body (stk_ty, checkingExpType "tc_grhs" res_ty) ; return (GRHS x guards' rhs') }- tc_grhs _ _ (XGRHS _) = panic "tc_grhs"+ tc_grhs _ _ (XGRHS nec) = noExtCon nec ------------------------------------------- -- Do notation@@ -323,7 +323,7 @@ ; cmd' <- tcCmdTop env' cmd (stk_ty, res_ty) ; return (cmd', mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) } -tc_cmd _ (XCmd {}) _ = panic "tc_cmd"+tc_cmd _ (XCmd nec) _ = noExtCon nec ----------------------------------------------------------------- -- Base case for illegal commands
compiler/typecheck/TcBinds.hs view
@@ -67,6 +67,7 @@ import ConLike import Control.Monad+import Data.Foldable (find) #include "HsVersions.h" @@ -359,17 +360,17 @@ ; ip_id <- newDict ipClass [ p, ty ] ; expr' <- tcMonoExpr expr (mkCheckExpType ty) ; let d = toDict ipClass p ty `fmap` expr'- ; return (ip_id, (IPBind noExt (Right ip_id) d)) }+ ; return (ip_id, (IPBind noExtField (Right ip_id) d)) } tc_ip_bind _ (IPBind _ (Right {}) _) = panic "tc_ip_bind"- tc_ip_bind _ (XIPBind _) = panic "tc_ip_bind"+ tc_ip_bind _ (XIPBind nec) = noExtCon nec -- Coerces a `t` into a dictionry for `IP "x" t`. -- co : t -> IP "x" t toDict ipClass x ty = mkHsWrap $ mkWpCastR $ wrapIP $ mkClassPred ipClass [x,ty] -tcLocalBinds (HsIPBinds _ (XHsIPBinds _ )) _ = panic "tcLocalBinds"-tcLocalBinds (XHsLocalBindsLR _) _ = panic "tcLocalBinds"+tcLocalBinds (HsIPBinds _ (XHsIPBinds nec)) _ = noExtCon nec+tcLocalBinds (XHsLocalBindsLR nec) _ = noExtCon nec {- Note [Implicit parameter untouchables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -485,12 +486,13 @@ -- (This used to be optional, but isn't now.) -- See Note [Polymorphic recursion] in HsBinds. do { traceTc "tc_group rec" (pprLHsBinds binds)- ; when hasPatSyn $ recursivePatSynErr binds+ ; whenIsJust mbFirstPatSyn $ \lpat_syn ->+ recursivePatSynErr (getLoc lpat_syn) binds ; (binds1, thing) <- go sccs ; return ([(Recursive, binds1)], thing) } -- Rec them all together where- hasPatSyn = anyBag (isPatSyn . unLoc) binds+ mbFirstPatSyn = find (isPatSyn . unLoc) binds isPatSyn PatSynBind{} = True isPatSyn _ = False @@ -511,10 +513,14 @@ tc_sub_group rec_tc binds = tcPolyBinds sig_fn prag_fn Recursive rec_tc closed binds -recursivePatSynErr :: OutputableBndrId (GhcPass p) =>- LHsBinds (GhcPass p) -> TcM a-recursivePatSynErr binds- = failWithTc $+recursivePatSynErr ::+ OutputableBndrId (GhcPass p) =>+ SrcSpan -- ^ The location of the first pattern synonym binding+ -- (for error reporting)+ -> LHsBinds (GhcPass p)+ -> TcM a+recursivePatSynErr loc binds+ = failAt loc $ hang (text "Recursive pattern synonym definition with following bindings:") 2 (vcat $ map pprLBind . bagToList $ binds) where@@ -720,14 +726,14 @@ , fun_ext = placeHolderNamesTc , fun_tick = tick } - export = ABE { abe_ext = noExt- , abe_wrap = idHsWrapper+ export = ABE { abe_ext = noExtField+ , abe_wrap = idHsWrapper , abe_poly = poly_id , abe_mono = mono_id , abe_prags = SpecPrags spec_prags } abs_bind = cL loc $- AbsBinds { abs_ext = noExt+ AbsBinds { abs_ext = noExtField , abs_tvs = skol_tvs , abs_ev_vars = ev_vars , abs_ev_binds = [ev_binds]@@ -810,7 +816,7 @@ ; loc <- getSrcSpanM ; let poly_ids = map abe_poly exports abs_bind = cL loc $- AbsBinds { abs_ext = noExt+ AbsBinds { abs_ext = noExtField , abs_tvs = qtvs , abs_ev_vars = givens, abs_ev_binds = [ev_binds] , abs_exports = exports, abs_binds = binds'@@ -871,7 +877,7 @@ ; when warn_missing_sigs $ localSigWarn Opt_WarnMissingLocalSignatures poly_id mb_sig - ; return (ABE { abe_ext = noExt+ ; return (ABE { abe_ext = noExtField , abe_wrap = wrap -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty) , abe_poly = poly_id
compiler/typecheck/TcClassDcl.hs view
@@ -284,12 +284,12 @@ tcPolyCheck no_prag_fn local_dm_sig (L bind_loc lm_bind) - ; let export = ABE { abe_ext = noExt+ ; let export = ABE { abe_ext = noExtField , abe_poly = global_dm_id , abe_mono = local_dm_id , abe_wrap = idHsWrapper , abe_prags = IsDefaultMethod }- full_bind = AbsBinds { abs_ext = noExt+ full_bind = AbsBinds { abs_ext = noExtField , abs_tvs = tyvars , abs_ev_vars = [this_dict] , abs_exports = [export]
compiler/typecheck/TcDefaults.hs view
@@ -66,7 +66,7 @@ tcDefaults decls@(L locn (DefaultDecl _ _) : _) = setSrcSpan locn $ failWithTc (dupDefaultDeclErr decls)-tcDefaults (L _ (XDefaultDecl _):_) = panic "tcDefaults"+tcDefaults (L _ (XDefaultDecl nec):_) = noExtCon nec tc_default_ty :: [Class] -> LHsType GhcRn -> TcM Type@@ -100,8 +100,8 @@ where pp (L locn (DefaultDecl _ _)) = text "here was another default declaration" <+> ppr locn- pp (L _ (XDefaultDecl _)) = panic "dupDefaultDeclErr"-dupDefaultDeclErr (L _ (XDefaultDecl _) : _) = panic "dupDefaultDeclErr"+ pp (L _ (XDefaultDecl nec)) = noExtCon nec+dupDefaultDeclErr (L _ (XDefaultDecl nec) : _) = noExtCon nec dupDefaultDeclErr [] = panic "dupDefaultDeclErr []" badDefaultTy :: Type -> [Class] -> SDoc
compiler/typecheck/TcDeriv.hs view
@@ -9,7 +9,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} -module TcDeriv ( tcDeriving, DerivInfo(..), mkDerivInfos ) where+module TcDeriv ( tcDeriving, DerivInfo(..) ) where #include "HsVersions.h" @@ -23,7 +23,7 @@ import TcDerivInfer import TcDerivUtils import TcValidity( allDistinctTyVars )-import TcClassDcl( instDeclCtxt3, tcATDefault, tcMkDeclCtxt )+import TcClassDcl( instDeclCtxt3, tcATDefault ) import TcEnv import TcGenDeriv -- Deriv stuff import TcValidity( checkValidInstHead )@@ -199,19 +199,6 @@ , di_ctxt :: SDoc -- ^ error context } --- | Extract `deriving` clauses of proper data type (skips data families)-mkDerivInfos :: [LTyClDecl GhcRn] -> TcM [DerivInfo]-mkDerivInfos decls = concatMapM (mk_deriv . unLoc) decls- where-- mk_deriv decl@(DataDecl { tcdLName = L _ data_name- , tcdDataDefn =- HsDataDefn { dd_derivs = L _ clauses } })- = do { tycon <- tcLookupTyCon data_name- ; return [DerivInfo { di_rep_tc = tycon, di_clauses = clauses- , di_ctxt = tcMkDeclCtxt decl }] }- mk_deriv _ = return []- {- ************************************************************************@@ -342,7 +329,7 @@ -- before renaming the instances themselves ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)) ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds- ; let aux_val_binds = ValBinds noExt aux_binds (bagToList aux_sigs)+ ; let aux_val_binds = ValBinds noExtField aux_binds (bagToList aux_sigs) ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds ; let bndrs = collectHsValBinders rn_aux_lhs ; envs <- extendGlobalRdrEnvRn (map avail bndrs) emptyFsEnv ;@@ -505,21 +492,16 @@ -> [LDerivDecl GhcRn] -> TcM [EarlyDerivSpec] makeDerivSpecs is_boot deriv_infos deriv_decls- = do { -- We carefully set up uses of recoverM to minimize error message- -- cascades. See Note [Flattening deriving clauses].- ; eqns1 <- sequenceA- [ recoverM (pure Nothing)- (deriveClause rep_tc (fmap unLoc dcs)- pred err_ctxt)+ = do { eqns1 <- sequenceA+ [ deriveClause rep_tc dcs preds err_ctxt | DerivInfo { di_rep_tc = rep_tc, di_clauses = clauses , di_ctxt = err_ctxt } <- deriv_infos , L _ (HsDerivingClause { deriv_clause_strategy = dcs , deriv_clause_tys = L _ preds }) <- clauses- , pred <- preds ] ; eqns2 <- mapM (recoverM (pure Nothing) . deriveStandalone) deriv_decls- ; let eqns = catMaybes (eqns1 ++ eqns2)+ ; let eqns = concat eqns1 ++ catMaybes eqns2 ; if is_boot then -- No 'deriving' at all in hs-boot files do { unless (null eqns) (add_deriv_err (head eqns))@@ -531,9 +513,116 @@ addErr (hang (text "Deriving not permitted in hs-boot file") 2 (text "Use an instance declaration instead")) +------------------------------------------------------------------+-- | Process the derived classes in a single @deriving@ clause.+deriveClause :: TyCon -> Maybe (LDerivStrategy GhcRn)+ -> [LHsSigType GhcRn] -> SDoc+ -> TcM [EarlyDerivSpec]+deriveClause rep_tc mb_lderiv_strat deriv_preds err_ctxt+ = addErrCtxt err_ctxt $ do+ traceTc "deriveClause" $ vcat+ [ text "tvs" <+> ppr tvs+ , text "tc" <+> ppr tc+ , text "tys" <+> ppr tys+ , text "mb_lderiv_strat" <+> ppr mb_lderiv_strat ]+ tcExtendTyVarEnv tvs $ do+ (mb_lderiv_strat', via_tvs) <- tcDerivStrategy mb_lderiv_strat+ tcExtendTyVarEnv via_tvs $+ -- Moreover, when using DerivingVia one can bind type variables in+ -- the `via` type as well, so these type variables must also be+ -- brought into scope.+ mapMaybeM (derivePred tc tys mb_lderiv_strat' via_tvs) deriv_preds+ -- After typechecking the `via` type once, we then typecheck all+ -- of the classes associated with that `via` type in the+ -- `deriving` clause.+ -- See also Note [Don't typecheck too much in DerivingVia].+ where+ tvs = tyConTyVars rep_tc+ (tc, tys) = case tyConFamInstSig_maybe rep_tc of+ -- data family:+ Just (fam_tc, pats, _) -> (fam_tc, pats)+ -- NB: deriveTyData wants the *user-specified*+ -- name. See Note [Why we don't pass rep_tc into deriveTyData]++ _ -> (rep_tc, mkTyVarTys tvs) -- datatype++-- | Process a single predicate in a @deriving@ clause.+--+-- This returns a 'Maybe' because the user might try to derive 'Typeable',+-- which is a no-op nowadays.+derivePred :: TyCon -> [Type] -> Maybe (LDerivStrategy GhcTc) -> [TyVar]+ -> LHsSigType GhcRn -> TcM (Maybe EarlyDerivSpec)+derivePred tc tys mb_lderiv_strat via_tvs deriv_pred =+ -- We carefully set up uses of recoverM to minimize error message+ -- cascades. See Note [Recovering from failures in deriving clauses].+ recoverM (pure Nothing) $+ setSrcSpan (getLoc (hsSigType deriv_pred)) $ do+ traceTc "derivePred" $ vcat+ [ text "tc" <+> ppr tc+ , text "tys" <+> ppr tys+ , text "deriv_pred" <+> ppr deriv_pred+ , text "mb_lderiv_strat" <+> ppr mb_lderiv_strat+ , text "via_tvs" <+> ppr via_tvs ]+ (cls_tvs, cls, cls_tys, cls_arg_kinds) <- tcHsDeriv deriv_pred+ when (cls_arg_kinds `lengthIsNot` 1) $+ failWithTc (nonUnaryErr deriv_pred)+ let [cls_arg_kind] = cls_arg_kinds+ mb_deriv_strat = fmap unLoc mb_lderiv_strat+ if (className cls == typeableClassName)+ then do warnUselessTypeable+ return Nothing+ else let deriv_tvs = via_tvs ++ cls_tvs in+ Just <$> deriveTyData tc tys mb_deriv_strat+ deriv_tvs cls cls_tys cls_arg_kind+ {--Note [Flattening deriving clauses]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Don't typecheck too much in DerivingVia]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following example:++ data D = ...+ deriving (A1 t, ..., A20 t) via T t++GHC used to be engineered such that it would typecheck the `deriving`+clause like so:++1. Take the first class in the clause (`A1`).+2. Typecheck the `via` type (`T t`) and bring its bound type variables+ into scope (`t`).+3. Typecheck the class (`A1`).+4. Move on to the next class (`A2`) and repeat the process until all+ classes have been typechecked.++This algorithm gets the job done most of the time, but it has two notable+flaws. One flaw is that it is wasteful: it requires that `T t` be typechecked+20 different times, once for each class in the `deriving` clause. This is+unnecessary because we only need to typecheck `T t` once in order to get+access to its bound type variable.++The other issue with this algorithm arises when there are no classes in the+`deriving` clause, like in the following example:++ data D2 = ...+ deriving () via Maybe Maybe++Because there are no classes, the algorithm above will simply do nothing.+As a consequence, GHC will completely miss the fact that `Maybe Maybe`+is ill-kinded nonsense (#16923).++To address both of these problems, GHC now uses this algorithm instead:++1. Typecheck the `via` type and bring its boudn type variables into scope.+2. Take the first class in the `deriving` clause.+3. Typecheck the class.+4. Move on to the next class and repeat the process until all classes have been+ typechecked.++This algorithm ensures that the `via` type is always typechecked, even if there+are no classes in the `deriving` clause. Moreover, it typecheck the `via` type+/exactly/ once and no more, even if there are multiple classes in the clause.++Note [Recovering from failures in deriving clauses]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider what happens if you run this program (from #10684) without DeriveGeneric enabled: @@ -556,56 +645,32 @@ This was happening because when GHC encountered any error within a single data type's set of deriving clauses, it would call recoverM and move on to the next data type's deriving clauses. One unfortunate consequence of-this design is that if A's derived Generic instance failed, so its derived+this design is that if A's derived Generic instance failed, its derived Show instance would be skipped entirely, leading to the "No instance for (Show A)" error cascade. -The solution to this problem is to "flatten" the set of classes that are-derived for a particular data type via deriving clauses. That is, if-you have:+The solution to this problem is to push through uses of recoverM to the+level of the individual derived classes in a particular data type's set of+deriving clauses. That is, if you have: newtype C = C D deriving (E, F, G)- deriving anyclass (H, I, J)- deriving newtype (K, L, M) Then instead of processing instances E through M under the scope of a single-recoverM, we flatten these deriving clauses into the list:+recoverM, as in the following pseudocode: - [ E (Nothing)- , F (Nothing)- , G (Nothing)- , H (Just anyclass)- , I (Just anyclass)- , J (Just anyclass)- , K (Just newtype)- , L (Just newtype)- , M (Just newtype) ]+ recoverM (pure Nothing) $ mapM derivePred [E, F, G] +We instead use recoverM in each iteration of the loop:++ mapM (recoverM (pure Nothing) . derivePred) [E, F, G]+ And then process each class individually, under its own recoverM scope. That way, failure to derive one class doesn't cancel out other classes in the same set of clause-derived classes. -} --------------------------------------------------------------------- | Process a single class in a `deriving` clause.-deriveClause :: TyCon -> Maybe (DerivStrategy GhcRn)- -> LHsSigType GhcRn -> SDoc- -> TcM (Maybe EarlyDerivSpec)-deriveClause rep_tc mb_strat pred err_ctxt- = addErrCtxt err_ctxt $- deriveTyData tvs tc tys mb_strat pred- where- tvs = tyConTyVars rep_tc- (tc, tys) = case tyConFamInstSig_maybe rep_tc of- -- data family:- Just (fam_tc, pats, _) -> (fam_tc, pats)- -- NB: deriveTyData wants the *user-specified*- -- name. See Note [Why we don't pass rep_tc into deriveTyData]-- _ -> (rep_tc, mkTyVarTys tvs) -- datatype-------------------------------------------------------------------- deriveStandalone :: LDerivDecl GhcRn -> TcM (Maybe EarlyDerivSpec) -- Process a single standalone deriving declaration -- e.g. deriving instance Show a => Show (T a)@@ -613,29 +678,29 @@ -- -- This returns a Maybe because the user might try to derive Typeable, which is -- a no-op nowadays.-deriveStandalone (L loc (DerivDecl _ deriv_ty mbl_deriv_strat overlap_mode))+deriveStandalone (L loc (DerivDecl _ deriv_ty mb_lderiv_strat overlap_mode)) = setSrcSpan loc $ addErrCtxt (standaloneCtxt deriv_ty) $ do { traceTc "Standalone deriving decl for" (ppr deriv_ty)- ; let mb_deriv_strat = fmap unLoc mbl_deriv_strat- ctxt = TcType.InstDeclCtxt True+ ; let ctxt = TcType.InstDeclCtxt True ; traceTc "Deriving strategy (standalone deriving)" $- vcat [ppr mb_deriv_strat, ppr deriv_ty]- ; (mb_deriv_strat', tvs', (deriv_ctxt', cls, inst_tys'))- <- tcDerivStrategy mb_deriv_strat $ do- (tvs, deriv_ctxt, cls, inst_tys)- <- tcStandaloneDerivInstType ctxt deriv_ty- pure (tvs, (deriv_ctxt, cls, inst_tys))- ; checkTc (not (null inst_tys')) derivingNullaryErr- ; let inst_ty' = last inst_tys'+ vcat [ppr mb_lderiv_strat, ppr deriv_ty]+ ; (mb_lderiv_strat, via_tvs) <- tcDerivStrategy mb_lderiv_strat+ ; (cls_tvs, deriv_ctxt, cls, inst_tys)+ <- tcExtendTyVarEnv via_tvs $+ tcStandaloneDerivInstType ctxt deriv_ty+ ; checkTc (not (null inst_tys)) derivingNullaryErr+ ; let mb_deriv_strat = fmap unLoc mb_lderiv_strat+ tvs = via_tvs ++ cls_tvs+ inst_ty = last inst_tys -- See Note [Unify kinds in deriving]- ; (tvs, deriv_ctxt, inst_tys) <-- case mb_deriv_strat' of+ ; (tvs', deriv_ctxt', inst_tys', mb_deriv_strat') <-+ case mb_deriv_strat of -- Perform an additional unification with the kind of the `via` -- type and the result of the previous kind unification. Just (ViaStrategy via_ty) -> do let via_kind = tcTypeKind via_ty- inst_ty_kind = tcTypeKind inst_ty'+ inst_ty_kind = tcTypeKind inst_ty mb_match = tcUnifyTy inst_ty_kind via_kind checkTc (isJust mb_match)@@ -647,38 +712,42 @@ -- See Note [Unification of two kind variables in deriving] unmapped_tkvs = filter (\v -> v `notElemTCvSubst` kind_subst && not (v `elemVarSet` ki_subst_range))- tvs'+ tvs (subst, _) = substTyVarBndrs kind_subst unmapped_tkvs (final_deriv_ctxt, final_deriv_ctxt_tys)- = case deriv_ctxt' of+ = case deriv_ctxt of InferContext wc -> (InferContext wc, []) SupplyContext theta -> let final_theta = substTheta subst theta in (SupplyContext final_theta, final_theta)- final_inst_tys = substTys subst inst_tys'+ final_inst_tys = substTys subst inst_tys+ final_via_ty = substTy subst via_ty+ -- See Note [Floating `via` type variables] final_tvs = tyCoVarsOfTypesWellScoped $ final_deriv_ctxt_tys ++ final_inst_tys- pure (final_tvs, final_deriv_ctxt, final_inst_tys)+ ++ [final_via_ty]+ pure ( final_tvs, final_deriv_ctxt, final_inst_tys+ , Just (ViaStrategy final_via_ty) ) - _ -> pure (tvs', deriv_ctxt', inst_tys')- ; let cls_tys = take (length inst_tys - 1) inst_tys- inst_ty = last inst_tys+ _ -> pure (tvs, deriv_ctxt, inst_tys, mb_deriv_strat)+ ; let cls_tys' = take (length inst_tys' - 1) inst_tys'+ inst_ty' = last inst_tys' ; traceTc "Standalone deriving;" $ vcat- [ text "tvs:" <+> ppr tvs- , text "mb_deriv_strat:" <+> ppr mb_deriv_strat'- , text "deriv_ctxt:" <+> ppr deriv_ctxt+ [ text "tvs':" <+> ppr tvs'+ , text "mb_deriv_strat':" <+> ppr mb_deriv_strat'+ , text "deriv_ctxt':" <+> ppr deriv_ctxt' , text "cls:" <+> ppr cls- , text "tys:" <+> ppr inst_tys ]+ , text "inst_tys':" <+> ppr inst_tys' ] -- C.f. TcInstDcls.tcLocalInstDecl1 ; traceTc "Standalone deriving:" $ vcat [ text "class:" <+> ppr cls- , text "class types:" <+> ppr cls_tys- , text "type:" <+> ppr inst_ty ]+ , text "class types:" <+> ppr cls_tys'+ , text "type:" <+> ppr inst_ty' ] - ; let bale_out msg = failWithTc (derivingThingErr False cls cls_tys- inst_ty mb_deriv_strat' msg)+ ; let bale_out msg = failWithTc (derivingThingErr False cls cls_tys'+ inst_ty' mb_deriv_strat' msg) - ; case tcSplitTyConApp_maybe inst_ty of+ ; case tcSplitTyConApp_maybe inst_ty' of Just (tc, tc_args) | className cls == typeableClassName -> do warnUselessTypeable@@ -686,14 +755,14 @@ | otherwise -> Just <$> mkEqnHelp (fmap unLoc overlap_mode)- tvs cls cls_tys tc tc_args- deriv_ctxt mb_deriv_strat'+ tvs' cls cls_tys' tc tc_args+ deriv_ctxt' mb_deriv_strat' _ -> -- Complain about functions, primitive types, etc, bale_out $ text "The last argument of the instance must be a data or newtype application" }-deriveStandalone (L _ (XDerivDecl _)) = panic "deriveStandalone"+deriveStandalone (L _ (XDerivDecl nec)) = noExtCon nec -- Typecheck the type in a standalone deriving declaration. --@@ -729,7 +798,7 @@ = L (getLoc deriv_ty_body) $ HsForAllTy { hst_fvf = ForallInvis , hst_bndrs = tvs- , hst_xforall = noExt+ , hst_xforall = noExtField , hst_body = rho }} let (tvs, _theta, cls, inst_tys) = tcSplitDFunTy dfun_ty pure (tvs, InferContext (Just wc_span), cls, inst_tys)@@ -738,10 +807,10 @@ let (tvs, theta, cls, inst_tys) = tcSplitDFunTy dfun_ty pure (tvs, SupplyContext theta, cls, inst_tys) -tcStandaloneDerivInstType _ (HsWC _ (XHsImplicitBndrs _))- = panic "tcStandaloneDerivInstType"-tcStandaloneDerivInstType _ (XHsWildCardBndrs _)- = panic "tcStandaloneDerivInstType"+tcStandaloneDerivInstType _ (HsWC _ (XHsImplicitBndrs nec))+ = noExtCon nec+tcStandaloneDerivInstType _ (XHsWildCardBndrs nec)+ = noExtCon nec warnUselessTypeable :: TcM () warnUselessTypeable@@ -751,42 +820,22 @@ text "has no effect: all types now auto-derive Typeable" } -------------------------------------------------------------------deriveTyData :: [TyVar] -> TyCon -> [Type] -- LHS of data or data instance+deriveTyData :: TyCon -> [Type] -- LHS of data or data instance -- Can be a data instance, hence [Type] args -- and in that case the TyCon is the /family/ tycon- -> Maybe (DerivStrategy GhcRn) -- The optional deriving strategy- -> LHsSigType GhcRn -- The deriving predicate- -> TcM (Maybe EarlyDerivSpec)+ -> Maybe (DerivStrategy GhcTc) -- The optional deriving strategy+ -> [TyVar] -- The type variables bound by the derived class+ -> Class -- The derived class+ -> [Type] -- The derived class's arguments+ -> Kind -- The function argument in the derived class's kind.+ -- (e.g., if `deriving Functor`, this would be+ -- `Type -> Type` since+ -- `Functor :: (Type -> Type) -> Constraint`)+ -> TcM EarlyDerivSpec -- The deriving clause of a data or newtype declaration -- I.e. not standalone deriving------ This returns a Maybe because the user might try to derive Typeable, which is--- a no-op nowadays.-deriveTyData tvs tc tc_args mb_deriv_strat deriv_pred- = setSrcSpan (getLoc (hsSigType deriv_pred)) $- -- Use loc of the 'deriving' item- do { (mb_deriv_strat', deriv_tvs, (cls, cls_tys, cls_arg_kinds))- <- tcExtendTyVarEnv tvs $- -- Deriving preds may (now) mention- -- the type variables for the type constructor, hence tcExtendTyVarenv- -- The "deriv_pred" is a LHsType to take account of the fact that for- -- newtype deriving we allow deriving (forall a. C [a]).-- -- Typeable is special, because Typeable :: forall k. k -> Constraint- -- so the argument kind 'k' is not decomposable by splitKindFunTys- -- as is the case for all other derivable type classes- tcDerivStrategy mb_deriv_strat $- tcHsDeriv deriv_pred-- ; when (cls_arg_kinds `lengthIsNot` 1) $- failWithTc (nonUnaryErr deriv_pred)- ; let [cls_arg_kind] = cls_arg_kinds- ; if className cls == typeableClassName- then do warnUselessTypeable- return Nothing- else-- do { -- Given data T a b c = ... deriving( C d ),+deriveTyData tc tc_args mb_deriv_strat deriv_tvs cls cls_tys cls_arg_kind+ = do { -- Given data T a b c = ... deriving( C d ), -- we want to drop type variables from T so that (C d (T a)) is well-kinded let (arg_kinds, _) = splitFunTys cls_arg_kind n_args_to_drop = length arg_kinds@@ -806,68 +855,69 @@ ; checkTc (enough_args && isJust mb_match) (derivingKindErr tc cls cls_tys cls_arg_kind enough_args) - ; let propagate_subst kind_subst tkvs' cls_tys' tc_args'- = (final_tkvs, final_cls_tys, final_tc_args)+ ; let -- Returns a singleton-element list if using ViaStrategy and an+ -- empty list otherwise. Useful for free-variable calculations.+ deriv_strat_tys :: Maybe (DerivStrategy GhcTc) -> [Type]+ deriv_strat_tys = foldMap (foldDerivStrategy [] (:[]))++ propagate_subst kind_subst tkvs' cls_tys' tc_args' mb_deriv_strat'+ = (final_tkvs, final_cls_tys, final_tc_args, final_mb_deriv_strat) where ki_subst_range = getTCvSubstRangeFVs kind_subst -- See Note [Unification of two kind variables in deriving] unmapped_tkvs = filter (\v -> v `notElemTCvSubst` kind_subst && not (v `elemVarSet` ki_subst_range)) tkvs'- (subst, _) = substTyVarBndrs kind_subst unmapped_tkvs- final_tc_args = substTys subst tc_args'- final_cls_tys = substTys subst cls_tys'- final_tkvs = tyCoVarsOfTypesWellScoped $- final_cls_tys ++ final_tc_args+ (subst, _) = substTyVarBndrs kind_subst unmapped_tkvs+ final_tc_args = substTys subst tc_args'+ final_cls_tys = substTys subst cls_tys'+ final_mb_deriv_strat = fmap (mapDerivStrategy (substTy subst))+ mb_deriv_strat'+ -- See Note [Floating `via` type variables]+ final_tkvs = tyCoVarsOfTypesWellScoped $+ final_cls_tys ++ final_tc_args+ ++ deriv_strat_tys final_mb_deriv_strat ; let tkvs = scopedSort $ fvVarList $ unionFV (tyCoFVsOfTypes tc_args_to_keep) (FV.mkFVs deriv_tvs) Just kind_subst = mb_match- (tkvs', final_cls_tys', final_tc_args')- = propagate_subst kind_subst tkvs cls_tys tc_args_to_keep+ (tkvs', cls_tys', tc_args', mb_deriv_strat')+ = propagate_subst kind_subst tkvs cls_tys+ tc_args_to_keep mb_deriv_strat -- See Note [Unify kinds in deriving]- ; (tkvs, final_cls_tys, final_tc_args, final_mb_deriv_strat) <-+ ; (final_tkvs, final_cls_tys, final_tc_args, final_mb_deriv_strat) <- case mb_deriv_strat' of -- Perform an additional unification with the kind of the `via` -- type and the result of the previous kind unification. Just (ViaStrategy via_ty) -> do- let final_via_ty = via_ty- final_via_kind = tcTypeKind final_via_ty- final_inst_ty_kind- = tcTypeKind (mkTyConApp tc final_tc_args')- via_match = tcUnifyTy final_inst_ty_kind final_via_kind+ let via_kind = tcTypeKind via_ty+ inst_ty_kind+ = tcTypeKind (mkTyConApp tc tc_args')+ via_match = tcUnifyTy inst_ty_kind via_kind checkTc (isJust via_match)- (derivingViaKindErr cls final_inst_ty_kind- final_via_ty final_via_kind)+ (derivingViaKindErr cls inst_ty_kind via_ty via_kind) let Just via_subst = via_match- (final_tkvs, final_cls_tys, final_tc_args)- = propagate_subst via_subst tkvs'- final_cls_tys' final_tc_args'- pure ( final_tkvs, final_cls_tys, final_tc_args- , Just $ ViaStrategy $ substTy via_subst via_ty- )-- _ -> pure ( tkvs', final_cls_tys', final_tc_args'- , mb_deriv_strat' )+ pure $ propagate_subst via_subst tkvs' cls_tys'+ tc_args' mb_deriv_strat' - ; traceTc "Deriving strategy (deriving clause)" $- vcat [ppr final_mb_deriv_strat, ppr deriv_pred]+ _ -> pure (tkvs', cls_tys', tc_args', mb_deriv_strat') - ; traceTc "derivTyData1" (vcat [ pprTyVars tvs, ppr tc, ppr tc_args- , ppr deriv_pred- , pprTyVars (tyCoVarsOfTypesList tc_args)- , ppr n_args_to_keep, ppr n_args_to_drop- , ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match- , ppr final_tc_args, ppr final_cls_tys ])+ ; traceTc "deriveTyData 1" $ vcat+ [ ppr final_mb_deriv_strat, pprTyVars deriv_tvs, ppr tc, ppr tc_args+ , pprTyVars (tyCoVarsOfTypesList tc_args)+ , ppr n_args_to_keep, ppr n_args_to_drop+ , ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match+ , ppr final_tc_args, ppr final_cls_tys ] - ; traceTc "derivTyData2" (vcat [ ppr tkvs ])+ ; traceTc "deriveTyData 2" $ vcat+ [ ppr final_tkvs ] ; let final_tc_app = mkTyConApp tc final_tc_args- ; checkTc (allDistinctTyVars (mkVarSet tkvs) args_to_drop) -- (a, b, c)+ ; checkTc (allDistinctTyVars (mkVarSet final_tkvs) args_to_drop) -- (a, b, c) (derivingEtaErr cls final_cls_tys final_tc_app) -- Check that -- (a) The args to drop are all type variables; eg reject:@@ -889,11 +939,11 @@ -- Check that we aren't deriving an instance of a magical -- type like (~) or Coercible (#14916). - ; spec <- mkEqnHelp Nothing tkvs+ ; spec <- mkEqnHelp Nothing final_tkvs cls final_cls_tys tc final_tc_args (InferContext Nothing) final_mb_deriv_strat- ; traceTc "derivTyData" (ppr spec)- ; return $ Just spec } }+ ; traceTc "deriveTyData 3" (ppr spec)+ ; return spec } {- Note [tc_args and tycon arity]@@ -1094,6 +1144,73 @@ fail to derive Functor, even though the code above is correct (see #11416, where this was first noticed). For this reason, we expand the type synonyms in the eta-reduced types before doing any analysis.++Note [Floating `via` type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When generating a derived instance, it will be of the form:++ instance forall ???. C c_args (D d_args) where ...++To fill in ???, GHC computes the free variables of `c_args` and `d_args`.+`DerivingVia` adds an extra wrinkle to this formula, since we must also+include the variables bound by the `via` type when computing the binders+used to fill in ???. This might seem strange, since if a `via` type binds+any type variables, then in almost all scenarios it will appear free in+`c_args` or `d_args`. There are certain corner cases where this does not hold,+however, such as in the following example (adapted from #15831):++ newtype Age = MkAge Int+ deriving Eq via Const Int a++In this example, the `via` type binds the type variable `a`, but `a` appears+nowhere in `Eq Age`. Nevertheless, we include it in the generated instance:++ instance forall a. Eq Age where+ (==) = coerce @(Const Int a -> Const Int a -> Bool)+ @(Age -> Age -> Bool)+ (==)++The use of `forall a` is certainly required here, since the `a` in+`Const Int a` would not be in scope otherwise. This instance is somewhat+strange in that nothing in the instance head `Eq Age` ever determines what `a`+will be, so any code that uses this instance will invariably instantiate `a`+to be `Any`. We refer to this property of `a` as being a "floating" `via`+type variable. Programs with floating `via` type variables are the only known+class of program in which the `via` type quantifies type variables that aren't+mentioned in the instance head in the generated instance.++Fortunately, the choice to instantiate floating `via` type variables to `Any`+is one that is completely transparent to the user (since the instance will+work as expected regardless of what `a` is instantiated to), so we decide to+permit them. An alternative design would make programs with floating `via`+variables illegal, by requiring that every variable mentioned in the `via` type+is also mentioned in the data header or the derived class. That restriction+would require the user to pick a particular type (the choice does not matter);+for example:++ newtype Age = MkAge Int+ -- deriving Eq via Const Int a -- Floating 'a'+ deriving Eq via Const Int () -- Choose a=()+ deriving Eq via Const Int Any -- Choose a=Any++No expressiveness would be lost thereby, but stylistically it seems preferable+to allow a type variable to indicate "it doesn't matter".++Note that by quantifying the `a` in `forall a. Eq Age`, we are deferring the+work of instantiating `a` to `Any` at every use site of the instance. An+alternative approach would be to generate an instance that directly defaulted+to `Any`:++ instance Eq Age where+ (==) = coerce @(Const Int Any -> Const Int Any -> Bool)+ @(Age -> Age -> Bool)+ (==)++We do not implement this approach since it would require a nontrivial amount+of implementation effort to substitute `Any` for the floating `via` type+variables, and since the end result isn't distinguishable from the former+instance (at least from the user's perspective), the amount of engineering+required to obtain the latter instance just isn't worth it. -} mkEqnHelp :: Maybe OverlapMode
compiler/typecheck/TcEnv.hs view
@@ -706,18 +706,18 @@ get_cons (L _ (DataFamInstD { dfid_inst = fid })) = get_fi_cons fid get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } })) = concatMap (get_fi_cons . unLoc) fids- get_cons (L _ (ClsInstD _ (XClsInstDecl _))) = panic "get_cons"- get_cons (L _ (XInstDecl _)) = panic "get_cons"+ get_cons (L _ (ClsInstD _ (XClsInstDecl nec))) = noExtCon nec+ get_cons (L _ (XInstDecl nec)) = noExtCon nec get_fi_cons :: DataFamInstDecl GhcRn -> [Name] get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons } }}}) = map unLoc $ concatMap (getConNames . unLoc) cons get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =- FamEqn { feqn_rhs = XHsDataDefn _ }}})- = panic "get_fi_cons"- get_fi_cons (DataFamInstDecl (HsIB _ (XFamEqn _))) = panic "get_fi_cons"- get_fi_cons (DataFamInstDecl (XHsImplicitBndrs _)) = panic "get_fi_cons"+ FamEqn { feqn_rhs = XHsDataDefn nec }}})+ = noExtCon nec+ get_fi_cons (DataFamInstDecl (HsIB _ (XFamEqn nec))) = noExtCon nec+ get_fi_cons (DataFamInstDecl (XHsImplicitBndrs nec)) = noExtCon nec tcAddPatSynPlaceholders :: [PatSynBind GhcRn GhcRn] -> TcM a -> TcM a
compiler/typecheck/TcExpr.hs view
@@ -56,6 +56,7 @@ import RdrName import TyCon import TyCoRep+import TyCoSubst (substTyWithInScope) import Type import TcEvidence import VarSet@@ -211,7 +212,7 @@ ; ipClass <- tcLookupClass ipClassName ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty]) ; tcWrapResult e- (fromDict ipClass ip_name ip_ty (HsVar noExt (noLoc ip_var)))+ (fromDict ipClass ip_name ip_ty (HsVar noExtField (noLoc ip_var))) ip_ty res_ty } where -- Coerces a dictionary for `IP "x" t` into `t`.@@ -230,7 +231,7 @@ ; loc <- getSrcSpanM ; var <- emitWantedEvVar origin pred ; tcWrapResult e- (fromDict pred (HsVar noExt (L loc var)))+ (fromDict pred (HsVar noExtField (L loc var))) alpha res_ty } } where -- Coerces a dictionary for `IsLabel "x" t` into `t`,@@ -240,9 +241,9 @@ lbl = mkStrLitTy l applyFromLabel loc fromLabel =- HsAppType noExt- (L loc (HsVar noExt (L loc fromLabel)))- (mkEmptyWildCardBndrs (L loc (HsTyLit noExt (HsStrTy NoSourceText l))))+ HsAppType noExtField+ (L loc (HsVar noExtField (L loc fromLabel)))+ (mkEmptyWildCardBndrs (L loc (HsTyLit noExtField (HsStrTy NoSourceText l)))) tcExpr (HsLam x match) res_ty = do { (match', wrap) <- tcMatchLambda herald match_ctxt match res_ty@@ -271,7 +272,7 @@ ; sig_info <- checkNoErrs $ -- Avoid error cascade tcUserTypeSig loc sig_ty Nothing ; (expr', poly_ty) <- tcExprSig expr sig_info- ; let expr'' = ExprWithTySig noExt expr' sig_ty+ ; let expr'' = ExprWithTySig noExtField expr' sig_ty ; tcWrapResult e expr'' poly_ty res_ty } {-@@ -361,7 +362,7 @@ ; arg2_ty <- readExpType arg2_exp_ty ; op_id <- tcLookupId op_name ; let op' = L loc (mkHsWrap (mkWpTyApps [arg1_ty, arg2_ty])- (HsVar noExt (L lv op_id)))+ (HsVar noExtField (L lv op_id))) ; return $ OpApp fix arg1' op' arg2' } | (L loc (HsVar _ (L lv op_name))) <- op@@ -399,7 +400,7 @@ ; let op' = L loc (mkHsWrap (mkWpTyApps [ getRuntimeRep op_res_ty , arg2_sigma , op_res_ty])- (HsVar noExt (L lv op_id)))+ (HsVar noExtField (L lv op_id))) -- arg1' :: arg1_ty -- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty) -- op' :: (a2_ty -> op_res_ty) -> a2_ty -> op_res_ty@@ -413,7 +414,7 @@ -- See Note [Disambiguating record fields] = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty ; sel_name <- disambiguateSelector lbl sig_tc_ty- ; let op' = L loc (HsRecFld noExt (Unambiguous sel_name lbl))+ ; let op' = L loc (HsRecFld noExtField (Unambiguous sel_name lbl)) ; tcExpr (OpApp fix arg1 op' arg2) res_ty } @@ -636,7 +637,7 @@ [p_ty] ; let wrap = mkWpTyApps [expr_ty] ; loc <- getSrcSpanM- ; return $ mkHsWrapCo co $ HsApp noExt+ ; return $ mkHsWrapCo co $ HsApp noExtField (L loc $ mkHsWrap wrap fromStaticPtr) (L loc (HsStatic fvs expr')) }@@ -1096,7 +1097,7 @@ wrapHsArgs f [] = f wrapHsArgs f (HsValArg a : args) = wrapHsArgs (mkHsApp f a) args wrapHsArgs f (HsTypeArg _ t : args) = wrapHsArgs (mkHsAppType f t) args-wrapHsArgs f (HsArgPar sp : args) = wrapHsArgs (L sp $ HsPar noExt f) args+wrapHsArgs f (HsArgPar sp : args) = wrapHsArgs (L sp $ HsPar noExtField f) args isHsValArg :: HsArg tm ty -> Bool isHsValArg (HsValArg {}) = True@@ -1164,7 +1165,7 @@ ; let [alpha, beta] = mkTemplateTyVars [liftedTypeKind, tYPE rep] seq_ty = mkSpecForAllTys [alpha,beta] (mkTyVarTy alpha `mkVisFunTy` mkTyVarTy beta `mkVisFunTy` mkTyVarTy beta)- seq_fun = L loc (HsVar noExt (L loc seqId))+ seq_fun = L loc (HsVar noExtField (L loc seqId)) -- seq_ty = forall (a:*) (b:TYPE r). a -> b -> b -- where 'r' is a meta type variable ; tcFunApp m_herald fun seq_fun seq_ty args res_ty }@@ -1419,7 +1420,7 @@ go (L l (Missing {}), arg_ty) = return (L l (Missing arg_ty)) go (L l (Present x expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty ; return (L l (Present x expr')) }- go (L _ (XTupArg{}), _) = panic "tcTupArgs"+ go (L _ (XTupArg nec), _) = noExtCon nec --------------------------- -- See TcType.SyntaxOpType also for commentary@@ -1721,14 +1722,14 @@ tcCheckId name res_ty = do { (expr, actual_res_ty) <- tcInferId name ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty])- ; addFunResCtxt False (HsVar noExt (noLoc name)) actual_res_ty res_ty $- tcWrapResultO (OccurrenceOf name) (HsVar noExt (noLoc name)) expr+ ; addFunResCtxt False (HsVar noExtField (noLoc name)) actual_res_ty res_ty $+ tcWrapResultO (OccurrenceOf name) (HsVar noExtField (noLoc name)) expr actual_res_ty res_ty } tcCheckRecSelId :: HsExpr GhcRn -> AmbiguousFieldOcc GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId) tcCheckRecSelId rn_expr f@(Unambiguous _ (L _ lbl)) res_ty = do { (expr, actual_res_ty) <- tcInferRecSelId f- ; addFunResCtxt False (HsRecFld noExt f) actual_res_ty res_ty $+ ; addFunResCtxt False (HsRecFld noExtField f) actual_res_ty res_ty $ tcWrapResultO (OccurrenceOfRecSel lbl) rn_expr expr actual_res_ty res_ty } tcCheckRecSelId rn_expr (Ambiguous _ lbl) res_ty = case tcSplitFunTy_maybe =<< checkingExpType_maybe res_ty of@@ -1736,7 +1737,7 @@ Just (arg, _) -> do { sel_name <- disambiguateSelector lbl arg ; tcCheckRecSelId rn_expr (Unambiguous sel_name lbl) res_ty }-tcCheckRecSelId _ (XAmbiguousFieldOcc _) _ = panic "tcCheckRecSelId"+tcCheckRecSelId _ (XAmbiguousFieldOcc nec) _ = noExtCon nec ------------------------ tcInferRecSelId :: AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTcId, TcRhoType)@@ -1745,7 +1746,7 @@ ; return (expr', ty) } tcInferRecSelId (Ambiguous _ lbl) = ambiguousSelector lbl-tcInferRecSelId (XAmbiguousFieldOcc _) = panic "tcInferRecSelId"+tcInferRecSelId (XAmbiguousFieldOcc nec) = noExtCon nec ------------------------ tcInferId :: Name -> TcM (HsExpr GhcTcId, TcSigmaType)@@ -1774,7 +1775,7 @@ = do { assert_error_id <- tcLookupId assertErrorName ; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name) (idType assert_error_id)- ; return (mkHsWrap wrap (HsVar noExt (noLoc assert_error_id)), id_rho)+ ; return (mkHsWrap wrap (HsVar noExtField (noLoc assert_error_id)), id_rho) } tc_infer_id :: RdrName -> Name -> TcM (HsExpr GhcTcId, TcSigmaType)@@ -1800,12 +1801,12 @@ _ -> failWithTc $ ppr thing <+> text "used where a value identifier was expected" } where- return_id id = return (HsVar noExt (noLoc id), idType id)+ return_id id = return (HsVar noExtField (noLoc id), idType id) return_data_con con -- For data constructors, must perform the stupid-theta check | null stupid_theta- = return (HsConLikeOut noExt (RealDataCon con), con_ty)+ = return (HsConLikeOut noExtField (RealDataCon con), con_ty) | otherwise -- See Note [Instantiating stupid theta]@@ -1816,7 +1817,7 @@ rho' = substTy subst rho ; wrap <- instCall (OccurrenceOf id_name) tys' theta' ; addDataConStupidTheta con tys'- ; return ( mkHsWrap wrap (HsConLikeOut noExt (RealDataCon con))+ ; return ( mkHsWrap wrap (HsConLikeOut noExtField (RealDataCon con)) , rho') } where@@ -1844,8 +1845,8 @@ ; let ev = mkLocalId name ty ; can <- newHoleCt (ExprHole unbound) ev ty ; emitInsoluble can- ; tcWrapResultO (UnboundOccurrenceOf occ) rn_expr (HsVar noExt (noLoc ev))- ty res_ty }+ ; tcWrapResultO (UnboundOccurrenceOf occ) rn_expr (HsVar noExtField (noLoc ev))+ ty res_ty } {-@@ -1941,7 +1942,7 @@ (mk_error ty' doc2) ; arg' <- tcMonoExpr arg (mkCheckExpType intPrimTy)- ; let fun' = L loc (mkHsWrap (WpTyApp rep_ty) (HsVar noExt (L loc fun)))+ ; let fun' = L loc (mkHsWrap (WpTyApp rep_ty) (HsVar noExtField (L loc fun))) rep_ty = mkTyConApp rep_tc rep_args out_args = concat [ pars1@@ -1970,7 +1971,7 @@ where pp (HsValArg e) = ppr e pp (HsTypeArg _ (HsWC { hswc_body = L _ t })) = pprHsType t- pp (HsTypeArg _ (XHsWildCardBndrs _)) = panic "too_many_args"+ pp (HsTypeArg _ (XHsWildCardBndrs nec)) = noExtCon nec pp (HsArgPar _) = empty @@ -2030,7 +2031,7 @@ ; lift <- if isStringTy id_ty then do { sid <- tcLookupId THNames.liftStringName -- See Note [Lifting strings]- ; return (HsVar noExt (noLoc sid)) }+ ; return (HsVar noExtField (noLoc sid)) } else setConstraintVar lie_var $ -- Put the 'lift' constraint into the right LIE@@ -2446,7 +2447,7 @@ ; return Nothing } where field_lbl = occNameFS $ rdrNameOcc (unLoc lbl)-tcRecordField _ _ (L _ (XFieldOcc _)) _ = panic "tcRecordField"+tcRecordField _ _ (L _ (XFieldOcc nec)) _ = noExtCon nec checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> TcM ()
compiler/typecheck/TcGenDeriv.hs view
@@ -448,7 +448,7 @@ , mkHsCaseAlt nlWildPat (gtResult op) ] where tag = get_tag data_con- tag_lit = noLoc (HsLit noExt (HsIntPrim NoSourceText (toInteger tag)))+ tag_lit = noLoc (HsLit noExtField (HsIntPrim NoSourceText (toInteger tag))) mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs) -- First argument 'a' known to be built with K@@ -615,7 +615,7 @@ (nlHsApp (nlHsVar (tag2con_RDR dflags tycon)) (nlHsApps plus_RDR [ nlHsVarApps intDataCon_RDR [ah_RDR]- , nlHsLit (HsInt noExt+ , nlHsLit (HsInt noExtField (mkIntegralLit (-1 :: Int)))])) to_enum dflags@@ -776,7 +776,7 @@ enum_index dflags = mk_easy_FunBind loc unsafeIndex_RDR- [noLoc (AsPat noExt (noLoc c_RDR)+ [noLoc (AsPat noExtField (noLoc c_RDR) (nlTuplePat [a_Pat, nlWildPat] Boxed)), d_Pat] ( untag_Expr dflags tycon [(a_RDR, ah_RDR)] (@@ -1148,7 +1148,7 @@ | otherwise = ([a_Pat, con_pat], showParen_Expr (genOpApp a_Expr ge_RDR (nlHsLit- (HsInt noExt (mkIntegralLit con_prec_plus_one))))+ (HsInt noExtField (mkIntegralLit con_prec_plus_one)))) (nlHsPar (nested_compose_Expr show_thingies))) where data_con_RDR = getRdrName data_con@@ -1241,7 +1241,7 @@ -- | showsPrec :: Show a => Int -> a -> ShowS mk_showsPrec_app :: Integer -> LHsExpr GhcPs -> LHsExpr GhcPs mk_showsPrec_app p x- = nlHsApps showsPrec_RDR [nlHsLit (HsInt noExt (mkIntegralLit p)), x]+ = nlHsApps showsPrec_RDR [nlHsLit (HsInt noExtField (mkIntegralLit p)), x] -- | shows :: Show a => a -> ShowS mk_shows_app :: LHsExpr GhcPs -> LHsExpr GhcPs@@ -1338,7 +1338,7 @@ genDataTyCon :: DerivStuff genDataTyCon -- $dT = DerivHsBind (mkHsVarBind loc data_type_name rhs,- L loc (TypeSig noExt [L loc data_type_name] sig_ty))+ L loc (TypeSig noExtField [L loc data_type_name] sig_ty)) sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR) rhs = nlHsVar mkDataType_RDR@@ -1348,7 +1348,7 @@ genDataDataCon :: DataCon -> RdrName -> DerivStuff genDataDataCon dc constr_name -- $cT1 etc = DerivHsBind (mkHsVarBind loc constr_name rhs,- L loc (TypeSig noExt [L loc constr_name] sig_ty))+ L loc (TypeSig noExtField [L loc constr_name] sig_ty)) where sig_ty = mkLHsSigWcType (nlHsTyVar constr_RDR) rhs = nlHsApps mkConstr_RDR constr_args@@ -1573,8 +1573,8 @@ liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp pure_Expr) (map (pats_etc mk_texp) data_cons) - mk_exp = ExpBr NoExt- mk_texp = TExpBr NoExt+ mk_exp = ExpBr noExtField+ mk_texp = TExpBr noExtField data_cons = tyConDataCons tycon pats_etc mk_bracket data_con@@ -1584,7 +1584,7 @@ data_con_RDR = getRdrName data_con con_arity = dataConSourceArity data_con as_needed = take con_arity as_RDRs- lift_Expr = noLoc (HsBracket NoExt (mk_bracket br_body))+ lift_Expr = noLoc (HsBracket noExtField (mk_bracket br_body)) br_body = nlHsApps (Exact (dataConName data_con)) (map nlHsVar as_needed) @@ -1861,12 +1861,12 @@ underlying_inst_tys = changeLast inst_tys rhs_ty nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs-nlHsAppType e s = noLoc (HsAppType noExt e hs_ty)+nlHsAppType e s = noLoc (HsAppType noExtField e hs_ty) where hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec (typeToLHsType s) nlExprWithTySig :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs-nlExprWithTySig e s = noLoc $ ExprWithTySig noExt (parenthesizeHsExpr sigPrec e) hs_ty+nlExprWithTySig e s = noLoc $ ExprWithTySig noExtField (parenthesizeHsExpr sigPrec e) hs_ty where hs_ty = mkLHsSigWcType (typeToLHsType s) @@ -1916,7 +1916,7 @@ -> (LHsBind GhcPs, LSig GhcPs) genAuxBindSpec dflags loc (DerivCon2Tag tycon) = (mkFunBindSE 0 loc rdr_name eqns,- L loc (TypeSig noExt [L loc rdr_name] sig_ty))+ L loc (TypeSig noExtField [L loc rdr_name] sig_ty)) where rdr_name = con2tag_RDR dflags tycon @@ -1942,7 +1942,7 @@ = (mkFunBindSE 0 loc rdr_name [([nlConVarPat intDataCon_RDR [a_RDR]], nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],- L loc (TypeSig noExt [L loc rdr_name] sig_ty))+ L loc (TypeSig noExtField [L loc rdr_name] sig_ty)) where sig_ty = mkLHsSigWcType $ L loc $ XHsType $ NHsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $@@ -1952,7 +1952,7 @@ genAuxBindSpec dflags loc (DerivMaxTag tycon) = (mkHsVarBind loc rdr_name rhs,- L loc (TypeSig noExt [L loc rdr_name] sig_ty))+ L loc (TypeSig noExtField [L loc rdr_name] sig_ty)) where rdr_name = maxtag_RDR dflags tycon sig_ty = mkLHsSigWcType (L loc (XHsType (NHsCoreTy intTy)))
compiler/typecheck/TcHsSyn.hs view
@@ -135,15 +135,15 @@ hsLitType (HsRat _ _ ty) = ty hsLitType (HsFloatPrim _ _) = floatPrimTy hsLitType (HsDoublePrim _ _) = doublePrimTy-hsLitType (XLit p) = pprPanic "hsLitType" (ppr p)+hsLitType (XLit nec) = noExtCon nec -- Overloaded literals. Here mainly because it uses isIntTy etc shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr GhcTcId) shortCutLit dflags (HsIntegral int@(IL src neg i)) ty- | isIntTy ty && inIntRange dflags i = Just (HsLit noExt (HsInt noExt int))+ | isIntTy ty && inIntRange dflags i = Just (HsLit noExtField (HsInt noExtField int)) | isWordTy ty && inWordRange dflags i = Just (mkLit wordDataCon (HsWordPrim src i))- | isIntegerTy ty = Just (HsLit noExt (HsInteger src i ty))+ | isIntegerTy ty = Just (HsLit noExtField (HsInteger src i ty)) | otherwise = shortCutLit dflags (HsFractional (integralFractionalLit neg i)) ty -- The 'otherwise' case is important -- Consider (3 :: Float). Syntactically it looks like an IntLit,@@ -152,16 +152,16 @@ -- literals, compiled without -O shortCutLit _ (HsFractional f) ty- | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim noExt f))- | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim noExt f))+ | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim noExtField f))+ | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim noExtField f)) | otherwise = Nothing shortCutLit _ (HsIsString src s) ty- | isStringTy ty = Just (HsLit noExt (HsString src s))+ | isStringTy ty = Just (HsLit noExtField (HsString src s)) | otherwise = Nothing mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc-mkLit con lit = HsApp noExt (nlHsDataCon con) (nlHsLit lit)+mkLit con lit = HsApp noExtField (nlHsDataCon con) (nlHsLit lit) ------------------------------ hsOverLitName :: OverLitVal -> Name@@ -389,7 +389,7 @@ zonkFieldOcc :: ZonkEnv -> FieldOcc GhcTcId -> TcM (FieldOcc GhcTc) zonkFieldOcc env (FieldOcc sel lbl) = fmap ((flip FieldOcc) lbl) $ zonkIdBndr env sel-zonkFieldOcc _ (XFieldOcc _) = panic "zonkFieldOcc"+zonkFieldOcc _ (XFieldOcc nec) = noExtCon nec zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var]) zonkEvBndrsX = mapAccumLM zonkEvBndrX@@ -532,12 +532,12 @@ = do n' <- mapIPNameTc (zonkIdBndr env) n e' <- zonkLExpr env e return (IPBind x n' e')- zonk_ip_bind (XIPBind _) = panic "zonkLocalBinds : XCIPBind"+ zonk_ip_bind (XIPBind nec) = noExtCon nec -zonkLocalBinds _ (HsIPBinds _ (XHsIPBinds _))- = panic "zonkLocalBinds" -- Not in typechecker output-zonkLocalBinds _ (XHsLocalBindsLR _)- = panic "zonkLocalBinds" -- Not in typechecker output+zonkLocalBinds _ (HsIPBinds _ (XHsIPBinds nec))+ = noExtCon nec+zonkLocalBinds _ (XHsLocalBindsLR nec)+ = noExtCon nec --------------------------------------------- zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (ZonkEnv, LHsBinds GhcTc)@@ -597,7 +597,7 @@ ; new_val_binds <- mapBagM (zonk_val_bind env3) val_binds ; new_exports <- mapM (zonk_export env3) exports ; return (new_val_binds, new_exports) }- ; return (AbsBinds { abs_ext = noExt+ ; return (AbsBinds { abs_ext = noExtField , abs_tvs = new_tyvars, abs_ev_vars = new_evs , abs_ev_binds = new_ev_binds , abs_exports = new_exports, abs_binds = new_val_bind@@ -633,7 +633,7 @@ , abe_poly = new_poly_id , abe_mono = zonkIdOcc env mono_id , abe_prags = new_prags })- zonk_export _ (XABExport _) = panic "zonk_bind: XABExport"+ zonk_export _ (XABExport nec) = noExtCon nec zonk_bind env (PatSynBind x bind@(PSB { psb_id = (dL->L loc id) , psb_args = details@@ -649,8 +649,8 @@ , psb_def = lpat' , psb_dir = dir' } } -zonk_bind _ (PatSynBind _ (XPatSynBind _)) = panic "zonk_bind"-zonk_bind _ (XHsBindsLR _) = panic "zonk_bind"+zonk_bind _ (PatSynBind _ (XPatSynBind nec)) = noExtCon nec+zonk_bind _ (XHsBindsLR nec) = noExtCon nec zonkPatSynDetails :: ZonkEnv -> HsPatSynDetails (Located TcId)@@ -704,7 +704,7 @@ ; return (MG { mg_alts = cL l ms' , mg_ext = MatchGroupTc arg_tys' res_ty' , mg_origin = origin }) }-zonkMatchGroup _ _ (XMatchGroup {}) = panic "zonkMatchGroup"+zonkMatchGroup _ _ (XMatchGroup nec) = noExtCon nec zonkMatch :: ZonkEnv -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))@@ -715,7 +715,7 @@ = do { (env1, new_pats) <- zonkPats env pats ; new_grhss <- zonkGRHSs env1 zBody grhss ; return (cL loc (match { m_pats = new_pats, m_grhss = new_grhss })) }-zonkMatch _ _ (dL->L _ (XMatch _)) = panic "zonkMatch"+zonkMatch _ _ (dL->L _ (XMatch nec)) = noExtCon nec zonkMatch _ _ _ = panic "zonkMatch: Impossible Match" -- due to #15884 @@ -732,10 +732,10 @@ = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded new_rhs <- zBody env2 rhs return (GRHS xx new_guarded new_rhs)- zonk_grhs (XGRHS _) = panic "zonkGRHSs"+ zonk_grhs (XGRHS nec) = noExtCon nec new_grhss <- mapM (wrapLocM zonk_grhs) grhss return (GRHSs x new_grhss (cL l new_binds))-zonkGRHSs _ _ (XGRHSs _) = panic "zonkGRHSs"+zonkGRHSs _ _ (XGRHSs nec) = noExtCon nec {- ************************************************************************@@ -841,7 +841,7 @@ ; return (cL l (Present x e')) } zonk_tup_arg (dL->L l (Missing t)) = do { t' <- zonkTcTypeToTypeX env t ; return (cL l (Missing t')) }- zonk_tup_arg (dL->L _ (XTupArg{})) = panic "zonkExpr.XTupArg"+ zonk_tup_arg (dL->L _ (XTupArg nec)) = noExtCon nec zonk_tup_arg _ = panic "zonk_tup_arg: Impossible Match" -- due to #15884 @@ -877,7 +877,7 @@ = do { (env', guard') <- zonkStmts env zonkLExpr guard ; expr' <- zonkLExpr env' expr ; return $ GRHS x guard' expr' }- zonk_alt (XGRHS _) = panic "zonkExpr.HsMultiIf"+ zonk_alt (XGRHS nec) = noExtCon nec zonkExpr env (HsLet x (dL->L l binds) expr) = do (new_env, new_binds) <- zonkLocalBinds env binds@@ -921,7 +921,7 @@ zonkExpr env (ExprWithTySig _ e ty) = do { e' <- zonkLExpr env e- ; return (ExprWithTySig noExt e' ty) }+ ; return (ExprWithTySig noExtField e' ty) } zonkExpr env (ArithSeq expr wit info) = do (env1, new_wit) <- zonkWit env wit@@ -1057,7 +1057,7 @@ new_ty <- zonkTcTypeToTypeX env ty return (HsCmdDo new_ty (cL l new_stmts)) -zonkCmd _ (XCmd{}) = panic "zonkCmd"+zonkCmd _ (XCmd nec) = noExtCon nec @@ -1077,7 +1077,7 @@ -- rules for arrows return (HsCmdTop (CmdTopTc new_stack_tys new_ty new_ids) new_cmd)-zonk_cmd_top _ (XCmdTop {}) = panic "zonk_cmd_top"+zonk_cmd_top _ (XCmdTop nec) = noExtCon nec ------------------------------------------------------------------------- zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)@@ -1110,7 +1110,7 @@ ; e' <- zonkExpr env e ; return (lit { ol_witness = e', ol_ext = OverLitTc r ty' }) } -zonkOverLit _ XOverLit{} = panic "zonkOverLit"+zonkOverLit _ (XOverLit nec) = noExtCon nec ------------------------------------------------------------------------- zonkArithSeq :: ZonkEnv -> ArithSeqInfo GhcTcId -> TcM (ArithSeqInfo GhcTc)@@ -1166,7 +1166,7 @@ ; (env3, new_return) <- zonkSyntaxExpr env2 return_op ; return (ParStmtBlock x new_stmts (zonkIdOccs env3 bndrs) new_return) }- zonk_branch _ (XParStmtBlock{}) = panic "zonkStmt"+ zonk_branch _ (XParStmtBlock nec) = noExtCon nec zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id@@ -1264,13 +1264,13 @@ get_pat (_, ApplicativeArgOne _ pat _ _) = pat get_pat (_, ApplicativeArgMany _ _ _ pat) = pat- get_pat (_, XApplicativeArg _) = panic "zonkStmt"+ get_pat (_, XApplicativeArg nec) = noExtCon nec replace_pat pat (op, ApplicativeArgOne x _ a isBody) = (op, ApplicativeArgOne x pat a isBody) replace_pat pat (op, ApplicativeArgMany x a b _) = (op, ApplicativeArgMany x a b pat)- replace_pat _ (_, XApplicativeArg _) = panic "zonkStmt"+ replace_pat _ (_, XApplicativeArg nec) = noExtCon nec zonk_args env args = do { (env1, new_args_rev) <- zonk_args_rev env (reverse args)@@ -1294,9 +1294,9 @@ = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts ; new_ret <- zonkExpr env1 ret ; return (ApplicativeArgMany x new_stmts new_ret pat) }- zonk_arg _ (XApplicativeArg _) = panic "zonkStmt.XApplicativeArg"+ zonk_arg _ (XApplicativeArg nec) = noExtCon nec -zonkStmt _ _ (XStmtLR _) = panic "zonkStmt"+zonkStmt _ _ (XStmtLR nec) = noExtCon nec ------------------------------------------------------------------------- zonkRecFields :: ZonkEnv -> HsRecordBinds GhcTcId -> TcM (HsRecordBinds GhcTcId)@@ -1540,7 +1540,7 @@ = do { (env', v') <- zonk_it env v ; return (env', cL l (RuleBndr x (cL loc v'))) } zonk_tm_bndr _ (dL->L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig"- zonk_tm_bndr _ (dL->L _ (XRuleBndr {})) = panic "zonk_tm_bndr XRuleBndr"+ zonk_tm_bndr _ (dL->L _ (XRuleBndr nec)) = noExtCon nec zonk_tm_bndr _ _ = panic "zonk_tm_bndr: Impossible Match" -- due to #15884 @@ -1552,7 +1552,7 @@ -- DV: used to be return (env,v) but that is plain -- wrong because we may need to go inside the kind -- of v and zonk there!-zonkRule _ (XRuleDecl _) = panic "zonkRule"+zonkRule _ (XRuleDecl nec) = noExtCon nec {- ************************************************************************
compiler/typecheck/TcHsType.hs view
@@ -8,6 +8,7 @@ {-# LANGUAGE CPP, TupleSections, MultiWayIf, RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-} module TcHsType ( -- Type signatures@@ -271,7 +272,7 @@ ; return (insolubleWC wanted, mkInvForAllTys kvs ty1) } -tc_hs_sig_type _ (XHsImplicitBndrs _) _ = panic "tc_hs_sig_type"+tc_hs_sig_type _ (XHsImplicitBndrs nec) _ = noExtCon nec tcTopLHsType :: LHsSigType GhcRn -> ContextKind -> TcM Type -- tcTopLHsType is used for kind-checking top-level HsType where@@ -296,10 +297,10 @@ ; traceTc "End tcTopLHsType }" (vcat [ppr hs_ty, ppr final_ty]) ; return final_ty} -tcTopLHsType (XHsImplicitBndrs _) _ = panic "tcTopLHsType"+tcTopLHsType (XHsImplicitBndrs nec) _ = noExtCon nec ------------------tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], (Class, [Type], [Kind]))+tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind]) -- Like tcHsSigType, but for the ...deriving( C t1 ty2 ) clause -- Returns the C, [ty1, ty2, and the kinds of C's remaining arguments -- E.g. class C (a::*) (b::k->k)@@ -313,52 +314,37 @@ ; let (tvs, pred) = splitForAllTys ty (kind_args, _) = splitFunTys (tcTypeKind pred) ; case getClassPredTys_maybe pred of- Just (cls, tys) -> return (tvs, (cls, tys, kind_args))+ Just (cls, tys) -> return (tvs, cls, tys, kind_args) Nothing -> failWithTc (text "Illegal deriving item" <+> quotes (ppr hs_ty)) } --- | Typecheck something within the context of a deriving strategy.--- This is of particular importance when the deriving strategy is @via@.--- For instance:------ @--- deriving via (S a) instance C (T a)--- @------ We need to typecheck @S a@, and moreover, we need to extend the tyvar--- environment with @a@ before typechecking @C (T a)@, since @S a@ quantified--- the type variable @a@.-tcDerivStrategy- :: forall a.- Maybe (DerivStrategy GhcRn) -- ^ The deriving strategy- -> TcM ([TyVar], a) -- ^ The thing to typecheck within the context of the- -- deriving strategy, which might quantify some type- -- variables of its own.- -> TcM (Maybe (DerivStrategy GhcTc), [TyVar], a)- -- ^ The typechecked deriving strategy, all quantified tyvars, and- -- the payload of the typechecked thing.-tcDerivStrategy mds thing_inside- = case mds of+-- | Typecheck a deriving strategy. For most deriving strategies, this is a+-- no-op, but for the @via@ strategy, this requires typechecking the @via@ type.+tcDerivStrategy ::+ Maybe (LDerivStrategy GhcRn)+ -- ^ The deriving strategy+ -> TcM (Maybe (LDerivStrategy GhcTc), [TyVar])+ -- ^ The typechecked deriving strategy and the tyvars that it binds+ -- (if using 'ViaStrategy').+tcDerivStrategy mb_lds+ = case mb_lds of Nothing -> boring_case Nothing- Just ds -> do (ds', tvs, thing) <- tc_deriv_strategy ds- pure (Just ds', tvs, thing)+ Just (dL->L loc ds) ->+ setSrcSpan loc $ do+ (ds', tvs) <- tc_deriv_strategy ds+ pure (Just (cL loc ds'), tvs) where tc_deriv_strategy :: DerivStrategy GhcRn- -> TcM (DerivStrategy GhcTc, [TyVar], a)+ -> TcM (DerivStrategy GhcTc, [TyVar]) tc_deriv_strategy StockStrategy = boring_case StockStrategy tc_deriv_strategy AnyclassStrategy = boring_case AnyclassStrategy tc_deriv_strategy NewtypeStrategy = boring_case NewtypeStrategy tc_deriv_strategy (ViaStrategy ty) = do- ty' <- checkNoErrs $- tcTopLHsType ty AnyKind+ ty' <- checkNoErrs $ tcTopLHsType ty AnyKind let (via_tvs, via_pred) = splitForAllTys ty'- tcExtendTyVarEnv via_tvs $ do- (thing_tvs, thing) <- thing_inside- pure (ViaStrategy via_pred, via_tvs ++ thing_tvs, thing)+ pure (ViaStrategy via_pred, via_tvs) - boring_case :: mds -> TcM (mds, [TyVar], a)- boring_case mds = do- (thing_tvs, thing) <- thing_inside- pure (mds, thing_tvs, thing)+ boring_case :: ds -> TcM (ds, [TyVar])+ boring_case ds = pure (ds, []) tcHsClsInstType :: UserTypeCtxt -- InstDeclCtxt or SpecInstCtxt -> LHsSigType GhcRn@@ -398,7 +384,7 @@ ; ty <- zonkPromoteType ty ; checkValidType TypeAppCtxt ty ; return ty }-tcHsTypeApp (XHsWildCardBndrs _) _ = panic "tcHsTypeApp"+tcHsTypeApp (XHsWildCardBndrs nec) _ = noExtCon nec {- Note [Wildcards in visible type application] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -841,12 +827,12 @@ ; res_k <- newOpenTypeKind ; ty1' <- tc_lhs_type mode ty1 arg_k ; ty2' <- tc_lhs_type mode ty2 res_k- ; checkExpectedKind (HsFunTy noExt ty1 ty2) (mkVisFunTy ty1' ty2')+ ; checkExpectedKind (HsFunTy noExtField ty1 ty2) (mkVisFunTy ty1' ty2') liftedTypeKind exp_kind } KindLevel -> -- no representation polymorphism in kinds. yet. do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind- ; checkExpectedKind (HsFunTy noExt ty1 ty2) (mkVisFunTy ty1' ty2')+ ; checkExpectedKind (HsFunTy noExtField ty1 ty2) (mkVisFunTy ty1' ty2') liftedTypeKind exp_kind } ---------------------------@@ -980,7 +966,7 @@ go (L _ (HsAppKindTy l ty k)) as = go ty (HsTypeArg l k : as) go (L sp (HsParTy _ f)) as = go f (HsArgPar sp : as) go (L _ (HsOpTy _ l op@(L sp _) r)) as- = ( L sp (HsTyVar noExt NotPromoted op)+ = ( L sp (HsTyVar noExtField NotPromoted op) , HsValArg l : HsValArg r : as ) go f as = (f, as) @@ -1652,6 +1638,8 @@ Then, in TcErrors, we report if there is a bad telescope. This way, we can report a suggested ordering to the user if there is a problem. +See also Note [Checking telescopes] in TcRnTypes+ Note [Keeping scoped variables in order: Implicit] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When the user implicitly quantifies over variables (say, in a type@@ -1868,7 +1856,7 @@ ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind | otherwise = AnyKind -kcLHsQTyVars_Cusk _ _ (XLHsQTyVars _) _ = panic "kcLHsQTyVars"+kcLHsQTyVars_Cusk _ _ (XLHsQTyVars nec) _ = noExtCon nec ------------------------------ kcLHsQTyVars_NonCusk name flav@@ -1916,7 +1904,7 @@ ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind | otherwise = AnyKind -kcLHsQTyVars_NonCusk _ _ (XLHsQTyVars _) _ = panic "kcLHsQTyVars"+kcLHsQTyVars_NonCusk _ _ (XLHsQTyVars nec) _ = noExtCon nec {- Note [No polymorphic recursion]@@ -2159,7 +2147,7 @@ tcHsTyVarBndr new_tv (KindedTyVar _ (L _ tv_nm) lhs_kind) = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind ; new_tv tv_nm kind }-tcHsTyVarBndr _ (XTyVarBndr _) = panic "tcHsTyVarBndr"+tcHsTyVarBndr _ (XTyVarBndr nec) = noExtCon nec ----------------- tcHsQTyVarBndr :: ContextKind@@ -2189,10 +2177,10 @@ _ -> new_tv tv_nm kind } where- hs_tv = HsTyVar noExt NotPromoted (noLoc tv_nm)+ hs_tv = HsTyVar noExtField NotPromoted (noLoc tv_nm) -- Used for error messages only -tcHsQTyVarBndr _ _ (XTyVarBndr _) = panic "tcHsTyVarBndr"+tcHsQTyVarBndr _ _ (XTyVarBndr nec) = noExtCon nec --------------------------------------@@ -2628,8 +2616,8 @@ ; traceTc "tcHsPartialSigType" (ppr tv_prs) ; return (wcs, wcx, tv_prs, theta, tau) } -tcHsPartialSigType _ (HsWC _ (XHsImplicitBndrs _)) = panic "tcHsPartialSigType"-tcHsPartialSigType _ (XHsWildCardBndrs _) = panic "tcHsPartialSigType"+tcHsPartialSigType _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec+tcHsPartialSigType _ (XHsWildCardBndrs nec) = noExtCon nec tcPartialContext :: HsContext GhcRn -> TcM (TcThetaType, Maybe TcType) tcPartialContext hs_theta@@ -2768,8 +2756,8 @@ -- NB: tv's Name may be fresh (in the case of newPatSigTyVar) ; return (name, tv) } -tcHsPatSigType _ (HsWC _ (XHsImplicitBndrs _)) = panic "tcHsPatSigType"-tcHsPatSigType _ (XHsWildCardBndrs _) = panic "tcHsPatSigType"+tcHsPatSigType _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec+tcHsPatSigType _ (XHsWildCardBndrs nec) = noExtCon nec tcPatSig :: Bool -- True <=> pattern binding -> LHsSigWcType GhcRn@@ -2799,17 +2787,6 @@ -- than in the renamer { when in_pat_bind (addErr (patBindSigErr sig_tvs)) - -- Check that all newly-in-scope tyvars are in fact- -- constrained by the pattern. This catches tiresome- -- cases like- -- type T a = Int- -- f :: Int -> Int- -- f (x :: T a) = ...- -- Here 'a' doesn't get a binding. Sigh- ; let bad_tvs = filterOut (`elemVarSet` exactTyCoVarsOfType sig_ty)- (tyCoVarsOfTypeList sig_ty)- ; checkTc (null bad_tvs) (badPatTyVarTvs sig_ty bad_tvs)- -- Now do a subsumption check of the pattern signature against res_ty ; wrap <- addErrCtxtM (mk_msg sig_ty) $ tcSubTypeET PatSigOrigin PatSigCtxt res_ty sig_ty@@ -3011,23 +2988,6 @@ NoDataKindsDC -> text "perhaps you intended to use DataKinds" PatSynPE -> text "pattern synonyms cannot be promoted" _ -> text "it is defined and used in the same recursive group"--{--************************************************************************-* *- Scoped type variables-* *-************************************************************************--}--badPatTyVarTvs :: TcType -> [TyVar] -> SDoc-badPatTyVarTvs sig_ty bad_tvs- = vcat [ fsep [text "The type variable" <> plural bad_tvs,- quotes (pprWithCommas ppr bad_tvs),- text "should be bound by the pattern signature" <+> quotes (ppr sig_ty),- text "but are actually discarded by a type synonym" ]- , text "To fix this, expand the type synonym"- , text "[Note: I hope to lift this restriction in due course]" ] {- ************************************************************************
compiler/typecheck/TcInstDcls.hs view
@@ -392,17 +392,14 @@ -- (DerivDecl) to check and process all derived class instances. tcInstDeclsDeriv :: [DerivInfo]- -> [LTyClDecl GhcRn] -> [LDerivDecl GhcRn] -> TcM (TcGblEnv, [InstInfo GhcRn], HsValBinds GhcRn)-tcInstDeclsDeriv datafam_deriv_infos tyclds derivds+tcInstDeclsDeriv deriv_infos derivds = do th_stage <- getStage -- See Note [Deriving inside TH brackets] if isBrackStage th_stage then do { gbl_env <- getGblEnv ; return (gbl_env, bagToList emptyBag, emptyValBindsOut) }- else do { data_deriv_infos <- mkDerivInfos tyclds- ; let deriv_infos = datafam_deriv_infos ++ data_deriv_infos- ; (tcg_env, info_bag, valbinds) <- tcDeriving deriv_infos derivds+ else do { (tcg_env, info_bag, valbinds) <- tcDeriving deriv_infos derivds ; return (tcg_env, bagToList info_bag, valbinds) } addClsInsts :: [InstInfo GhcRn] -> TcM a -> TcM a@@ -461,7 +458,7 @@ = do { (insts, fam_insts, deriv_infos) <- tcClsInstDecl (L loc decl) ; return (insts, fam_insts, deriv_infos) } -tcLocalInstDecl (L _ (XInstDecl _)) = panic "tcLocalInstDecl"+tcLocalInstDecl (L _ (XInstDecl nec)) = noExtCon nec tcClsInstDecl :: LClsInstDecl GhcRn -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo])@@ -538,7 +535,7 @@ . dfid_eqn . unLoc) adts) -tcClsInstDecl (L _ (XClsInstDecl _)) = panic "tcClsInstDecl"+tcClsInstDecl (L _ (XClsInstDecl nec)) = noExtCon nec {- ************************************************************************@@ -660,9 +657,9 @@ -- Do /not/ check that the number of patterns = tyConArity fam_tc -- See [Arity of data families] in FamInstEnv ; (qtvs, pats, res_kind, stupid_theta)- <- tcDataFamHeader mb_clsinfo fam_tc imp_vars mb_bndrs- fixity hs_ctxt hs_pats m_ksig hs_cons- new_or_data+ <- tcDataFamInstHeader mb_clsinfo fam_tc imp_vars mb_bndrs+ fixity hs_ctxt hs_pats m_ksig hs_cons+ new_or_data -- Eta-reduce the axiom if possible -- Quite tricky: see Note [Eta-reduction for data families]@@ -782,16 +779,18 @@ tcDataFamInstDecl _ _ = panic "tcDataFamInstDecl" ------------------------tcDataFamHeader :: AssocInstInfo -> TyCon -> [Name] -> Maybe [LHsTyVarBndr GhcRn]- -> LexicalFixity -> LHsContext GhcRn- -> HsTyPats GhcRn -> Maybe (LHsKind GhcRn) -> [LConDecl GhcRn]- -> NewOrData- -> TcM ([TyVar], [Type], Kind, ThetaType)--- The "header" is the part other than the data constructors themselves--- e.g. data instance D [a] :: * -> * where ...+tcDataFamInstHeader+ :: AssocInstInfo -> TyCon -> [Name] -> Maybe [LHsTyVarBndr GhcRn]+ -> LexicalFixity -> LHsContext GhcRn+ -> HsTyPats GhcRn -> Maybe (LHsKind GhcRn) -> [LConDecl GhcRn]+ -> NewOrData+ -> TcM ([TyVar], [Type], Kind, ThetaType)+-- The "header" of a data family instance is the part other than+-- the data constructors themselves+-- e.g. data instance D [a] :: * -> * where ... -- Here the "header" is the bit before the "where"-tcDataFamHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity hs_ctxt- hs_pats m_ksig hs_cons new_or_data+tcDataFamInstHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity+ hs_ctxt hs_pats m_ksig hs_cons new_or_data = do { (imp_tvs, (exp_tvs, (stupid_theta, lhs_ty))) <- pushTcLevelM_ $ solveEqualities $@@ -806,8 +805,10 @@ -- Add constraints from the result signature ; res_kind <- tc_kind_sig m_ksig+ -- Add constraints from the data constructors- ; mapM_ (wrapLocM_ (kcConDecl new_or_data res_kind)) hs_cons+ ; kcConDecls new_or_data res_kind hs_cons+ ; lhs_ty <- checkExpectedKind_pp pp_lhs lhs_ty lhs_kind res_kind ; return (stupid_theta, lhs_ty) } @@ -832,7 +833,7 @@ -- the body of unravelFamInstPats. ; pats <- case splitTyConApp_maybe lhs_ty of Just (_, pats) -> pure pats- Nothing -> pprPanic "tcDataFamHeader" (ppr lhs_ty)+ Nothing -> pprPanic "tcDataFamInstHeader" (ppr lhs_ty) ; return (qtvs, pats, typeKind lhs_ty, stupid_theta) } -- See Note [Unifying data family kinds] about why we need typeKind here where@@ -889,7 +890,7 @@ have a definitive kind for the data family from the data family declaration, and so we learn nothing really new from the kind signature on an instance. We still must perform this unification (done in the call to checkExpectedKind-toward the beginning of tcDataFamHeader), but the result is unhelpful. If there+toward the beginning of tcDataFamInstHeader), but the result is unhelpful. If there is a cast, it will wrap the lhs_ty, and so we just drop it before splitting the lhs_ty to reveal the underlying patterns. Because of the potential of dropping a cast like this, we just use typeKind in the result instead of propagating res_kind@@ -1094,14 +1095,14 @@ -- con_app_scs = MkD ty1 ty2 sc1 sc2 -- con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2 con_app_tys = mkHsWrap (mkWpTyApps inst_tys)- (HsConLikeOut noExt (RealDataCon dict_constr))+ (HsConLikeOut noExtField (RealDataCon dict_constr)) -- NB: We *can* have covars in inst_tys, in the case of -- promoted GADT constructors. con_app_args = foldl' app_to_meth con_app_tys sc_meth_ids app_to_meth :: HsExpr GhcTc -> Id -> HsExpr GhcTc- app_to_meth fun meth_id = HsApp noExt (L loc fun)+ app_to_meth fun meth_id = HsApp noExtField (L loc fun) (L loc (wrapId arg_wrapper meth_id)) inst_tv_tys = mkTyVarTys inst_tyvars@@ -1115,13 +1116,13 @@ -- Newtype dfuns just inline unconditionally, -- so don't attempt to specialise them - export = ABE { abe_ext = noExt+ export = ABE { abe_ext = noExtField , abe_wrap = idHsWrapper , abe_poly = dfun_id_w_prags , abe_mono = self_dict , abe_prags = dfun_spec_prags } -- NB: see Note [SPECIALISE instance pragmas]- main_bind = AbsBinds { abs_ext = noExt+ main_bind = AbsBinds { abs_ext = noExtField , abs_tvs = inst_tyvars , abs_ev_vars = dfun_ev_vars , abs_exports = [export]@@ -1168,7 +1169,7 @@ is_newtype = isNewTyCon clas_tc wrapId :: HsWrapper -> IdP (GhcPass id) -> HsExpr (GhcPass id)-wrapId wrapper id = mkHsWrap wrapper (HsVar noExt (noLoc id))+wrapId wrapper id = mkHsWrap wrapper (HsVar noExtField (noLoc id)) {- Note [Typechecking plan for instance declarations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1267,13 +1268,13 @@ ; let sc_top_ty = mkInvForAllTys tyvars $ mkPhiTy (map idType dfun_evs) sc_pred sc_top_id = mkLocalId sc_top_name sc_top_ty- export = ABE { abe_ext = noExt+ export = ABE { abe_ext = noExtField , abe_wrap = idHsWrapper , abe_poly = sc_top_id , abe_mono = sc_ev_id , abe_prags = noSpecPrags } local_ev_binds = TcEvBinds ev_binds_var- bind = AbsBinds { abs_ext = noExt+ bind = AbsBinds { abs_ext = noExtField , abs_tvs = tyvars , abs_ev_vars = dfun_evs , abs_exports = [export]@@ -1566,12 +1567,12 @@ mkLHsWrap lam_wrapper (error_rhs dflags) ; return (meth_id, meth_bind, Nothing) } where- error_rhs dflags = L inst_loc $ HsApp noExt error_fun (error_msg dflags)+ error_rhs dflags = L inst_loc $ HsApp noExtField error_fun (error_msg dflags) error_fun = L inst_loc $ wrapId (mkWpTyApps [ getRuntimeRep meth_tau, meth_tau]) nO_METHOD_BINDING_ERROR_ID- error_msg dflags = L inst_loc (HsLit noExt (HsStringPrim NoSourceText+ error_msg dflags = L inst_loc (HsLit noExtField (HsStringPrim NoSourceText (unsafeMkByteString (error_string dflags)))) meth_tau = funResultTy (piResultTys (idType sel_id) inst_tys) error_string dflags = showSDoc dflags@@ -1699,14 +1700,14 @@ ; spec_prags <- tcSpecPrags global_meth_id prags ; let specs = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags- export = ABE { abe_ext = noExt+ export = ABE { abe_ext = noExtField , abe_poly = global_meth_id , abe_mono = local_meth_id , abe_wrap = idHsWrapper , abe_prags = specs } local_ev_binds = TcEvBinds ev_binds_var- full_bind = AbsBinds { abs_ext = noExt+ full_bind = AbsBinds { abs_ext = noExtField , abs_tvs = tyvars , abs_ev_vars = dfun_ev_vars , abs_exports = [export]@@ -1749,14 +1750,14 @@ ; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind - ; let export = ABE { abe_ext = noExt+ ; let export = ABE { abe_ext = noExtField , abe_poly = local_meth_id , abe_mono = inner_id , abe_wrap = hs_wrap , abe_prags = noSpecPrags } ; return (unitBag $ L (getLoc meth_bind) $- AbsBinds { abs_ext = noExt, abs_tvs = [], abs_ev_vars = []+ AbsBinds { abs_ext = noExtField, abs_tvs = [], abs_ev_vars = [] , abs_exports = [export] , abs_binds = tc_bind, abs_ev_binds = [] , abs_sig = True }) }@@ -1902,7 +1903,7 @@ ; dm_id <- tcLookupId dm_name ; let inline_prag = idInlinePragma dm_id inline_prags | isAnyInlinePragma inline_prag- = [noLoc (InlineSig noExt fn inline_prag)]+ = [noLoc (InlineSig noExtField fn inline_prag)] | otherwise = [] -- Copy the inline pragma (if any) from the default method@@ -1922,7 +1923,7 @@ ; return (bind, inline_prags) } where mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn- mk_vta fun ty = noLoc (HsAppType noExt fun (mkEmptyWildCardBndrs $ nlHsParTy+ mk_vta fun ty = noLoc (HsAppType noExtField fun (mkEmptyWildCardBndrs $ nlHsParTy $ noLoc $ XHsType $ NHsCoreTy ty)) -- NB: use visible type application -- See Note [Default methods in instances]
compiler/typecheck/TcMatches.hs view
@@ -219,7 +219,7 @@ ; return (MG { mg_alts = L l matches' , mg_ext = MatchGroupTc pat_tys rhs_ty , mg_origin = origin }) }-tcMatches _ _ _ (XMatchGroup {}) = panic "tcMatches"+tcMatches _ _ _ (XMatchGroup nec) = noExtCon nec ------------- tcMatch :: (Outputable (body GhcRn)) => TcMatchCtxt body@@ -236,10 +236,10 @@ = add_match_ctxt match $ do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $ tcGRHSs ctxt grhss rhs_ty- ; return (Match { m_ext = noExt+ ; return (Match { m_ext = noExtField , m_ctxt = mc_what ctxt, m_pats = pats' , m_grhss = grhss' }) }- tc_match _ _ _ (XMatch _) = panic "tcMatch"+ tc_match _ _ _ (XMatch nec) = noExtCon nec -- For (\x -> e), tcExpr has already said "In the expression \x->e" -- so we don't want to add "In the lambda abstraction \x->e"@@ -263,8 +263,8 @@ <- tcLocalBinds binds $ mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss - ; return (GRHSs noExt grhss' (L l binds')) }-tcGRHSs _ (XGRHSs _) _ = panic "tcGRHSs"+ ; return (GRHSs noExtField grhss' (L l binds')) }+tcGRHSs _ (XGRHSs nec) _ = noExtCon nec ------------- tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (Located (body GhcRn))@@ -274,10 +274,10 @@ = do { (guards', rhs') <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $ mc_body ctxt rhs- ; return (GRHS noExt guards' rhs') }+ ; return (GRHS noExtField guards' rhs') } where stmt_ctxt = PatGuard (mc_what ctxt)-tcGRHS _ _ (XGRHS _) = panic "tcGRHS"+tcGRHS _ _ (XGRHS nec) = noExtCon nec {- ************************************************************************@@ -467,7 +467,7 @@ ; (pairs', thing) <- loop pairs ; return (ids, pairs', thing) } ; return ( ParStmtBlock x stmts' ids noSyntaxExpr : pairs', thing ) }- loop (XParStmtBlock{}:_) = panic "tcLcStmt"+ loop (XParStmtBlock nec:_) = noExtCon nec tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts , trS_bndrs = bindersMap@@ -1034,12 +1034,12 @@ } ; return (ApplicativeArgMany x stmts' ret' pat') } - goArg (XApplicativeArg _, _, _) = panic "tcApplicativeStmts"+ goArg (XApplicativeArg nec, _, _) = noExtCon nec get_arg_bndrs :: ApplicativeArg GhcTcId -> [Id] get_arg_bndrs (ApplicativeArgOne _ pat _ _) = collectPatBinders pat get_arg_bndrs (ApplicativeArgMany _ _ _ pat) = collectPatBinders pat- get_arg_bndrs (XApplicativeArg _) = panic "tcApplicativeStmts"+ get_arg_bndrs (XApplicativeArg nec) = noExtCon nec {- Note [ApplicativeDo and constraints]@@ -1096,5 +1096,5 @@ args_in_match :: LMatch GhcRn body -> Int args_in_match (L _ (Match { m_pats = pats })) = length pats- args_in_match (L _ (XMatch _)) = panic "checkArgs"-checkArgs _ (XMatchGroup{}) = panic "checkArgs"+ args_in_match (L _ (XMatch nec)) = noExtCon nec+checkArgs _ (XMatchGroup nec) = noExtCon nec
compiler/typecheck/TcPat.hs view
@@ -466,7 +466,7 @@ -- pat_ty /= pat_ty iff coi /= IdCo possibly_mangled_result | gopt Opt_IrrefutableTuples dflags &&- isBoxed boxity = LazyPat noExt (noLoc unmangled_result)+ isBoxed boxity = LazyPat noExtField (noLoc unmangled_result) | otherwise = unmangled_result ; pat_ty <- readExpType pat_ty
compiler/typecheck/TcPatSyn.hs view
@@ -102,7 +102,7 @@ matcher_id = mkLocalId matcher_name $ mkSpecForAllTys [alphaTyVar] alphaTy -recoverPSB (XPatSynBind {}) = panic "recoverPSB"+recoverPSB (XPatSynBind nec) = noExtCon nec {- Note [Pattern synonym error recovery] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -187,7 +187,7 @@ , mkTyVarTys ex_tvs, prov_theta, prov_evs) (map nlHsVar args, map idType args) pat_ty rec_fields } }-tcInferPatSynDecl (XPatSynBind _) = panic "tcInferPatSynDecl"+tcInferPatSynDecl (XPatSynBind nec) = noExtCon nec mkProvEvidence :: EvId -> Maybe (PredType, EvTerm) -- See Note [Equality evidence in pattern synonyms]@@ -397,7 +397,7 @@ -- satisfy the substitution invariant. There's no need to -- add 'ex_tvs' as they are already in the domain of the -- substitution.- -- See also Note [The substitution invariant] in TyCoRep.+ -- See also Note [The substitution invariant] in TyCoSubst. ; prov_dicts <- mapM (emitWanted (ProvCtxtOrigin psb)) prov_theta' ; args' <- zipWithM (tc_arg subst) arg_names arg_tys ; return (ex_tvs', prov_dicts, args') }@@ -434,7 +434,7 @@ -- Why do we need tcSubType here? -- See Note [Pattern synonyms and higher rank types] ; return (mkLHsWrap wrap $ nlHsVar arg_id) }-tcCheckPatSynDecl (XPatSynBind _) _ = panic "tcCheckPatSynDecl"+tcCheckPatSynDecl (XPatSynBind nec) _ = noExtCon nec {- [Pattern synonyms and higher rank types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -726,13 +726,13 @@ mkHsCaseAlt lwpat fail'] body = mkLHsWrap (mkWpLet req_ev_binds) $ cL (getLoc lpat) $- HsCase noExt (nlHsVar scrutinee) $+ HsCase noExtField (nlHsVar scrutinee) $ MG{ mg_alts = cL (getLoc lpat) cases , mg_ext = MatchGroupTc [pat_ty] res_ty , mg_origin = Generated } body' = noLoc $- HsLam noExt $+ HsLam noExtField $ MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr args body] , mg_ext = MatchGroupTc [pat_ty, cont_ty, fail_ty] res_ty@@ -741,7 +741,7 @@ match = mkMatch (mkPrefixFunRhs (cL loc name)) [] (mkHsLams (rr_tv:res_tv:univ_tvs) req_dicts body')- (noLoc (EmptyLocalBinds noExt))+ (noLoc (EmptyLocalBinds noExtField)) mg :: MatchGroup GhcTc (LHsExpr GhcTc) mg = MG{ mg_alts = cL (getLoc match) [match] , mg_ext = MatchGroupTc [] res_ty@@ -863,11 +863,11 @@ mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn) mk_mg body = mkMatchGroup Generated [builder_match] where- builder_args = [cL loc (VarPat noExt (cL loc n))+ builder_args = [cL loc (VarPat noExtField (cL loc n)) | (dL->L loc n) <- args] builder_match = mkMatch (mkPrefixFunRhs (cL loc name)) builder_args body- (noLoc (EmptyLocalBinds noExt))+ (noLoc (EmptyLocalBinds noExtField)) args = case details of PrefixCon args -> args@@ -882,13 +882,13 @@ = mg { mg_alts = cL l [cL loc (match { m_pats = nlWildPatName : pats })] } add_dummy_arg other_mg = pprPanic "add_dummy_arg" $ pprMatches other_mg-tcPatSynBuilderBind (XPatSynBind _) = panic "tcPatSynBuilderBind"+tcPatSynBuilderBind (XPatSynBind nec) = noExtCon nec tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr GhcTcId, TcSigmaType) -- monadic only for failure tcPatSynBuilderOcc ps | Just (builder_id, add_void_arg) <- builder- , let builder_expr = HsConLikeOut noExt (PatSynCon ps)+ , let builder_expr = HsConLikeOut noExtField (PatSynCon ps) builder_ty = idType builder_id = return $ if add_void_arg@@ -927,14 +927,14 @@ -> Either MsgDoc (HsExpr GhcRn) mkPrefixConExpr lcon@(dL->L loc _) pats = do { exprs <- mapM go pats- ; return (foldl' (\x y -> HsApp noExt (cL loc x) y)- (HsVar noExt lcon) exprs) }+ ; return (foldl' (\x y -> HsApp noExtField (cL loc x) y)+ (HsVar noExtField lcon) exprs) } mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn) -> Either MsgDoc (HsExpr GhcRn) mkRecordConExpr con fields = do { exprFields <- mapM go fields- ; return (RecordCon noExt con exprFields) }+ ; return (RecordCon noExtField con exprFields) } go :: LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn) go (dL->L loc p) = cL loc <$> go1 p@@ -951,27 +951,27 @@ go1 (VarPat _ (dL->L l var)) | var `elemNameSet` lhsVars- = return $ HsVar noExt (cL l var)+ = return $ HsVar noExtField (cL l var) | otherwise = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym")- go1 (ParPat _ pat) = fmap (HsPar noExt) $ go pat+ go1 (ParPat _ pat) = fmap (HsPar noExtField) $ go pat go1 p@(ListPat reb pats) | Nothing <- reb = do { exprs <- mapM go pats- ; return $ ExplicitList noExt Nothing exprs }+ ; return $ ExplicitList noExtField Nothing exprs } | otherwise = notInvertibleListPat p go1 (TuplePat _ pats box) = do { exprs <- mapM go pats- ; return $ ExplicitTuple noExt- (map (noLoc . (Present noExt)) exprs)+ ; return $ ExplicitTuple noExtField+ (map (noLoc . (Present noExtField)) exprs) box } go1 (SumPat _ pat alt arity) = do { expr <- go1 (unLoc pat)- ; return $ ExplicitSum noExt alt arity+ ; return $ ExplicitSum noExtField alt arity (noLoc expr) }- go1 (LitPat _ lit) = return $ HsLit noExt lit+ go1 (LitPat _ lit) = return $ HsLit noExtField lit go1 (NPat _ (dL->L _ n) mb_neg _) | Just neg <- mb_neg = return $ unLoc $ nlHsSyntaxApps neg- [noLoc (HsOverLit noExt n)]- | otherwise = return $ HsOverLit noExt n+ [noLoc (HsOverLit noExtField n)]+ | otherwise = return $ HsOverLit noExtField n go1 (ConPatOut{}) = panic "ConPatOut in output of renamer" go1 (CoPat{}) = panic "CoPat in output of renamer" go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
compiler/typecheck/TcRnDriver.hs view
@@ -554,7 +554,7 @@ ("Declaration splices are not " ++ "permitted inside top-level " ++ "declarations added with addTopDecls"))- ; Just (XSpliceDecl _, _) -> panic "tc_rn_src_decls"+ ; Just (XSpliceDecl nec, _) -> noExtCon nec } -- Rename TH-generated top-level declarations ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env@@ -597,7 +597,7 @@ ; return (tcg_env, tcl_env, lie1 `andWC` lie2) }- ; Just (XSpliceDecl _, _) -> panic "tc_rn_src_decls"+ ; Just (XSpliceDecl nec, _) -> noExtCon nec } } @@ -634,8 +634,8 @@ -- Check for illegal declarations ; case group_tail of Just (SpliceDecl _ d _, _) -> badBootDecl hsc_src "splice" d- Just (XSpliceDecl _, _) -> panic "tcRnHsBootDecls"- Nothing -> return ()+ Just (XSpliceDecl nec, _) -> noExtCon nec+ Nothing -> return () ; mapM_ (badBootDecl hsc_src "foreign") for_decls ; mapM_ (badBootDecl hsc_src "default") def_decls ; mapM_ (badBootDecl hsc_src "rule") rule_decls@@ -1682,7 +1682,7 @@ tcTyClsInstDecls tycl_decls deriv_decls binds = tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $ tcAddPatSynPlaceholders (getPatSynBinds binds) $- do { (tcg_env, inst_info, datafam_deriv_info)+ do { (tcg_env, inst_info, deriv_info) <- tcTyAndClassDecls tycl_decls ; ; setGblEnv tcg_env $ do { -- With the @TyClDecl@s and @InstDecl@s checked we're ready to@@ -1692,9 +1692,8 @@ -- Careful to quit now in case there were instance errors, so that -- the deriving errors don't pile up as well. ; failIfErrsM- ; let tyclds = tycl_decls >>= group_tyclds ; (tcg_env', inst_info', val_binds)- <- tcInstDeclsDeriv datafam_deriv_info tyclds deriv_decls+ <- tcInstDeclsDeriv deriv_info deriv_decls ; setGblEnv tcg_env' $ do { failIfErrsM ; pure (tcg_env', inst_info' ++ inst_info, val_binds)@@ -1740,7 +1739,7 @@ ; (ev_binds, main_expr) <- checkConstraints skol_info [] [] $ addErrCtxt mainCtxt $- tcMonoExpr (cL loc (HsVar noExt (cL loc main_name)))+ tcMonoExpr (cL loc (HsVar noExtField (cL loc main_name))) (mkCheckExpType io_ty) -- See Note [Root-main Id]@@ -2069,35 +2068,35 @@ -- (if we are at a breakpoint, say). We must put those free vars -- [let it = expr]- let_stmt = cL loc $ LetStmt noExt $ noLoc $ HsValBinds noExt+ let_stmt = cL loc $ LetStmt noExtField $ noLoc $ HsValBinds noExtField $ XValBindsLR (NValBinds [(NonRecursive,unitBag the_bind)] []) -- [it <- e]- bind_stmt = cL loc $ BindStmt noExt- (cL loc (VarPat noExt (cL loc fresh_it)))+ bind_stmt = cL loc $ BindStmt noExtField+ (cL loc (VarPat noExtField (cL loc fresh_it))) (nlHsApp ghciStep rn_expr) (mkRnSyntaxExpr bindIOName) noSyntaxExpr -- [; print it]- print_it = cL loc $ BodyStmt noExt+ print_it = cL loc $ BodyStmt noExtField (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it)) (mkRnSyntaxExpr thenIOName) noSyntaxExpr -- NewA- no_it_a = cL loc $ BodyStmt noExt (nlHsApps bindIOName+ no_it_a = cL loc $ BodyStmt noExtField (nlHsApps bindIOName [rn_expr , nlHsVar interPrintName]) (mkRnSyntaxExpr thenIOName) noSyntaxExpr - no_it_b = cL loc $ BodyStmt noExt (rn_expr)+ no_it_b = cL loc $ BodyStmt noExtField (rn_expr) (mkRnSyntaxExpr thenIOName) noSyntaxExpr - no_it_c = cL loc $ BodyStmt noExt+ no_it_c = cL loc $ BodyStmt noExtField (nlHsApp (nlHsVar interPrintName) rn_expr) (mkRnSyntaxExpr thenIOName) noSyntaxExpr@@ -2231,7 +2230,7 @@ ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM ; return stuff } where- print_v = cL loc $ BodyStmt noExt (nlHsApp (nlHsVar printName)+ print_v = cL loc $ BodyStmt noExtField (nlHsApp (nlHsVar printName) (nlHsVar v)) (mkRnSyntaxExpr thenIOName) noSyntaxExpr @@ -2318,14 +2317,14 @@ step_ty = noLoc $ HsForAllTy { hst_fvf = ForallInvis- , hst_bndrs = [noLoc $ UserTyVar noExt (noLoc a_tv)]- , hst_xforall = noExt+ , hst_bndrs = [noLoc $ UserTyVar noExtField (noLoc a_tv)]+ , hst_xforall = noExtField , hst_body = nlHsFunTy ghciM ioM } stepTy :: LHsSigWcType GhcRn stepTy = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs step_ty) - return (noLoc $ ExprWithTySig noExt (nlHsVar ghciStepIoMName) stepTy)+ return (noLoc $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy) isGHCiMonad :: HscEnv -> String -> IO (Messages, Maybe Name) isGHCiMonad hsc_env ty
compiler/typecheck/TcRnExports.hs view
@@ -183,7 +183,7 @@ ; let real_exports | explicit_mod = exports | has_main- = Just (noLoc [noLoc (IEVar noExt+ = Just (noLoc [noLoc (IEVar noExtField (noLoc (IEName $ noLoc default_main)))]) -- ToDo: the 'noLoc' here is unhelpful if 'main' -- turns out to be out of scope@@ -317,7 +317,7 @@ , ppr new_exports ]) ; return (Just ( ExportAccum occs' mods- , ( cL loc (IEModuleContents noExt lmod)+ , ( cL loc (IEModuleContents noExtField lmod) , new_exports))) } exports_from_item acc@(ExportAccum occs mods) (dL->L loc ie)@@ -340,18 +340,18 @@ lookup_ie :: IE GhcPs -> RnM (IE GhcRn, AvailInfo) lookup_ie (IEVar _ (dL->L l rdr)) = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr- return (IEVar noExt (cL l (replaceWrappedName rdr name)), avail)+ return (IEVar noExtField (cL l (replaceWrappedName rdr name)), avail) lookup_ie (IEThingAbs _ (dL->L l rdr)) = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr- return (IEThingAbs noExt (cL l (replaceWrappedName rdr name))+ return (IEThingAbs noExtField (cL l (replaceWrappedName rdr name)) , avail) lookup_ie ie@(IEThingAll _ n') = do (n, avail, flds) <- lookup_ie_all ie n' let name = unLoc n- return (IEThingAll noExt (replaceLWrappedName n' (unLoc n))+ return (IEThingAll noExtField (replaceLWrappedName n' (unLoc n)) , AvailTC name (name:avail) flds) @@ -364,7 +364,7 @@ NoIEWildcard -> return (lname, [], []) IEWildcard _ -> lookup_ie_all ie l let name = unLoc lname- return (IEThingWith noExt (replaceLWrappedName l name) wc subs+ return (IEThingWith noExtField (replaceLWrappedName l name) wc subs (flds ++ (map noLoc all_flds)), AvailTC name (name : avails ++ all_avail) (map unLoc flds ++ all_flds))@@ -406,10 +406,10 @@ ------------- lookup_doc_ie :: IE GhcPs -> RnM (IE GhcRn) lookup_doc_ie (IEGroup _ lev doc) = do rn_doc <- rnHsDoc doc- return (IEGroup noExt lev rn_doc)+ return (IEGroup noExtField lev rn_doc) lookup_doc_ie (IEDoc _ doc) = do rn_doc <- rnHsDoc doc- return (IEDoc noExt rn_doc)- lookup_doc_ie (IEDocNamed _ str) = return (IEDocNamed noExt str)+ return (IEDoc noExtField rn_doc)+ lookup_doc_ie (IEDocNamed _ str) = return (IEDocNamed noExtField str) lookup_doc_ie _ = panic "lookup_doc_ie" -- Other cases covered earlier -- In an export item M.T(A,B,C), we want to treat the uses of
compiler/typecheck/TcRules.hs view
@@ -66,10 +66,10 @@ tcRuleDecls (HsRules { rds_src = src , rds_rules = decls }) = do { tc_decls <- mapM (wrapLocM tcRule) decls- ; return $ HsRules { rds_ext = noExt+ ; return $ HsRules { rds_ext = noExtField , rds_src = src , rds_rules = tc_decls } }-tcRuleDecls (XRuleDecls _) = panic "tcRuleDecls"+tcRuleDecls (XRuleDecls nec) = noExtCon nec tcRule :: RuleDecl GhcRn -> TcM (RuleDecl GhcTcId) tcRule (HsRule { rd_ext = ext@@ -141,10 +141,11 @@ , rd_name = rname , rd_act = act , rd_tyvs = ty_bndrs -- preserved for ppr-ing- , rd_tmvs = map (noLoc . RuleBndr noExt . noLoc) (all_qtkvs ++ tpl_ids)+ , rd_tmvs = map (noLoc . RuleBndr noExtField . noLoc)+ (all_qtkvs ++ tpl_ids) , rd_lhs = mkHsDictLet lhs_binds lhs' , rd_rhs = mkHsDictLet rhs_binds rhs' } }-tcRule (XRuleDecl _) = panic "tcRule"+tcRule (XRuleDecl nec) = noExtCon nec generateRuleConstraints :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn] -> LHsExpr GhcRn -> LHsExpr GhcRn@@ -203,7 +204,7 @@ ; (tyvars, tmvars) <- tcExtendNameTyVarEnv tvs $ tcRuleTmBndrs rule_bndrs ; return (map snd tvs ++ tyvars, id : tmvars) }-tcRuleTmBndrs (L _ (XRuleBndr _) : _) = panic "tcRuleTmBndrs"+tcRuleTmBndrs (L _ (XRuleBndr nec) : _) = noExtCon nec ruleCtxt :: FastString -> SDoc ruleCtxt name = text "When checking the transformation rule" <+>
compiler/typecheck/TcSigs.hs view
@@ -258,8 +258,8 @@ isCompleteHsSig (HsWC { hswc_ext = wcs , hswc_body = HsIB { hsib_body = hs_ty } }) = null wcs && no_anon_wc hs_ty-isCompleteHsSig (HsWC _ (XHsImplicitBndrs _)) = panic "isCompleteHsSig"-isCompleteHsSig (XHsWildCardBndrs _) = panic "isCompleteHsSig"+isCompleteHsSig (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec+isCompleteHsSig (XHsWildCardBndrs nec) = noExtCon nec no_anon_wc :: LHsType GhcRn -> Bool no_anon_wc lty = go lty@@ -300,7 +300,7 @@ where go (UserTyVar _ _) = True go (KindedTyVar _ _ ki) = no_anon_wc ki- go (XTyVarBndr{}) = panic "no_anon_wc_bndrs"+ go (XTyVarBndr nec) = noExtCon nec {- Note [Fail eagerly on bad signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -465,7 +465,7 @@ mkSpecForAllTys ex $ mkPhiTy prov $ body-tcPatSynSig _ (XHsImplicitBndrs _) = panic "tcPatSynSig"+tcPatSynSig _ (XHsImplicitBndrs nec) = noExtCon nec ppr_tvs :: [TyVar] -> SDoc ppr_tvs tvs = braces (vcat [ ppr tv <+> dcolon <+> ppr (tyVarKind tv)
compiler/typecheck/TcSplice.hs view
@@ -185,7 +185,7 @@ ; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr") rn_expr (unLoc (mkHsApp (nlHsTyApp texpco [rep, expr_ty])- (noLoc (HsTcBracketOut noExt brack ps'))))+ (noLoc (HsTcBracketOut noExtField brack ps')))) meta_ty res_ty } tcTypedBracket _ other_brack _ = pprPanic "tcTypedBracket" (ppr other_brack)@@ -197,7 +197,7 @@ ; meta_ty <- tcBrackTy brack ; traceTc "tc_bracket done untyped" (ppr meta_ty) ; tcWrapResultO (Shouldn'tHappenOrigin "untyped bracket")- rn_expr (HsTcBracketOut noExt brack ps') meta_ty res_ty }+ rn_expr (HsTcBracketOut noExtField brack ps') meta_ty res_ty } --------------- tcBrackTy :: HsBracket GhcRn -> TcM TcType@@ -207,9 +207,9 @@ tcBrackTy (TypBr {}) = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ) tcBrackTy (DecBrG {}) = tcMetaTy decsQTyConName -- Result type is Q [Dec] tcBrackTy (PatBr {}) = tcMetaTy patQTyConName -- Result type is PatQ (= Q Pat)-tcBrackTy (DecBrL {}) = panic "tcBrackTy: Unexpected DecBrL"-tcBrackTy (TExpBr {}) = panic "tcUntypedBracket: Unexpected TExpBr"-tcBrackTy (XBracket {}) = panic "tcUntypedBracket: Unexpected XBracket"+tcBrackTy (DecBrL {}) = panic "tcBrackTy: Unexpected DecBrL"+tcBrackTy (TExpBr {}) = panic "tcUntypedBracket: Unexpected TExpBr"+tcBrackTy (XBracket nec) = noExtCon nec --------------- tcPendingSplice :: PendingRnSplice -> TcM PendingTcSplice@@ -498,7 +498,7 @@ ; lcl_env <- getLclEnv ; let delayed_splice = DelayedSplice lcl_env expr res_ty q_expr- ; return (HsSpliceE noExt (HsSplicedT delayed_splice))+ ; return (HsSpliceE noExtField (HsSplicedT delayed_splice)) } @@ -610,8 +610,8 @@ ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]] ; let specialised_to_annotation_wrapper_expr = L loc (mkHsWrap wrapper- (HsVar noExt (L loc to_annotation_wrapper_id)))- ; return (L loc (HsApp noExt+ (HsVar noExtField (L loc to_annotation_wrapper_id)))+ ; return (L loc (HsApp noExtField specialised_to_annotation_wrapper_expr expr')) }) @@ -945,6 +945,7 @@ qLookupName = lookupName qReify = reify qReifyFixity nm = lookupThName nm >>= reifyFixity+ qReifyType = reifyTypeOfThing qReifyInstances = reifyInstances qReifyRoles = reifyRoles qReifyAnnotations = reifyAnnotations@@ -1210,6 +1211,7 @@ LookupName b str -> wrapTHResult $ TH.qLookupName b str Reify n -> wrapTHResult $ TH.qReify n ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n+ ReifyType n -> wrapTHResult $ TH.qReifyType n ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n ReifyAnnotations lookup tyrep ->@@ -2014,6 +2016,23 @@ reifyDecidedStrictness HsLazy = TH.DecidedLazy reifyDecidedStrictness HsStrict = TH.DecidedStrict reifyDecidedStrictness HsUnpack{} = TH.DecidedUnpack++reifyTypeOfThing :: TH.Name -> TcM TH.Type+reifyTypeOfThing th_name = do+ thing <- getThing th_name+ case thing of+ AGlobal (AnId id) -> reifyType (idType id)+ AGlobal (ATyCon tc) -> reifyKind (tyConKind tc)+ AGlobal (AConLike (RealDataCon dc)) ->+ reifyType (idType (dataConWrapId dc))+ AGlobal (AConLike (PatSynCon ps)) ->+ reifyPatSynType (patSynSig ps)+ ATcId{tct_id = id} -> zonkTcType (idType id) >>= reifyType+ ATyVar _ tctv -> zonkTcTyVar tctv >>= reifyType+ -- Impossible cases, supposedly:+ AGlobal (ACoAxiom _) -> panic "reifyTypeOfThing: ACoAxiom"+ ATcTyCon _ -> panic "reifyTypeOfThing: ATcTyCon"+ APromotionErr _ -> panic "reifyTypeOfThing: APromotionErr" ------------------------------ lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget
compiler/typecheck/TcTyClsDecls.hs view
@@ -15,7 +15,7 @@ -- Functions used by TcInstDcls to check -- data/type family instance declarations- kcConDecl, tcConDecls, dataDeclChecks, checkValidTyCon,+ kcConDecls, tcConDecls, dataDeclChecks, checkValidTyCon, tcFamTyPats, tcTyFamInstEqn, tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt, unravelFamInstPats, addConsistencyConstraints,@@ -36,7 +36,7 @@ import TcTyDecls import TcClassDcl import {-# SOURCE #-} TcInstDcls( tcInstDecls1 )-import TcDeriv (DerivInfo)+import TcDeriv (DerivInfo(..)) import TcUnify ( unifyKind ) import TcHsType import ClsInst( AssocInstInfo(..) )@@ -124,7 +124,7 @@ -- classes -- and their implicit Ids,DataCons , [InstInfo GhcRn] -- Source-code instance decls info- , [DerivInfo] -- data family deriving info+ , [DerivInfo] -- Deriving info ) -- Fails if there are any errors tcTyAndClassDecls tyclds_s@@ -160,7 +160,7 @@ -- Step 1: Typecheck the type/class declarations ; traceTc "---- tcTyClGroup ---- {" empty ; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds))- ; tyclss <- tcTyClDecls tyclds role_annots+ ; (tyclss, data_deriv_info) <- tcTyClDecls tyclds role_annots -- Step 1.5: Make sure we don't have any type synonym cycles ; traceTc "Starting synonym cycle check" (ppr tyclss)@@ -186,12 +186,20 @@ ; gbl_env <- addTyConsToGblEnv tyclss -- Step 4: check instance declarations- ; setGblEnv gbl_env $- tcInstDecls1 instds }+ ; (gbl_env', inst_info, datafam_deriv_info) <-+ setGblEnv gbl_env $+ tcInstDecls1 instds -tcTyClGroup (XTyClGroup _) = panic "tcTyClGroup"+ ; let deriv_info = datafam_deriv_info ++ data_deriv_info+ ; return (gbl_env', inst_info, deriv_info) } -tcTyClDecls :: [LTyClDecl GhcRn] -> RoleAnnotEnv -> TcM [TyCon]++tcTyClGroup (XTyClGroup nec) = noExtCon nec++tcTyClDecls+ :: [LTyClDecl GhcRn]+ -> RoleAnnotEnv+ -> TcM ([TyCon], [DerivInfo]) tcTyClDecls tyclds role_annots = tcExtendKindEnv promotion_err_env $ --- See Note [Type environment evolution] do { -- Step 1: kind-check this group and returns the final@@ -206,7 +214,7 @@ -- NB: We have to be careful here to NOT eagerly unfold -- type synonyms, as we have not tested for type synonym -- loops yet and could fall into a black hole.- ; fixM $ \ ~rec_tyclss -> do+ ; fixM $ \ ~(rec_tyclss, _) -> do { tcg_env <- getGblEnv ; let roles = inferRoles (tcg_src tcg_env) role_annots rec_tyclss @@ -214,7 +222,8 @@ -- NB: if the decls mention any ill-staged data cons -- (see Note [Recursion and promoting data constructors]) -- we will have failed already in kcTyClGroup, so no worries here- ; tcExtendRecEnv (zipRecTyClss tc_tycons rec_tyclss) $+ ; (tycons, data_deriv_infos) <-+ tcExtendRecEnv (zipRecTyClss tc_tycons rec_tyclss) $ -- Also extend the local type envt with bindings giving -- a TcTyCon for each each knot-tied TyCon or Class@@ -223,7 +232,8 @@ tcExtendKindEnvWithTyCons tc_tycons $ -- Kind and type check declarations for this group- mapM (tcTyClDecl roles) tyclds+ mapAndUnzipM (tcTyClDecl roles) tyclds+ ; return (tycons, concat data_deriv_infos) } } where promotion_err_env = mkPromotionErrorEnv tyclds@@ -1069,8 +1079,8 @@ HsKindSig _ _ k -> Just k _ -> Nothing -getInitialKind _ (DataDecl _ _ _ _ (XHsDataDefn _)) = panic "getInitialKind"-getInitialKind _ (XTyClDecl _) = panic "getInitialKind"+getInitialKind _ (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec+getInitialKind _ (XTyClDecl nec) = noExtCon nec --------------------------------- getFamDeclInitialKinds@@ -1111,7 +1121,7 @@ ClosedTypeFamily _ -> ASSERT( isNothing mb_parent_tycon ) ClosedTypeFamilyFlavour ctxt = TyFamResKindCtxt name-getFamDeclInitialKind _ _ (XFamilyDecl _) = panic "getFamDeclInitialKind"+getFamDeclInitialKind _ _ (XFamilyDecl nec) = noExtCon nec ------------------------------------------------------------------------ kcLTyClDecl :: LTyClDecl GhcRn -> TcM ()@@ -1138,8 +1148,7 @@ , dd_ND = new_or_data } <- defn = do { tyCon <- kcLookupTcTyCon name -- See Note [Implementation of UnliftedNewtypes] STEP 2- ; (_, final_res_kind) <- etaExpandAlgTyCon (tyConBinders tyCon) (tyConResKind tyCon)- ; mapM_ (wrapLocM_ (kcConDecl new_or_data final_res_kind)) cons+ ; kcConDecls new_or_data (tyConResKind tyCon) cons } -- hs_tvs and dd_kindSig already dealt with in getInitialKind -- This must be a GADT-style decl,@@ -1154,7 +1163,7 @@ = bindTyClTyVars name $ \ _ _ -> do { _ <- tcHsContext ctxt ; tyCon <- kcLookupTcTyCon name- ; mapM_ (wrapLocM_ (kcConDecl new_or_data (tyConResKind tyCon))) cons+ ; kcConDecls new_or_data (tyConResKind tyCon) cons } kcTyClDecl (SynDecl { tcdLName = dL->L _ name, tcdRhs = rhs })@@ -1183,9 +1192,9 @@ do { fam_tc <- kcLookupTcTyCon fam_tc_name ; mapM_ (kcTyFamInstEqn fam_tc) eqns } _ -> return ()-kcTyClDecl (FamDecl _ (XFamilyDecl _)) = panic "kcTyClDecl"-kcTyClDecl (DataDecl _ _ _ _ (XHsDataDefn _)) = panic "kcTyClDecl"-kcTyClDecl (XTyClDecl _) = panic "kcTyClDecl"+kcTyClDecl (FamDecl _ (XFamilyDecl nec)) = noExtCon nec+kcTyClDecl (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec+kcTyClDecl (XTyClDecl nec) = noExtCon nec ------------------- @@ -1223,16 +1232,27 @@ unifyNewtypeKind dflags new_or_data arg_tys arg_tc_tys res_kind } +kcConDecls :: NewOrData+ -> Kind -- The result kind signature+ -> [LConDecl GhcRn] -- The data constructors+ -> TcM ()+kcConDecls new_or_data res_kind cons+ = mapM_ (wrapLocM_ (kcConDecl new_or_data final_res_kind)) cons+ where+ (_, final_res_kind) = splitPiTys res_kind+ -- See Note [kcConDecls result kind]+ -- Kind check a data constructor. In additional to the data constructor, -- we also need to know about whether or not its corresponding type was -- declared with data or newtype, and we need to know the result kind of -- this type. See Note [Implementation of UnliftedNewtypes] for why -- we need the first two arguments.-kcConDecl ::- NewOrData -- Was the corresponding type declared with data or newtype?- -> Kind -- The result kind of the corresponding type constructor- -> ConDecl GhcRn -- The data constructor- -> TcM ()+kcConDecl :: NewOrData+ -> Kind -- Result kind of the type constructor+ -- Usually Type but can be TYPE UnliftedRep+ -- or even TYPE r, in the case of unlifted newtype+ -> ConDecl GhcRn+ -> TcM () kcConDecl new_or_data res_kind (ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs , con_mb_cxt = ex_ctxt, con_args = args })@@ -1241,8 +1261,8 @@ bindExplicitTKBndrs_Tv ex_tvs $ do { _ <- tcHsMbContext ex_ctxt ; kcConArgTys new_or_data res_kind (hsConDeclArgTys args)- -- We don't need to check the telescope here, because that's- -- done in tcConDecl+ -- We don't need to check the telescope here,+ -- because that's done in tcConDecl } kcConDecl new_or_data res_kind (ConDeclGADT@@ -1250,8 +1270,8 @@ , con_args = args, con_res_ty = res_ty }) | HsQTvs { hsq_ext = implicit_tkv_nms , hsq_explicit = explicit_tkv_nms } <- qtvs- = -- Even though the data constructor's type is closed, we- -- must still kind-check the type, because that may influence+ = -- Even though the GADT-style data constructor's type is closed,+ -- we must still kind-check the type, because that may influence -- the inferred kind of the /type/ constructor. Example: -- data T f a where -- MkT :: f a -> T f a@@ -1266,10 +1286,34 @@ ; kcConArgTys new_or_data res_kind (hsConDeclArgTys args) ; _ <- tcHsOpenType res_ty ; return () }-kcConDecl _ _ (ConDeclGADT _ _ _ (XLHsQTyVars _) _ _ _ _) = panic "kcConDecl"-kcConDecl _ _ (XConDecl _) = panic "kcConDecl"+kcConDecl _ _ (ConDeclGADT _ _ _ (XLHsQTyVars nec) _ _ _ _) = noExtCon nec+kcConDecl _ _ (XConDecl nec) = noExtCon nec -{-+{- Note [kcConDecls result kind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We might have e.g.+ data T a :: Type -> Type where ...+or+ newtype instance N a :: Type -> Type where ..+in which case, the 'res_kind' passed to kcConDecls will be+ Type->Type++We must look past those arrows, or even foralls, to the Type in the+corner, to pass to kcConDecl c.f. #16828. Hence the splitPiTys here.++I am a bit concerned about tycons with a declaration like+ data T a :: Type -> forall k. k -> Type where ...++It does not have a CUSK, so kcLHsQTyVars_NonCusk will make a TcTyCon+with tyConResKind of Type -> forall k. k -> Type. Even that is fine:+the splitPiTys will look past the forall. But I'm bothered about+what if the type "in the corner" metions k? This is incredibly+obscure but something like this could be bad:+ data T a :: Type -> foral k. k -> TYPE (F k) where ...++I bet we are not quite right here, but my brain suffered a buffer+overflow and I thought it best to nail the common cases right now.+ Note [Recursion and promoting data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We don't want to allow promotion in a strongly connected component@@ -1493,7 +1537,7 @@ 2. In a newtype instance (with -XUnliftedNewtypes), if the user does not write a kind signature, we want to allow the possibility that the kind is not Type, so we use newOpenTypeKind instead of liftedTypeKind.- This is done in tcDataFamHeader in TcInstDcls. Example:+ This is done in tcDataFamInstHeader in TcInstDcls. Example: data family Bar (a :: RuntimeRep) :: TYPE a newtype instance Bar 'IntRep = BarIntC Int#@@ -1521,40 +1565,55 @@ -} -tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM TyCon+tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM (TyCon, [DerivInfo]) tcTyClDecl roles_info (dL->L loc decl) | Just thing <- wiredInNameTyThing_maybe (tcdName decl) = case thing of -- See Note [Declarations for wired-in things]- ATyCon tc -> return tc+ ATyCon tc -> return (tc, wiredInDerivInfo tc decl) _ -> pprPanic "tcTyClDecl" (ppr thing) | otherwise = setSrcSpan loc $ tcAddDeclCtxt decl $ do { traceTc "---- tcTyClDecl ---- {" (ppr decl)- ; tc <- tcTyClDecl1 Nothing roles_info decl+ ; (tc, deriv_infos) <- tcTyClDecl1 Nothing roles_info decl ; traceTc "---- tcTyClDecl end ---- }" (ppr tc)- ; return tc }+ ; return (tc, deriv_infos) } +noDerivInfos :: a -> (a, [DerivInfo])+noDerivInfos a = (a, [])++wiredInDerivInfo :: TyCon -> TyClDecl GhcRn -> [DerivInfo]+wiredInDerivInfo tycon decl+ | DataDecl { tcdDataDefn = dataDefn } <- decl+ , HsDataDefn { dd_derivs = derivs } <- dataDefn+ = [ DerivInfo { di_rep_tc = tycon+ , di_clauses = unLoc derivs+ , di_ctxt = tcMkDeclCtxt decl } ]+wiredInDerivInfo _ _ = []+ -- "type family" declarations-tcTyClDecl1 :: Maybe Class -> RolesInfo -> TyClDecl GhcRn -> TcM TyCon+tcTyClDecl1 :: Maybe Class -> RolesInfo -> TyClDecl GhcRn -> TcM (TyCon, [DerivInfo]) tcTyClDecl1 parent _roles_info (FamDecl { tcdFam = fd })- = tcFamDecl1 parent fd+ = fmap noDerivInfos $+ tcFamDecl1 parent fd -- "type" synonym declaration tcTyClDecl1 _parent roles_info (SynDecl { tcdLName = (dL->L _ tc_name) , tcdRhs = rhs }) = ASSERT( isNothing _parent )+ fmap noDerivInfos $ bindTyClTyVars tc_name $ \ binders res_kind -> tcTySynRhs roles_info tc_name binders res_kind rhs -- "data/newtype" declaration tcTyClDecl1 _parent roles_info- (DataDecl { tcdLName = (dL->L _ tc_name)- , tcdDataDefn = defn })+ decl@(DataDecl { tcdLName = (dL->L _ tc_name)+ , tcdDataDefn = defn }) = ASSERT( isNothing _parent ) bindTyClTyVars tc_name $ \ tycon_binders res_kind ->- tcDataDefn roles_info tc_name tycon_binders res_kind defn+ tcDataDefn (tcMkDeclCtxt decl) roles_info tc_name+ tycon_binders res_kind defn tcTyClDecl1 _parent roles_info (ClassDecl { tcdLName = (dL->L _ class_name)@@ -1567,9 +1626,9 @@ = ASSERT( isNothing _parent ) do { clas <- tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs- ; return (classTyCon clas) }+ ; return (noDerivInfos (classTyCon clas)) } -tcTyClDecl1 _ _ (XTyClDecl _) = panic "tcTyClDecl1"+tcTyClDecl1 _ _ (XTyClDecl nec) = noExtCon nec {- *********************************************************************@@ -1947,7 +2006,7 @@ ; return fam_tc } } | otherwise = panic "tcFamInst1" -- Silence pattern-exhaustiveness checker-tcFamDecl1 _ (XFamilyDecl _) = panic "tcFamDecl1"+tcFamDecl1 _ (XFamilyDecl nec) = noExtCon nec -- | Maybe return a list of Bools that say whether a type family was declared -- injective in the corresponding type arguments. Length of the list is equal to@@ -2009,17 +2068,20 @@ tycon = buildSynTyCon tc_name binders res_kind roles rhs_ty ; return tycon } -tcDataDefn :: RolesInfo -> Name+tcDataDefn :: SDoc+ -> RolesInfo -> Name -> [TyConBinder] -> Kind- -> HsDataDefn GhcRn -> TcM TyCon+ -> HsDataDefn GhcRn -> TcM (TyCon, [DerivInfo]) -- NB: not used for newtype/data instances (whether associated or not)-tcDataDefn roles_info+tcDataDefn err_ctxt+ roles_info tc_name tycon_binders res_kind (HsDataDefn { dd_ND = new_or_data, dd_cType = cType , dd_ctxt = ctxt , dd_kindSig = mb_ksig -- Already in tc's kind -- via getInitialKinds- , dd_cons = cons })+ , dd_cons = cons+ , dd_derivs = derivs }) = do { gadt_syntax <- dataDeclChecks tc_name new_or_data ctxt cons ; tcg_env <- getGblEnv@@ -2057,8 +2119,11 @@ stupid_theta tc_rhs (VanillaAlgTyCon tc_rep_nm) gadt_syntax) }+ ; let deriv_info = DerivInfo { di_rep_tc = tycon+ , di_clauses = unLoc derivs+ , di_ctxt = err_ctxt } ; traceTc "tcDataDefn" (ppr tc_name $$ ppr tycon_binders $$ ppr extra_bndrs)- ; return tycon }+ ; return (tycon, [deriv_info]) } where -- Abstract data types in hsig files can have arbitrary kinds, -- because they may be implemented by type synonyms@@ -2084,7 +2149,7 @@ DataType -> return (mkDataTyConRhs data_cons) NewType -> ASSERT( not (null data_cons) ) mkNewTyConRhs tc_name tycon (head data_cons)-tcDataDefn _ _ _ _ (XHsDataDefn _) = panic "tcDataDefn"+tcDataDefn _ _ _ _ _ (XHsDataDefn nec) = noExtCon nec -------------------------@@ -2122,8 +2187,8 @@ where vis_arity = length (tyConVisibleTyVars tc_fam_tc) -kcTyFamInstEqn _ (dL->L _ (XHsImplicitBndrs _)) = panic "kcTyFamInstEqn"-kcTyFamInstEqn _ (dL->L _ (HsIB _ (XFamEqn _))) = panic "kcTyFamInstEqn"+kcTyFamInstEqn _ (dL->L _ (XHsImplicitBndrs nec)) = noExtCon nec+kcTyFamInstEqn _ (dL->L _ (HsIB _ (XFamEqn nec))) = noExtCon nec kcTyFamInstEqn _ _ = panic "kcTyFamInstEqn: Impossible Match" -- due to #15884 @@ -2246,7 +2311,7 @@ -- See Note [Generalising in tcTyFamInstEqnGuts] -- This code (and the stuff immediately above) is very similar- -- to that in tcDataFamHeader. Maybe we should abstract the+ -- to that in tcDataFamInstHeader. Maybe we should abstract the -- common code; but for the moment I concluded that it's -- clearer to duplicate it. Still, if you fix a bug here, -- check there too!@@ -2289,7 +2354,7 @@ where fam_name = tyConName fam_tc fam_arity = tyConArity fam_tc- lhs_fun = noLoc (HsTyVar noExt NotPromoted (noLoc fam_name))+ lhs_fun = noLoc (HsTyVar noExtField NotPromoted (noLoc fam_name)) unravelFamInstPats :: TcType -> [TcType] -- Decompose fam_app to get the argument patterns@@ -2653,9 +2718,9 @@ ; traceTc "tcConDecl 2" (ppr names) ; mapM buildOneDataCon names }-tcConDecl _ _ _ _ _ _ (ConDeclGADT _ _ _ (XLHsQTyVars _) _ _ _ _)- = panic "tcConDecl"-tcConDecl _ _ _ _ _ _ (XConDecl _) = panic "tcConDecl"+tcConDecl _ _ _ _ _ _ (ConDeclGADT _ _ _ (XLHsQTyVars nec) _ _ _ _)+ = noExtCon nec+tcConDecl _ _ _ _ _ _ (XConDecl nec) = noExtCon nec tcConIsInfixH98 :: Name -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])@@ -3975,8 +4040,8 @@ HsIB { hsib_body = eqn }}) = tcMkFamInstCtxt (pprDataFamInstFlavour decl <+> text "instance") (unLoc (feqn_tycon eqn))-tcMkDataFamInstCtxt (DataFamInstDecl (XHsImplicitBndrs _))- = panic "tcMkDataFamInstCtxt"+tcMkDataFamInstCtxt (DataFamInstDecl (XHsImplicitBndrs nec))+ = noExtCon nec tcAddDataFamInstCtxt :: DataFamInstDecl GhcRn -> TcM a -> TcM a tcAddDataFamInstCtxt decl@@ -4168,7 +4233,7 @@ text "Expected" <+> (ppr $ length tyvars) <> comma <+> text "got" <+> (ppr $ length annots) <> colon) 2 (ppr d)-wrongNumberOfRoles _ (dL->L _ (XRoleAnnotDecl _)) = panic "wrongNumberOfRoles"+wrongNumberOfRoles _ (dL->L _ (XRoleAnnotDecl nec)) = noExtCon nec wrongNumberOfRoles _ _ = panic "wrongNumberOfRoles: Impossible Match" -- due to #15884 @@ -4179,7 +4244,7 @@ setSrcSpan loc $ addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$ text "they are allowed only for datatypes and classes.")-illegalRoleAnnotDecl (dL->L _ (XRoleAnnotDecl _)) = panic "illegalRoleAnnotDecl"+illegalRoleAnnotDecl (dL->L _ (XRoleAnnotDecl nec)) = noExtCon nec illegalRoleAnnotDecl _ = panic "illegalRoleAnnotDecl: Impossible Match" -- due to #15884
compiler/typecheck/TcTyDecls.hs view
@@ -832,8 +832,8 @@ tcValBinds TopLevel binds sigs getGblEnv ; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) } where- sigs = [ cL loc (IdSig noExt sel_id) | (sel_id, _) <- sel_bind_prs- , let loc = getSrcSpan sel_id ]+ sigs = [ cL loc (IdSig noExtField sel_id) | (sel_id, _) <- sel_bind_prs+ , let loc = getSrcSpan sel_id ] binds = [(NonRecursive, unitBag bind) | (_, bind) <- sel_bind_prs] mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)]@@ -892,7 +892,7 @@ | otherwise = map mk_match cons_w_field ++ deflt mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname) [cL loc (mk_sel_pat con)]- (cL loc (HsVar noExt (cL loc field_var)))+ (cL loc (HsVar noExtField (cL loc field_var))) mk_sel_pat con = ConPatIn (cL loc (getName con)) (RecCon rec_fields) rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing } rec_field = noLoc (HsRecField@@ -900,7 +900,7 @@ = cL loc (FieldOcc sel_name (cL loc $ mkVarUnqual lbl)) , hsRecFieldArg- = cL loc (VarPat noExt (cL loc field_var))+ = cL loc (VarPat noExtField (cL loc field_var)) , hsRecPun = False }) sel_lname = cL loc sel_name field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc@@ -910,10 +910,10 @@ -- mentions this particular record selector deflt | all dealt_with all_cons = [] | otherwise = [mkSimpleMatch CaseAlt- [cL loc (WildPat noExt)]- (mkHsApp (cL loc (HsVar noExt+ [cL loc (WildPat noExtField)]+ (mkHsApp (cL loc (HsVar noExtField (cL loc (getName rEC_SEL_ERROR_ID))))- (cL loc (HsLit noExt msg_lit)))]+ (cL loc (HsLit noExtField msg_lit)))] -- Do not add a default case unless there are unmatched -- constructors. We must take account of GADTs, else we
compiler/typecheck/TcUnify.hs view
@@ -64,6 +64,7 @@ import qualified GHC.LanguageExtensions as LangExt import Outputable +import Data.Maybe( isNothing ) import Control.Monad import Control.Arrow ( second ) @@ -1176,7 +1177,13 @@ -> TcLevel -> WantedConstraints -> TcM () emitResidualTvConstraint skol_info m_telescope skol_tvs tclvl wanted | isEmptyWC wanted+ , isNothing m_telescope || skol_tvs `lengthAtMost` 1+ -- If m_telescope is (Just d), we must do the bad-telescope check,+ -- so we must /not/ discard the implication even if there are no+ -- wanted constraints. See Note [Checking telescopes] in TcRnTypes.+ -- Lacking this check led to #16247 = return ()+ | otherwise = do { ev_binds <- newNoTcEvBinds ; implic <- newImplication@@ -1388,7 +1395,7 @@ = do { co_tys <- uType t_or_k origin t1 t2 ; return (mkCoherenceRightCo Nominal t2 co2 co_tys) } - -- Variables; go for uVar+ -- Variables; go for uUnfilledVar -- Note that we pass in *original* (before synonym expansion), -- so that type variables tend to get filled in with -- the most informative version of the type@@ -1576,11 +1583,11 @@ ************************************************************************ * *- uVar and friends+ uUnfilledVar and friends * * ************************************************************************ -@uVar@ is called when at least one of the types being unified is a+@uunfilledVar@ is called when at least one of the types being unified is a variable. It does {\em not} assume that the variable is a fixed point of the substitution; rather, notice that @uVar@ (defined below) nips back into @uTys@ if it turns out that the variable is already bound.@@ -1590,7 +1597,8 @@ uUnfilledVar :: CtOrigin -> TypeOrKind -> SwapFlag- -> TcTyVar -- Tyvar 1+ -> TcTyVar -- Tyvar 1: not necessarily a meta-tyvar+ -- definitely not a /filled/ meta-tyvar -> TcTauType -- Type 2 -> TcM Coercion -- "Unfilled" means that the variable is definitely not a filled-in meta tyvar@@ -1608,7 +1616,8 @@ uUnfilledVar1 :: CtOrigin -> TypeOrKind -> SwapFlag- -> TcTyVar -- Tyvar 1+ -> TcTyVar -- Tyvar 1: not necessarily a meta-tyvar+ -- definitely not a /filled/ meta-tyvar -> TcTauType -- Type 2, zonked -> TcM Coercion uUnfilledVar1 origin t_or_k swapped tv1 ty2@@ -1621,12 +1630,19 @@ where -- 'go' handles the case where both are -- tyvars so we might want to swap+ -- E.g. maybe tv2 is a meta-tyvar and tv1 is not go tv2 | tv1 == tv2 -- Same type variable => no-op = return (mkNomReflCo (mkTyVarTy tv1)) | swapOverTyVars tv1 tv2 -- Distinct type variables- = uUnfilledVar2 origin t_or_k (flipSwap swapped)- tv2 (mkTyVarTy tv1)+ -- Swap meta tyvar to the left if poss+ = do { tv1 <- zonkTyCoVarKind tv1+ -- We must zonk tv1's kind because that might+ -- not have happened yet, and it's an invariant of+ -- uUnfilledTyVar2 that ty2 is fully zonked+ -- Omitting this caused #16902+ ; uUnfilledVar2 origin t_or_k (flipSwap swapped)+ tv2 (mkTyVarTy tv1) } | otherwise = uUnfilledVar2 origin t_or_k swapped tv1 ty2@@ -1635,7 +1651,8 @@ uUnfilledVar2 :: CtOrigin -> TypeOrKind -> SwapFlag- -> TcTyVar -- Tyvar 1+ -> TcTyVar -- Tyvar 1: not necessarily a meta-tyvar+ -- definitely not a /filled/ meta-tyvar -> TcTauType -- Type 2, zonked -> TcM Coercion uUnfilledVar2 origin t_or_k swapped tv1 ty2@@ -1652,8 +1669,10 @@ , ppr ty2 <+> dcolon <+> ppr (tcTypeKind ty2) , ppr (isTcReflCo co_k), ppr co_k ] - ; if isTcReflCo co_k -- only proceed if the kinds matched.-+ ; if isTcReflCo co_k+ -- Only proceed if the kinds match+ -- NB: tv1 should still be unfilled, despite the kind unification+ -- because tv1 is not free in ty2 (or, hence, in its kind) then do { writeMetaTyVar tv1 ty2' ; return (mkTcNomReflCo ty2') }
compiler/typecheck/TcValidity.hs view
@@ -27,6 +27,7 @@ import TcUnify ( tcSubType_NC ) import TcSimplify ( simplifyAmbiguityCheck ) import ClsInst ( matchGlobalInst, ClsInstResult(..), InstanceWhat(..), AssocInstInfo(..) )+import TyCoFVs import TyCoRep import TcType hiding ( sizeType, sizeTypes ) import TysWiredIn ( heqTyConName, eqTyConName, coercibleTyConName )@@ -2141,7 +2142,7 @@ , text "qtvs:" <+> ppr qtvs , text "rhs_tvs:" <+> ppr (fvVarSet rhs_fvs) , text "pat_tvs:" <+> ppr pat_tvs- , text "exact_pat_tvs:" <+> ppr exact_pat_tvs ]+ , text "inj_pat_tvs:" <+> ppr inj_pat_tvs ] -- Check for implicitly-bound tyvars, mentioned on the -- RHS but not bound on the LHS@@ -2161,15 +2162,21 @@ (text "used in") } where- pat_tvs = tyCoVarsOfTypes pats- exact_pat_tvs = exactTyCoVarsOfTypes pats- rhs_fvs = tyCoFVsOfType rhs- used_tvs = pat_tvs `unionVarSet` fvVarSet rhs_fvs- bad_qtvs = filterOut (`elemVarSet` used_tvs) qtvs- -- Bound but not used at all- bad_rhs_tvs = filterOut (`elemVarSet` exact_pat_tvs) (fvVarList rhs_fvs)- -- Used on RHS but not bound on LHS- dodgy_tvs = pat_tvs `minusVarSet` exact_pat_tvs+ pat_tvs = tyCoVarsOfTypes pats+ inj_pat_tvs = fvVarSet $ injectiveVarsOfTypes pats+ -- The type variables that are in injective positions.+ -- See Note [Dodgy binding sites in type family instances]+ --+ -- NB: It's OK to use the nondeterministic `fvVarSet` function here,+ -- since the order of `inj_pat_tvs` is never revealed in an error+ -- message.+ rhs_fvs = tyCoFVsOfType rhs+ used_tvs = pat_tvs `unionVarSet` fvVarSet rhs_fvs+ bad_qtvs = filterOut (`elemVarSet` used_tvs) qtvs+ -- Bound but not used at all+ bad_rhs_tvs = filterOut (`elemVarSet` inj_pat_tvs) (fvVarList rhs_fvs)+ -- Used on RHS but not bound on LHS+ dodgy_tvs = pat_tvs `minusVarSet` inj_pat_tvs check_tvs tvs what what2 = unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $@@ -2328,10 +2335,10 @@ type family T :: k type instance T = (Nothing :: Maybe a) -Upon a cursory glance, it may appear that the kind variable `a` is-free-floating above, since there are no (visible) LHS patterns in-`T`. However, there is an *invisible* pattern due to the return kind,-so inside of GHC, the instance looks closer to this:+Upon a cursory glance, it may appear that the kind variable `a` is unbound+since there are no (visible) LHS patterns in `T`. However, there is an+*invisible* pattern due to the return kind, so inside of GHC, the instance+looks closer to this: type family T @k :: k type instance T @(Maybe a) = (Nothing :: Maybe a)@@ -2346,7 +2353,7 @@ type instance T @(*) = Proxy (Nothing :: Maybe a) So this time, `a` is neither bound by a visible nor invisible type pattern on-the LHS, so it would be reported as free-floating.+the LHS, so `a` would be reported as not in scope. Finally, here's one more brain-teaser (from #9574). In the example below: @@ -2355,13 +2362,51 @@ instance Funct ('KProxy :: KProxy o) where type Codomain 'KProxy = NatTr (Proxy :: o -> *) -As it turns out, `o` is not free-floating in this example. That is because `o`+As it turns out, `o` is in scope in this example. That is because `o` is bound by the kind signature of the LHS type pattern 'KProxy. To make this more obvious, one can also write the instance like so: instance Funct ('KProxy :: KProxy o) where type Codomain ('KProxy :: KProxy o) = NatTr (Proxy :: o -> *) +Note [Dodgy binding sites in type family instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following example (from #7536):++ type T a = Int+ type instance F (T a) = a++This `F` instance is extremely fishy, since the RHS, `a`, purports to be+"bound" by the LHS pattern `T a`. "Bound" has scare quotes around it because+`T a` expands to `Int`, which doesn't mention at all, so it's as if one had+actually written:++ type instance F Int = a++That is clearly bogus, so to reject this, we check that every type variable+that is mentioned on the RHS is /actually/ bound on the LHS. In other words,+we need to do something slightly more sophisticated that just compute the free+variables of the LHS patterns.++It's tempting to just expand all type synonyms on the LHS and then compute+their free variables, but even that isn't sophisticated enough. After all,+an impish user could write the following (#17008):++ type family ConstType (a :: Type) :: Type where+ ConstType _ = Type++ type family F (x :: ConstType a) :: Type where+ F (x :: ConstType a) = a++Just like in the previous example, the `a` on the RHS isn't actually bound+on the LHS, but this time a type family is responsible for the deception, not+a type synonym.++We avoid both issues by requiring that all RHS type variables are mentioned+in injective positions on the left-hand side (by way of+`injectiveVarsOfTypes`). For instance, the `a` in `T a` is not in an injective+position, as `T` is not an injective type constructor, so we do not count that.+Similarly for the `a` in `ConstType a`. Note [Matching in the consistent-instantation check] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-version: 0.20190703+version: 0.20190806 license: BSD3 license-file: LICENSE category: Development@@ -42,11 +42,9 @@ ghc-lib/stage1/compiler/build/primop-vector-tys.hs-incl ghc-lib/stage1/compiler/build/primop-vector-uniques.hs-incl ghc-lib/stage0/compiler/build/Fingerprint.hs- includes/*.h+ includes/ghcconfig.h+ includes/MachDeps.h includes/CodeGen.Platform.hs- includes/rts/*.h- includes/rts/storage/*.h- includes/rts/prof/*.h compiler/nativeGen/*.h compiler/utils/*.h compiler/*.h@@ -59,6 +57,7 @@ default-language: Haskell2010 default-extensions: NoImplicitPrelude include-dirs:+ includes ghc-lib/generated ghc-lib/stage0/compiler/build ghc-lib/stage1/compiler/build@@ -86,7 +85,7 @@ transformers == 0.5.*, process >= 1 && < 1.7, hpc == 0.6.*,- ghc-lib-parser == 0.20190703+ ghc-lib-parser == 0.20190806 build-tools: alex >= 3.1, happy >= 1.19.4 other-extensions: BangPatterns@@ -127,11 +126,11 @@ ghc-lib/stage1/compiler/build libraries/template-haskell compiler/specialise- libraries/ghc-boot compiler/nativeGen compiler/profiling compiler/simplCore compiler/typecheck+ libraries/ghc-boot compiler/backpack compiler/simplStg compiler/codeGen@@ -143,10 +142,10 @@ compiler/stranal compiler/rename compiler/stgSyn- libraries/ghci compiler/hsSyn compiler/iface compiler/utils+ libraries/ghci compiler/ghci compiler/main compiler/cmm@@ -227,6 +226,8 @@ GHC.PackageDb, GHC.Platform, GHC.Serialized,+ GHC.UniqueSubdir,+ GHC.Version, GHCi.BreakArray, GHCi.FFI, GHCi.Message,@@ -323,7 +324,11 @@ ToIface, ToolSettings, TrieMap,+ TyCoFVs,+ TyCoPpr, TyCoRep,+ TyCoSubst,+ TyCoTidy, TyCon, Type, TysPrim,@@ -666,42 +671,3 @@ X86.Ppr X86.RegInfo X86.Regs--executable ghc-lib- default-language: Haskell2010- if !os(windows)- build-depends: unix- else- build-depends: Win32- build-depends:- base == 4.*, array, bytestring, directory, process, filepath,- containers, deepseq, ghc-prim, haskeline, time, transformers,- ghc-lib- hs-source-dirs: ghc- ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS- cc-options: -DTHREADED_RTS- cpp-options: -DHAVE_INTERPRETER -DTHREADED_RTS -DGHC_LOADED_INTO_GHCI- other-modules:- GHCi.Leak- GHCi.UI- GHCi.UI.Info- GHCi.UI.Monad- GHCi.UI.Tags- GHCi.Util- other-extensions:- BangPatterns- CPP- FlexibleInstances- LambdaCase- MagicHash- MultiWayIf- NondecreasingIndentation- OverloadedStrings- RankNTypes- RecordWildCards- ScopedTypeVariables- TupleSections- UnboxedTuples- ViewPatterns- default-extensions: NoImplicitPrelude- main-is: Main.hs
ghc-lib/generated/ghcplatform.h view
@@ -22,13 +22,5 @@ #define BUILD_VENDOR "apple" #define HOST_VENDOR "apple" -/* These TARGET macros are for backwards compatibility... DO NOT USE! */-#define TargetPlatform_TYPE x86_64_apple_darwin-#define x86_64_apple_darwin_TARGET 1-#define x86_64_TARGET_ARCH 1-#define TARGET_ARCH "x86_64"-#define darwin_TARGET_OS 1-#define TARGET_OS "darwin"-#define apple_TARGET_VENDOR 1 #endif /* __GHCPLATFORM_H__ */
ghc-lib/generated/ghcversion.h view
@@ -6,7 +6,7 @@ #endif #define __GLASGOW_HASKELL_PATCHLEVEL1__ 0-#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20190703+#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20190804 #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\ ((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \
ghc-lib/stage1/compiler/build/ghc_boot_platform.h view
@@ -6,28 +6,20 @@ #define x86_64_apple_darwin_BUILD 1 #define x86_64_apple_darwin_HOST 1-#define x86_64_apple_darwin_TARGET 1 #define x86_64_BUILD_ARCH 1 #define x86_64_HOST_ARCH 1-#define x86_64_TARGET_ARCH 1 #define BUILD_ARCH "x86_64" #define HOST_ARCH "x86_64"-#define TARGET_ARCH "x86_64"-#define LLVM_TARGET "x86_64-apple-darwin" #define darwin_BUILD_OS 1 #define darwin_HOST_OS 1-#define darwin_TARGET_OS 1 #define BUILD_OS "darwin" #define HOST_OS "darwin"-#define TARGET_OS "darwin" #define apple_BUILD_VENDOR 1 #define apple_HOST_VENDOR 1-#define apple_TARGET_VENDOR 1 #define BUILD_VENDOR "apple" #define HOST_VENDOR "apple"-#define TARGET_VENDOR "apple" #endif /* __PLATFORM_H__ */
ghc-lib/stage1/compiler/build/primop-data-decl.hs-incl view
@@ -541,7 +541,6 @@ | TraceEventOp | TraceEventBinaryOp | TraceMarkerOp- | GetThreadAllocationCounter | SetThreadAllocationCounter | VecBroadcastOp PrimOpVecCat Length Width | VecPackOp PrimOpVecCat Length Width
ghc-lib/stage1/compiler/build/primop-has-side-effects.hs-incl view
@@ -213,7 +213,6 @@ primOpHasSideEffects TraceEventOp = True primOpHasSideEffects TraceEventBinaryOp = True primOpHasSideEffects TraceMarkerOp = True-primOpHasSideEffects GetThreadAllocationCounter = True primOpHasSideEffects SetThreadAllocationCounter = True primOpHasSideEffects (VecReadByteArrayOp _ _ _) = True primOpHasSideEffects (VecWriteByteArrayOp _ _ _) = True
ghc-lib/stage1/compiler/build/primop-list.hs-incl view
@@ -540,7 +540,6 @@ , TraceEventOp , TraceEventBinaryOp , TraceMarkerOp- , GetThreadAllocationCounter , SetThreadAllocationCounter , (VecBroadcastOp IntVec 16 W8) , (VecBroadcastOp IntVec 8 W16)
ghc-lib/stage1/compiler/build/primop-out-of-line.hs-incl view
@@ -97,6 +97,5 @@ primOpOutOfLine TraceEventOp = True primOpOutOfLine TraceEventBinaryOp = True primOpOutOfLine TraceMarkerOp = True-primOpOutOfLine GetThreadAllocationCounter = True primOpOutOfLine SetThreadAllocationCounter = True primOpOutOfLine _ = False
ghc-lib/stage1/compiler/build/primop-primop-info.hs-incl view
@@ -540,7 +540,6 @@ primOpInfo TraceEventOp = mkGenPrimOp (fsLit "traceEvent#") [deltaTyVar] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo TraceEventBinaryOp = mkGenPrimOp (fsLit "traceBinaryEvent#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo TraceMarkerOp = mkGenPrimOp (fsLit "traceMarker#") [deltaTyVar] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo GetThreadAllocationCounter = mkGenPrimOp (fsLit "getThreadAllocationCounter#") [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) primOpInfo SetThreadAllocationCounter = mkGenPrimOp (fsLit "setThreadAllocationCounter#") [] [intPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) primOpInfo (VecBroadcastOp IntVec 16 W8) = mkGenPrimOp (fsLit "broadcastInt8X16#") [] [intPrimTy] (int8X16PrimTy) primOpInfo (VecBroadcastOp IntVec 8 W16) = mkGenPrimOp (fsLit "broadcastInt16X8#") [] [intPrimTy] (int16X8PrimTy)
ghc-lib/stage1/compiler/build/primop-tag.hs-incl view
@@ -1,1205 +1,1204 @@ maxPrimOpTag :: Int-maxPrimOpTag = 1202-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 IntAddOp = 8-primOpTag IntSubOp = 9-primOpTag IntMulOp = 10-primOpTag IntMulMayOfloOp = 11-primOpTag IntQuotOp = 12-primOpTag IntRemOp = 13-primOpTag IntQuotRemOp = 14-primOpTag AndIOp = 15-primOpTag OrIOp = 16-primOpTag XorIOp = 17-primOpTag NotIOp = 18-primOpTag IntNegOp = 19-primOpTag IntAddCOp = 20-primOpTag IntSubCOp = 21-primOpTag IntGtOp = 22-primOpTag IntGeOp = 23-primOpTag IntEqOp = 24-primOpTag IntNeOp = 25-primOpTag IntLtOp = 26-primOpTag IntLeOp = 27-primOpTag ChrOp = 28-primOpTag Int2WordOp = 29-primOpTag Int2FloatOp = 30-primOpTag Int2DoubleOp = 31-primOpTag Word2FloatOp = 32-primOpTag Word2DoubleOp = 33-primOpTag ISllOp = 34-primOpTag ISraOp = 35-primOpTag ISrlOp = 36-primOpTag Int8Extend = 37-primOpTag Int8Narrow = 38-primOpTag Int8NegOp = 39-primOpTag Int8AddOp = 40-primOpTag Int8SubOp = 41-primOpTag Int8MulOp = 42-primOpTag Int8QuotOp = 43-primOpTag Int8RemOp = 44-primOpTag Int8QuotRemOp = 45-primOpTag Int8EqOp = 46-primOpTag Int8GeOp = 47-primOpTag Int8GtOp = 48-primOpTag Int8LeOp = 49-primOpTag Int8LtOp = 50-primOpTag Int8NeOp = 51-primOpTag Word8Extend = 52-primOpTag Word8Narrow = 53-primOpTag Word8NotOp = 54-primOpTag Word8AddOp = 55-primOpTag Word8SubOp = 56-primOpTag Word8MulOp = 57-primOpTag Word8QuotOp = 58-primOpTag Word8RemOp = 59-primOpTag Word8QuotRemOp = 60-primOpTag Word8EqOp = 61-primOpTag Word8GeOp = 62-primOpTag Word8GtOp = 63-primOpTag Word8LeOp = 64-primOpTag Word8LtOp = 65-primOpTag Word8NeOp = 66-primOpTag Int16Extend = 67-primOpTag Int16Narrow = 68-primOpTag Int16NegOp = 69-primOpTag Int16AddOp = 70-primOpTag Int16SubOp = 71-primOpTag Int16MulOp = 72-primOpTag Int16QuotOp = 73-primOpTag Int16RemOp = 74-primOpTag Int16QuotRemOp = 75-primOpTag Int16EqOp = 76-primOpTag Int16GeOp = 77-primOpTag Int16GtOp = 78-primOpTag Int16LeOp = 79-primOpTag Int16LtOp = 80-primOpTag Int16NeOp = 81-primOpTag Word16Extend = 82-primOpTag Word16Narrow = 83-primOpTag Word16NotOp = 84-primOpTag Word16AddOp = 85-primOpTag Word16SubOp = 86-primOpTag Word16MulOp = 87-primOpTag Word16QuotOp = 88-primOpTag Word16RemOp = 89-primOpTag Word16QuotRemOp = 90-primOpTag Word16EqOp = 91-primOpTag Word16GeOp = 92-primOpTag Word16GtOp = 93-primOpTag Word16LeOp = 94-primOpTag Word16LtOp = 95-primOpTag Word16NeOp = 96-primOpTag WordAddOp = 97-primOpTag WordAddCOp = 98-primOpTag WordSubCOp = 99-primOpTag WordAdd2Op = 100-primOpTag WordSubOp = 101-primOpTag WordMulOp = 102-primOpTag WordMul2Op = 103-primOpTag WordQuotOp = 104-primOpTag WordRemOp = 105-primOpTag WordQuotRemOp = 106-primOpTag WordQuotRem2Op = 107-primOpTag AndOp = 108-primOpTag OrOp = 109-primOpTag XorOp = 110-primOpTag NotOp = 111-primOpTag SllOp = 112-primOpTag SrlOp = 113-primOpTag Word2IntOp = 114-primOpTag WordGtOp = 115-primOpTag WordGeOp = 116-primOpTag WordEqOp = 117-primOpTag WordNeOp = 118-primOpTag WordLtOp = 119-primOpTag WordLeOp = 120-primOpTag PopCnt8Op = 121-primOpTag PopCnt16Op = 122-primOpTag PopCnt32Op = 123-primOpTag PopCnt64Op = 124-primOpTag PopCntOp = 125-primOpTag Pdep8Op = 126-primOpTag Pdep16Op = 127-primOpTag Pdep32Op = 128-primOpTag Pdep64Op = 129-primOpTag PdepOp = 130-primOpTag Pext8Op = 131-primOpTag Pext16Op = 132-primOpTag Pext32Op = 133-primOpTag Pext64Op = 134-primOpTag PextOp = 135-primOpTag Clz8Op = 136-primOpTag Clz16Op = 137-primOpTag Clz32Op = 138-primOpTag Clz64Op = 139-primOpTag ClzOp = 140-primOpTag Ctz8Op = 141-primOpTag Ctz16Op = 142-primOpTag Ctz32Op = 143-primOpTag Ctz64Op = 144-primOpTag CtzOp = 145-primOpTag BSwap16Op = 146-primOpTag BSwap32Op = 147-primOpTag BSwap64Op = 148-primOpTag BSwapOp = 149-primOpTag BRev8Op = 150-primOpTag BRev16Op = 151-primOpTag BRev32Op = 152-primOpTag BRev64Op = 153-primOpTag BRevOp = 154-primOpTag Narrow8IntOp = 155-primOpTag Narrow16IntOp = 156-primOpTag Narrow32IntOp = 157-primOpTag Narrow8WordOp = 158-primOpTag Narrow16WordOp = 159-primOpTag Narrow32WordOp = 160-primOpTag DoubleGtOp = 161-primOpTag DoubleGeOp = 162-primOpTag DoubleEqOp = 163-primOpTag DoubleNeOp = 164-primOpTag DoubleLtOp = 165-primOpTag DoubleLeOp = 166-primOpTag DoubleAddOp = 167-primOpTag DoubleSubOp = 168-primOpTag DoubleMulOp = 169-primOpTag DoubleDivOp = 170-primOpTag DoubleNegOp = 171-primOpTag DoubleFabsOp = 172-primOpTag Double2IntOp = 173-primOpTag Double2FloatOp = 174-primOpTag DoubleExpOp = 175-primOpTag DoubleExpM1Op = 176-primOpTag DoubleLogOp = 177-primOpTag DoubleLog1POp = 178-primOpTag DoubleSqrtOp = 179-primOpTag DoubleSinOp = 180-primOpTag DoubleCosOp = 181-primOpTag DoubleTanOp = 182-primOpTag DoubleAsinOp = 183-primOpTag DoubleAcosOp = 184-primOpTag DoubleAtanOp = 185-primOpTag DoubleSinhOp = 186-primOpTag DoubleCoshOp = 187-primOpTag DoubleTanhOp = 188-primOpTag DoubleAsinhOp = 189-primOpTag DoubleAcoshOp = 190-primOpTag DoubleAtanhOp = 191-primOpTag DoublePowerOp = 192-primOpTag DoubleDecode_2IntOp = 193-primOpTag DoubleDecode_Int64Op = 194-primOpTag FloatGtOp = 195-primOpTag FloatGeOp = 196-primOpTag FloatEqOp = 197-primOpTag FloatNeOp = 198-primOpTag FloatLtOp = 199-primOpTag FloatLeOp = 200-primOpTag FloatAddOp = 201-primOpTag FloatSubOp = 202-primOpTag FloatMulOp = 203-primOpTag FloatDivOp = 204-primOpTag FloatNegOp = 205-primOpTag FloatFabsOp = 206-primOpTag Float2IntOp = 207-primOpTag FloatExpOp = 208-primOpTag FloatExpM1Op = 209-primOpTag FloatLogOp = 210-primOpTag FloatLog1POp = 211-primOpTag FloatSqrtOp = 212-primOpTag FloatSinOp = 213-primOpTag FloatCosOp = 214-primOpTag FloatTanOp = 215-primOpTag FloatAsinOp = 216-primOpTag FloatAcosOp = 217-primOpTag FloatAtanOp = 218-primOpTag FloatSinhOp = 219-primOpTag FloatCoshOp = 220-primOpTag FloatTanhOp = 221-primOpTag FloatAsinhOp = 222-primOpTag FloatAcoshOp = 223-primOpTag FloatAtanhOp = 224-primOpTag FloatPowerOp = 225-primOpTag Float2DoubleOp = 226-primOpTag FloatDecode_IntOp = 227-primOpTag NewArrayOp = 228-primOpTag SameMutableArrayOp = 229-primOpTag ReadArrayOp = 230-primOpTag WriteArrayOp = 231-primOpTag SizeofArrayOp = 232-primOpTag SizeofMutableArrayOp = 233-primOpTag IndexArrayOp = 234-primOpTag UnsafeFreezeArrayOp = 235-primOpTag UnsafeThawArrayOp = 236-primOpTag CopyArrayOp = 237-primOpTag CopyMutableArrayOp = 238-primOpTag CloneArrayOp = 239-primOpTag CloneMutableArrayOp = 240-primOpTag FreezeArrayOp = 241-primOpTag ThawArrayOp = 242-primOpTag CasArrayOp = 243-primOpTag NewSmallArrayOp = 244-primOpTag SameSmallMutableArrayOp = 245-primOpTag ReadSmallArrayOp = 246-primOpTag WriteSmallArrayOp = 247-primOpTag SizeofSmallArrayOp = 248-primOpTag SizeofSmallMutableArrayOp = 249-primOpTag IndexSmallArrayOp = 250-primOpTag UnsafeFreezeSmallArrayOp = 251-primOpTag UnsafeThawSmallArrayOp = 252-primOpTag CopySmallArrayOp = 253-primOpTag CopySmallMutableArrayOp = 254-primOpTag CloneSmallArrayOp = 255-primOpTag CloneSmallMutableArrayOp = 256-primOpTag FreezeSmallArrayOp = 257-primOpTag ThawSmallArrayOp = 258-primOpTag CasSmallArrayOp = 259-primOpTag NewByteArrayOp_Char = 260-primOpTag NewPinnedByteArrayOp_Char = 261-primOpTag NewAlignedPinnedByteArrayOp_Char = 262-primOpTag MutableByteArrayIsPinnedOp = 263-primOpTag ByteArrayIsPinnedOp = 264-primOpTag ByteArrayContents_Char = 265-primOpTag SameMutableByteArrayOp = 266-primOpTag ShrinkMutableByteArrayOp_Char = 267-primOpTag ResizeMutableByteArrayOp_Char = 268-primOpTag UnsafeFreezeByteArrayOp = 269-primOpTag SizeofByteArrayOp = 270-primOpTag SizeofMutableByteArrayOp = 271-primOpTag GetSizeofMutableByteArrayOp = 272-primOpTag IndexByteArrayOp_Char = 273-primOpTag IndexByteArrayOp_WideChar = 274-primOpTag IndexByteArrayOp_Int = 275-primOpTag IndexByteArrayOp_Word = 276-primOpTag IndexByteArrayOp_Addr = 277-primOpTag IndexByteArrayOp_Float = 278-primOpTag IndexByteArrayOp_Double = 279-primOpTag IndexByteArrayOp_StablePtr = 280-primOpTag IndexByteArrayOp_Int8 = 281-primOpTag IndexByteArrayOp_Int16 = 282-primOpTag IndexByteArrayOp_Int32 = 283-primOpTag IndexByteArrayOp_Int64 = 284-primOpTag IndexByteArrayOp_Word8 = 285-primOpTag IndexByteArrayOp_Word16 = 286-primOpTag IndexByteArrayOp_Word32 = 287-primOpTag IndexByteArrayOp_Word64 = 288-primOpTag IndexByteArrayOp_Word8AsChar = 289-primOpTag IndexByteArrayOp_Word8AsWideChar = 290-primOpTag IndexByteArrayOp_Word8AsAddr = 291-primOpTag IndexByteArrayOp_Word8AsFloat = 292-primOpTag IndexByteArrayOp_Word8AsDouble = 293-primOpTag IndexByteArrayOp_Word8AsStablePtr = 294-primOpTag IndexByteArrayOp_Word8AsInt16 = 295-primOpTag IndexByteArrayOp_Word8AsInt32 = 296-primOpTag IndexByteArrayOp_Word8AsInt64 = 297-primOpTag IndexByteArrayOp_Word8AsInt = 298-primOpTag IndexByteArrayOp_Word8AsWord16 = 299-primOpTag IndexByteArrayOp_Word8AsWord32 = 300-primOpTag IndexByteArrayOp_Word8AsWord64 = 301-primOpTag IndexByteArrayOp_Word8AsWord = 302-primOpTag ReadByteArrayOp_Char = 303-primOpTag ReadByteArrayOp_WideChar = 304-primOpTag ReadByteArrayOp_Int = 305-primOpTag ReadByteArrayOp_Word = 306-primOpTag ReadByteArrayOp_Addr = 307-primOpTag ReadByteArrayOp_Float = 308-primOpTag ReadByteArrayOp_Double = 309-primOpTag ReadByteArrayOp_StablePtr = 310-primOpTag ReadByteArrayOp_Int8 = 311-primOpTag ReadByteArrayOp_Int16 = 312-primOpTag ReadByteArrayOp_Int32 = 313-primOpTag ReadByteArrayOp_Int64 = 314-primOpTag ReadByteArrayOp_Word8 = 315-primOpTag ReadByteArrayOp_Word16 = 316-primOpTag ReadByteArrayOp_Word32 = 317-primOpTag ReadByteArrayOp_Word64 = 318-primOpTag ReadByteArrayOp_Word8AsChar = 319-primOpTag ReadByteArrayOp_Word8AsWideChar = 320-primOpTag ReadByteArrayOp_Word8AsAddr = 321-primOpTag ReadByteArrayOp_Word8AsFloat = 322-primOpTag ReadByteArrayOp_Word8AsDouble = 323-primOpTag ReadByteArrayOp_Word8AsStablePtr = 324-primOpTag ReadByteArrayOp_Word8AsInt16 = 325-primOpTag ReadByteArrayOp_Word8AsInt32 = 326-primOpTag ReadByteArrayOp_Word8AsInt64 = 327-primOpTag ReadByteArrayOp_Word8AsInt = 328-primOpTag ReadByteArrayOp_Word8AsWord16 = 329-primOpTag ReadByteArrayOp_Word8AsWord32 = 330-primOpTag ReadByteArrayOp_Word8AsWord64 = 331-primOpTag ReadByteArrayOp_Word8AsWord = 332-primOpTag WriteByteArrayOp_Char = 333-primOpTag WriteByteArrayOp_WideChar = 334-primOpTag WriteByteArrayOp_Int = 335-primOpTag WriteByteArrayOp_Word = 336-primOpTag WriteByteArrayOp_Addr = 337-primOpTag WriteByteArrayOp_Float = 338-primOpTag WriteByteArrayOp_Double = 339-primOpTag WriteByteArrayOp_StablePtr = 340-primOpTag WriteByteArrayOp_Int8 = 341-primOpTag WriteByteArrayOp_Int16 = 342-primOpTag WriteByteArrayOp_Int32 = 343-primOpTag WriteByteArrayOp_Int64 = 344-primOpTag WriteByteArrayOp_Word8 = 345-primOpTag WriteByteArrayOp_Word16 = 346-primOpTag WriteByteArrayOp_Word32 = 347-primOpTag WriteByteArrayOp_Word64 = 348-primOpTag WriteByteArrayOp_Word8AsChar = 349-primOpTag WriteByteArrayOp_Word8AsWideChar = 350-primOpTag WriteByteArrayOp_Word8AsAddr = 351-primOpTag WriteByteArrayOp_Word8AsFloat = 352-primOpTag WriteByteArrayOp_Word8AsDouble = 353-primOpTag WriteByteArrayOp_Word8AsStablePtr = 354-primOpTag WriteByteArrayOp_Word8AsInt16 = 355-primOpTag WriteByteArrayOp_Word8AsInt32 = 356-primOpTag WriteByteArrayOp_Word8AsInt64 = 357-primOpTag WriteByteArrayOp_Word8AsInt = 358-primOpTag WriteByteArrayOp_Word8AsWord16 = 359-primOpTag WriteByteArrayOp_Word8AsWord32 = 360-primOpTag WriteByteArrayOp_Word8AsWord64 = 361-primOpTag WriteByteArrayOp_Word8AsWord = 362-primOpTag CompareByteArraysOp = 363-primOpTag CopyByteArrayOp = 364-primOpTag CopyMutableByteArrayOp = 365-primOpTag CopyByteArrayToAddrOp = 366-primOpTag CopyMutableByteArrayToAddrOp = 367-primOpTag CopyAddrToByteArrayOp = 368-primOpTag SetByteArrayOp = 369-primOpTag AtomicReadByteArrayOp_Int = 370-primOpTag AtomicWriteByteArrayOp_Int = 371-primOpTag CasByteArrayOp_Int = 372-primOpTag FetchAddByteArrayOp_Int = 373-primOpTag FetchSubByteArrayOp_Int = 374-primOpTag FetchAndByteArrayOp_Int = 375-primOpTag FetchNandByteArrayOp_Int = 376-primOpTag FetchOrByteArrayOp_Int = 377-primOpTag FetchXorByteArrayOp_Int = 378-primOpTag NewArrayArrayOp = 379-primOpTag SameMutableArrayArrayOp = 380-primOpTag UnsafeFreezeArrayArrayOp = 381-primOpTag SizeofArrayArrayOp = 382-primOpTag SizeofMutableArrayArrayOp = 383-primOpTag IndexArrayArrayOp_ByteArray = 384-primOpTag IndexArrayArrayOp_ArrayArray = 385-primOpTag ReadArrayArrayOp_ByteArray = 386-primOpTag ReadArrayArrayOp_MutableByteArray = 387-primOpTag ReadArrayArrayOp_ArrayArray = 388-primOpTag ReadArrayArrayOp_MutableArrayArray = 389-primOpTag WriteArrayArrayOp_ByteArray = 390-primOpTag WriteArrayArrayOp_MutableByteArray = 391-primOpTag WriteArrayArrayOp_ArrayArray = 392-primOpTag WriteArrayArrayOp_MutableArrayArray = 393-primOpTag CopyArrayArrayOp = 394-primOpTag CopyMutableArrayArrayOp = 395-primOpTag AddrAddOp = 396-primOpTag AddrSubOp = 397-primOpTag AddrRemOp = 398-primOpTag Addr2IntOp = 399-primOpTag Int2AddrOp = 400-primOpTag AddrGtOp = 401-primOpTag AddrGeOp = 402-primOpTag AddrEqOp = 403-primOpTag AddrNeOp = 404-primOpTag AddrLtOp = 405-primOpTag AddrLeOp = 406-primOpTag IndexOffAddrOp_Char = 407-primOpTag IndexOffAddrOp_WideChar = 408-primOpTag IndexOffAddrOp_Int = 409-primOpTag IndexOffAddrOp_Word = 410-primOpTag IndexOffAddrOp_Addr = 411-primOpTag IndexOffAddrOp_Float = 412-primOpTag IndexOffAddrOp_Double = 413-primOpTag IndexOffAddrOp_StablePtr = 414-primOpTag IndexOffAddrOp_Int8 = 415-primOpTag IndexOffAddrOp_Int16 = 416-primOpTag IndexOffAddrOp_Int32 = 417-primOpTag IndexOffAddrOp_Int64 = 418-primOpTag IndexOffAddrOp_Word8 = 419-primOpTag IndexOffAddrOp_Word16 = 420-primOpTag IndexOffAddrOp_Word32 = 421-primOpTag IndexOffAddrOp_Word64 = 422-primOpTag ReadOffAddrOp_Char = 423-primOpTag ReadOffAddrOp_WideChar = 424-primOpTag ReadOffAddrOp_Int = 425-primOpTag ReadOffAddrOp_Word = 426-primOpTag ReadOffAddrOp_Addr = 427-primOpTag ReadOffAddrOp_Float = 428-primOpTag ReadOffAddrOp_Double = 429-primOpTag ReadOffAddrOp_StablePtr = 430-primOpTag ReadOffAddrOp_Int8 = 431-primOpTag ReadOffAddrOp_Int16 = 432-primOpTag ReadOffAddrOp_Int32 = 433-primOpTag ReadOffAddrOp_Int64 = 434-primOpTag ReadOffAddrOp_Word8 = 435-primOpTag ReadOffAddrOp_Word16 = 436-primOpTag ReadOffAddrOp_Word32 = 437-primOpTag ReadOffAddrOp_Word64 = 438-primOpTag WriteOffAddrOp_Char = 439-primOpTag WriteOffAddrOp_WideChar = 440-primOpTag WriteOffAddrOp_Int = 441-primOpTag WriteOffAddrOp_Word = 442-primOpTag WriteOffAddrOp_Addr = 443-primOpTag WriteOffAddrOp_Float = 444-primOpTag WriteOffAddrOp_Double = 445-primOpTag WriteOffAddrOp_StablePtr = 446-primOpTag WriteOffAddrOp_Int8 = 447-primOpTag WriteOffAddrOp_Int16 = 448-primOpTag WriteOffAddrOp_Int32 = 449-primOpTag WriteOffAddrOp_Int64 = 450-primOpTag WriteOffAddrOp_Word8 = 451-primOpTag WriteOffAddrOp_Word16 = 452-primOpTag WriteOffAddrOp_Word32 = 453-primOpTag WriteOffAddrOp_Word64 = 454-primOpTag NewMutVarOp = 455-primOpTag ReadMutVarOp = 456-primOpTag WriteMutVarOp = 457-primOpTag SameMutVarOp = 458-primOpTag AtomicModifyMutVar2Op = 459-primOpTag AtomicModifyMutVar_Op = 460-primOpTag CasMutVarOp = 461-primOpTag CatchOp = 462-primOpTag RaiseOp = 463-primOpTag RaiseIOOp = 464-primOpTag MaskAsyncExceptionsOp = 465-primOpTag MaskUninterruptibleOp = 466-primOpTag UnmaskAsyncExceptionsOp = 467-primOpTag MaskStatus = 468-primOpTag AtomicallyOp = 469-primOpTag RetryOp = 470-primOpTag CatchRetryOp = 471-primOpTag CatchSTMOp = 472-primOpTag NewTVarOp = 473-primOpTag ReadTVarOp = 474-primOpTag ReadTVarIOOp = 475-primOpTag WriteTVarOp = 476-primOpTag SameTVarOp = 477-primOpTag NewMVarOp = 478-primOpTag TakeMVarOp = 479-primOpTag TryTakeMVarOp = 480-primOpTag PutMVarOp = 481-primOpTag TryPutMVarOp = 482-primOpTag ReadMVarOp = 483-primOpTag TryReadMVarOp = 484-primOpTag SameMVarOp = 485-primOpTag IsEmptyMVarOp = 486-primOpTag DelayOp = 487-primOpTag WaitReadOp = 488-primOpTag WaitWriteOp = 489-primOpTag ForkOp = 490-primOpTag ForkOnOp = 491-primOpTag KillThreadOp = 492-primOpTag YieldOp = 493-primOpTag MyThreadIdOp = 494-primOpTag LabelThreadOp = 495-primOpTag IsCurrentThreadBoundOp = 496-primOpTag NoDuplicateOp = 497-primOpTag ThreadStatusOp = 498-primOpTag MkWeakOp = 499-primOpTag MkWeakNoFinalizerOp = 500-primOpTag AddCFinalizerToWeakOp = 501-primOpTag DeRefWeakOp = 502-primOpTag FinalizeWeakOp = 503-primOpTag TouchOp = 504-primOpTag MakeStablePtrOp = 505-primOpTag DeRefStablePtrOp = 506-primOpTag EqStablePtrOp = 507-primOpTag MakeStableNameOp = 508-primOpTag EqStableNameOp = 509-primOpTag StableNameToIntOp = 510-primOpTag CompactNewOp = 511-primOpTag CompactResizeOp = 512-primOpTag CompactContainsOp = 513-primOpTag CompactContainsAnyOp = 514-primOpTag CompactGetFirstBlockOp = 515-primOpTag CompactGetNextBlockOp = 516-primOpTag CompactAllocateBlockOp = 517-primOpTag CompactFixupPointersOp = 518-primOpTag CompactAdd = 519-primOpTag CompactAddWithSharing = 520-primOpTag CompactSize = 521-primOpTag ReallyUnsafePtrEqualityOp = 522-primOpTag ParOp = 523-primOpTag SparkOp = 524-primOpTag SeqOp = 525-primOpTag GetSparkOp = 526-primOpTag NumSparks = 527-primOpTag DataToTagOp = 528-primOpTag TagToEnumOp = 529-primOpTag AddrToAnyOp = 530-primOpTag AnyToAddrOp = 531-primOpTag MkApUpd0_Op = 532-primOpTag NewBCOOp = 533-primOpTag UnpackClosureOp = 534-primOpTag ClosureSizeOp = 535-primOpTag GetApStackValOp = 536-primOpTag GetCCSOfOp = 537-primOpTag GetCurrentCCSOp = 538-primOpTag ClearCCSOp = 539-primOpTag TraceEventOp = 540-primOpTag TraceEventBinaryOp = 541-primOpTag TraceMarkerOp = 542-primOpTag GetThreadAllocationCounter = 543-primOpTag SetThreadAllocationCounter = 544-primOpTag (VecBroadcastOp IntVec 16 W8) = 545-primOpTag (VecBroadcastOp IntVec 8 W16) = 546-primOpTag (VecBroadcastOp IntVec 4 W32) = 547-primOpTag (VecBroadcastOp IntVec 2 W64) = 548-primOpTag (VecBroadcastOp IntVec 32 W8) = 549-primOpTag (VecBroadcastOp IntVec 16 W16) = 550-primOpTag (VecBroadcastOp IntVec 8 W32) = 551-primOpTag (VecBroadcastOp IntVec 4 W64) = 552-primOpTag (VecBroadcastOp IntVec 64 W8) = 553-primOpTag (VecBroadcastOp IntVec 32 W16) = 554-primOpTag (VecBroadcastOp IntVec 16 W32) = 555-primOpTag (VecBroadcastOp IntVec 8 W64) = 556-primOpTag (VecBroadcastOp WordVec 16 W8) = 557-primOpTag (VecBroadcastOp WordVec 8 W16) = 558-primOpTag (VecBroadcastOp WordVec 4 W32) = 559-primOpTag (VecBroadcastOp WordVec 2 W64) = 560-primOpTag (VecBroadcastOp WordVec 32 W8) = 561-primOpTag (VecBroadcastOp WordVec 16 W16) = 562-primOpTag (VecBroadcastOp WordVec 8 W32) = 563-primOpTag (VecBroadcastOp WordVec 4 W64) = 564-primOpTag (VecBroadcastOp WordVec 64 W8) = 565-primOpTag (VecBroadcastOp WordVec 32 W16) = 566-primOpTag (VecBroadcastOp WordVec 16 W32) = 567-primOpTag (VecBroadcastOp WordVec 8 W64) = 568-primOpTag (VecBroadcastOp FloatVec 4 W32) = 569-primOpTag (VecBroadcastOp FloatVec 2 W64) = 570-primOpTag (VecBroadcastOp FloatVec 8 W32) = 571-primOpTag (VecBroadcastOp FloatVec 4 W64) = 572-primOpTag (VecBroadcastOp FloatVec 16 W32) = 573-primOpTag (VecBroadcastOp FloatVec 8 W64) = 574-primOpTag (VecPackOp IntVec 16 W8) = 575-primOpTag (VecPackOp IntVec 8 W16) = 576-primOpTag (VecPackOp IntVec 4 W32) = 577-primOpTag (VecPackOp IntVec 2 W64) = 578-primOpTag (VecPackOp IntVec 32 W8) = 579-primOpTag (VecPackOp IntVec 16 W16) = 580-primOpTag (VecPackOp IntVec 8 W32) = 581-primOpTag (VecPackOp IntVec 4 W64) = 582-primOpTag (VecPackOp IntVec 64 W8) = 583-primOpTag (VecPackOp IntVec 32 W16) = 584-primOpTag (VecPackOp IntVec 16 W32) = 585-primOpTag (VecPackOp IntVec 8 W64) = 586-primOpTag (VecPackOp WordVec 16 W8) = 587-primOpTag (VecPackOp WordVec 8 W16) = 588-primOpTag (VecPackOp WordVec 4 W32) = 589-primOpTag (VecPackOp WordVec 2 W64) = 590-primOpTag (VecPackOp WordVec 32 W8) = 591-primOpTag (VecPackOp WordVec 16 W16) = 592-primOpTag (VecPackOp WordVec 8 W32) = 593-primOpTag (VecPackOp WordVec 4 W64) = 594-primOpTag (VecPackOp WordVec 64 W8) = 595-primOpTag (VecPackOp WordVec 32 W16) = 596-primOpTag (VecPackOp WordVec 16 W32) = 597-primOpTag (VecPackOp WordVec 8 W64) = 598-primOpTag (VecPackOp FloatVec 4 W32) = 599-primOpTag (VecPackOp FloatVec 2 W64) = 600-primOpTag (VecPackOp FloatVec 8 W32) = 601-primOpTag (VecPackOp FloatVec 4 W64) = 602-primOpTag (VecPackOp FloatVec 16 W32) = 603-primOpTag (VecPackOp FloatVec 8 W64) = 604-primOpTag (VecUnpackOp IntVec 16 W8) = 605-primOpTag (VecUnpackOp IntVec 8 W16) = 606-primOpTag (VecUnpackOp IntVec 4 W32) = 607-primOpTag (VecUnpackOp IntVec 2 W64) = 608-primOpTag (VecUnpackOp IntVec 32 W8) = 609-primOpTag (VecUnpackOp IntVec 16 W16) = 610-primOpTag (VecUnpackOp IntVec 8 W32) = 611-primOpTag (VecUnpackOp IntVec 4 W64) = 612-primOpTag (VecUnpackOp IntVec 64 W8) = 613-primOpTag (VecUnpackOp IntVec 32 W16) = 614-primOpTag (VecUnpackOp IntVec 16 W32) = 615-primOpTag (VecUnpackOp IntVec 8 W64) = 616-primOpTag (VecUnpackOp WordVec 16 W8) = 617-primOpTag (VecUnpackOp WordVec 8 W16) = 618-primOpTag (VecUnpackOp WordVec 4 W32) = 619-primOpTag (VecUnpackOp WordVec 2 W64) = 620-primOpTag (VecUnpackOp WordVec 32 W8) = 621-primOpTag (VecUnpackOp WordVec 16 W16) = 622-primOpTag (VecUnpackOp WordVec 8 W32) = 623-primOpTag (VecUnpackOp WordVec 4 W64) = 624-primOpTag (VecUnpackOp WordVec 64 W8) = 625-primOpTag (VecUnpackOp WordVec 32 W16) = 626-primOpTag (VecUnpackOp WordVec 16 W32) = 627-primOpTag (VecUnpackOp WordVec 8 W64) = 628-primOpTag (VecUnpackOp FloatVec 4 W32) = 629-primOpTag (VecUnpackOp FloatVec 2 W64) = 630-primOpTag (VecUnpackOp FloatVec 8 W32) = 631-primOpTag (VecUnpackOp FloatVec 4 W64) = 632-primOpTag (VecUnpackOp FloatVec 16 W32) = 633-primOpTag (VecUnpackOp FloatVec 8 W64) = 634-primOpTag (VecInsertOp IntVec 16 W8) = 635-primOpTag (VecInsertOp IntVec 8 W16) = 636-primOpTag (VecInsertOp IntVec 4 W32) = 637-primOpTag (VecInsertOp IntVec 2 W64) = 638-primOpTag (VecInsertOp IntVec 32 W8) = 639-primOpTag (VecInsertOp IntVec 16 W16) = 640-primOpTag (VecInsertOp IntVec 8 W32) = 641-primOpTag (VecInsertOp IntVec 4 W64) = 642-primOpTag (VecInsertOp IntVec 64 W8) = 643-primOpTag (VecInsertOp IntVec 32 W16) = 644-primOpTag (VecInsertOp IntVec 16 W32) = 645-primOpTag (VecInsertOp IntVec 8 W64) = 646-primOpTag (VecInsertOp WordVec 16 W8) = 647-primOpTag (VecInsertOp WordVec 8 W16) = 648-primOpTag (VecInsertOp WordVec 4 W32) = 649-primOpTag (VecInsertOp WordVec 2 W64) = 650-primOpTag (VecInsertOp WordVec 32 W8) = 651-primOpTag (VecInsertOp WordVec 16 W16) = 652-primOpTag (VecInsertOp WordVec 8 W32) = 653-primOpTag (VecInsertOp WordVec 4 W64) = 654-primOpTag (VecInsertOp WordVec 64 W8) = 655-primOpTag (VecInsertOp WordVec 32 W16) = 656-primOpTag (VecInsertOp WordVec 16 W32) = 657-primOpTag (VecInsertOp WordVec 8 W64) = 658-primOpTag (VecInsertOp FloatVec 4 W32) = 659-primOpTag (VecInsertOp FloatVec 2 W64) = 660-primOpTag (VecInsertOp FloatVec 8 W32) = 661-primOpTag (VecInsertOp FloatVec 4 W64) = 662-primOpTag (VecInsertOp FloatVec 16 W32) = 663-primOpTag (VecInsertOp FloatVec 8 W64) = 664-primOpTag (VecAddOp IntVec 16 W8) = 665-primOpTag (VecAddOp IntVec 8 W16) = 666-primOpTag (VecAddOp IntVec 4 W32) = 667-primOpTag (VecAddOp IntVec 2 W64) = 668-primOpTag (VecAddOp IntVec 32 W8) = 669-primOpTag (VecAddOp IntVec 16 W16) = 670-primOpTag (VecAddOp IntVec 8 W32) = 671-primOpTag (VecAddOp IntVec 4 W64) = 672-primOpTag (VecAddOp IntVec 64 W8) = 673-primOpTag (VecAddOp IntVec 32 W16) = 674-primOpTag (VecAddOp IntVec 16 W32) = 675-primOpTag (VecAddOp IntVec 8 W64) = 676-primOpTag (VecAddOp WordVec 16 W8) = 677-primOpTag (VecAddOp WordVec 8 W16) = 678-primOpTag (VecAddOp WordVec 4 W32) = 679-primOpTag (VecAddOp WordVec 2 W64) = 680-primOpTag (VecAddOp WordVec 32 W8) = 681-primOpTag (VecAddOp WordVec 16 W16) = 682-primOpTag (VecAddOp WordVec 8 W32) = 683-primOpTag (VecAddOp WordVec 4 W64) = 684-primOpTag (VecAddOp WordVec 64 W8) = 685-primOpTag (VecAddOp WordVec 32 W16) = 686-primOpTag (VecAddOp WordVec 16 W32) = 687-primOpTag (VecAddOp WordVec 8 W64) = 688-primOpTag (VecAddOp FloatVec 4 W32) = 689-primOpTag (VecAddOp FloatVec 2 W64) = 690-primOpTag (VecAddOp FloatVec 8 W32) = 691-primOpTag (VecAddOp FloatVec 4 W64) = 692-primOpTag (VecAddOp FloatVec 16 W32) = 693-primOpTag (VecAddOp FloatVec 8 W64) = 694-primOpTag (VecSubOp IntVec 16 W8) = 695-primOpTag (VecSubOp IntVec 8 W16) = 696-primOpTag (VecSubOp IntVec 4 W32) = 697-primOpTag (VecSubOp IntVec 2 W64) = 698-primOpTag (VecSubOp IntVec 32 W8) = 699-primOpTag (VecSubOp IntVec 16 W16) = 700-primOpTag (VecSubOp IntVec 8 W32) = 701-primOpTag (VecSubOp IntVec 4 W64) = 702-primOpTag (VecSubOp IntVec 64 W8) = 703-primOpTag (VecSubOp IntVec 32 W16) = 704-primOpTag (VecSubOp IntVec 16 W32) = 705-primOpTag (VecSubOp IntVec 8 W64) = 706-primOpTag (VecSubOp WordVec 16 W8) = 707-primOpTag (VecSubOp WordVec 8 W16) = 708-primOpTag (VecSubOp WordVec 4 W32) = 709-primOpTag (VecSubOp WordVec 2 W64) = 710-primOpTag (VecSubOp WordVec 32 W8) = 711-primOpTag (VecSubOp WordVec 16 W16) = 712-primOpTag (VecSubOp WordVec 8 W32) = 713-primOpTag (VecSubOp WordVec 4 W64) = 714-primOpTag (VecSubOp WordVec 64 W8) = 715-primOpTag (VecSubOp WordVec 32 W16) = 716-primOpTag (VecSubOp WordVec 16 W32) = 717-primOpTag (VecSubOp WordVec 8 W64) = 718-primOpTag (VecSubOp FloatVec 4 W32) = 719-primOpTag (VecSubOp FloatVec 2 W64) = 720-primOpTag (VecSubOp FloatVec 8 W32) = 721-primOpTag (VecSubOp FloatVec 4 W64) = 722-primOpTag (VecSubOp FloatVec 16 W32) = 723-primOpTag (VecSubOp FloatVec 8 W64) = 724-primOpTag (VecMulOp IntVec 16 W8) = 725-primOpTag (VecMulOp IntVec 8 W16) = 726-primOpTag (VecMulOp IntVec 4 W32) = 727-primOpTag (VecMulOp IntVec 2 W64) = 728-primOpTag (VecMulOp IntVec 32 W8) = 729-primOpTag (VecMulOp IntVec 16 W16) = 730-primOpTag (VecMulOp IntVec 8 W32) = 731-primOpTag (VecMulOp IntVec 4 W64) = 732-primOpTag (VecMulOp IntVec 64 W8) = 733-primOpTag (VecMulOp IntVec 32 W16) = 734-primOpTag (VecMulOp IntVec 16 W32) = 735-primOpTag (VecMulOp IntVec 8 W64) = 736-primOpTag (VecMulOp WordVec 16 W8) = 737-primOpTag (VecMulOp WordVec 8 W16) = 738-primOpTag (VecMulOp WordVec 4 W32) = 739-primOpTag (VecMulOp WordVec 2 W64) = 740-primOpTag (VecMulOp WordVec 32 W8) = 741-primOpTag (VecMulOp WordVec 16 W16) = 742-primOpTag (VecMulOp WordVec 8 W32) = 743-primOpTag (VecMulOp WordVec 4 W64) = 744-primOpTag (VecMulOp WordVec 64 W8) = 745-primOpTag (VecMulOp WordVec 32 W16) = 746-primOpTag (VecMulOp WordVec 16 W32) = 747-primOpTag (VecMulOp WordVec 8 W64) = 748-primOpTag (VecMulOp FloatVec 4 W32) = 749-primOpTag (VecMulOp FloatVec 2 W64) = 750-primOpTag (VecMulOp FloatVec 8 W32) = 751-primOpTag (VecMulOp FloatVec 4 W64) = 752-primOpTag (VecMulOp FloatVec 16 W32) = 753-primOpTag (VecMulOp FloatVec 8 W64) = 754-primOpTag (VecDivOp FloatVec 4 W32) = 755-primOpTag (VecDivOp FloatVec 2 W64) = 756-primOpTag (VecDivOp FloatVec 8 W32) = 757-primOpTag (VecDivOp FloatVec 4 W64) = 758-primOpTag (VecDivOp FloatVec 16 W32) = 759-primOpTag (VecDivOp FloatVec 8 W64) = 760-primOpTag (VecQuotOp IntVec 16 W8) = 761-primOpTag (VecQuotOp IntVec 8 W16) = 762-primOpTag (VecQuotOp IntVec 4 W32) = 763-primOpTag (VecQuotOp IntVec 2 W64) = 764-primOpTag (VecQuotOp IntVec 32 W8) = 765-primOpTag (VecQuotOp IntVec 16 W16) = 766-primOpTag (VecQuotOp IntVec 8 W32) = 767-primOpTag (VecQuotOp IntVec 4 W64) = 768-primOpTag (VecQuotOp IntVec 64 W8) = 769-primOpTag (VecQuotOp IntVec 32 W16) = 770-primOpTag (VecQuotOp IntVec 16 W32) = 771-primOpTag (VecQuotOp IntVec 8 W64) = 772-primOpTag (VecQuotOp WordVec 16 W8) = 773-primOpTag (VecQuotOp WordVec 8 W16) = 774-primOpTag (VecQuotOp WordVec 4 W32) = 775-primOpTag (VecQuotOp WordVec 2 W64) = 776-primOpTag (VecQuotOp WordVec 32 W8) = 777-primOpTag (VecQuotOp WordVec 16 W16) = 778-primOpTag (VecQuotOp WordVec 8 W32) = 779-primOpTag (VecQuotOp WordVec 4 W64) = 780-primOpTag (VecQuotOp WordVec 64 W8) = 781-primOpTag (VecQuotOp WordVec 32 W16) = 782-primOpTag (VecQuotOp WordVec 16 W32) = 783-primOpTag (VecQuotOp WordVec 8 W64) = 784-primOpTag (VecRemOp IntVec 16 W8) = 785-primOpTag (VecRemOp IntVec 8 W16) = 786-primOpTag (VecRemOp IntVec 4 W32) = 787-primOpTag (VecRemOp IntVec 2 W64) = 788-primOpTag (VecRemOp IntVec 32 W8) = 789-primOpTag (VecRemOp IntVec 16 W16) = 790-primOpTag (VecRemOp IntVec 8 W32) = 791-primOpTag (VecRemOp IntVec 4 W64) = 792-primOpTag (VecRemOp IntVec 64 W8) = 793-primOpTag (VecRemOp IntVec 32 W16) = 794-primOpTag (VecRemOp IntVec 16 W32) = 795-primOpTag (VecRemOp IntVec 8 W64) = 796-primOpTag (VecRemOp WordVec 16 W8) = 797-primOpTag (VecRemOp WordVec 8 W16) = 798-primOpTag (VecRemOp WordVec 4 W32) = 799-primOpTag (VecRemOp WordVec 2 W64) = 800-primOpTag (VecRemOp WordVec 32 W8) = 801-primOpTag (VecRemOp WordVec 16 W16) = 802-primOpTag (VecRemOp WordVec 8 W32) = 803-primOpTag (VecRemOp WordVec 4 W64) = 804-primOpTag (VecRemOp WordVec 64 W8) = 805-primOpTag (VecRemOp WordVec 32 W16) = 806-primOpTag (VecRemOp WordVec 16 W32) = 807-primOpTag (VecRemOp WordVec 8 W64) = 808-primOpTag (VecNegOp IntVec 16 W8) = 809-primOpTag (VecNegOp IntVec 8 W16) = 810-primOpTag (VecNegOp IntVec 4 W32) = 811-primOpTag (VecNegOp IntVec 2 W64) = 812-primOpTag (VecNegOp IntVec 32 W8) = 813-primOpTag (VecNegOp IntVec 16 W16) = 814-primOpTag (VecNegOp IntVec 8 W32) = 815-primOpTag (VecNegOp IntVec 4 W64) = 816-primOpTag (VecNegOp IntVec 64 W8) = 817-primOpTag (VecNegOp IntVec 32 W16) = 818-primOpTag (VecNegOp IntVec 16 W32) = 819-primOpTag (VecNegOp IntVec 8 W64) = 820-primOpTag (VecNegOp FloatVec 4 W32) = 821-primOpTag (VecNegOp FloatVec 2 W64) = 822-primOpTag (VecNegOp FloatVec 8 W32) = 823-primOpTag (VecNegOp FloatVec 4 W64) = 824-primOpTag (VecNegOp FloatVec 16 W32) = 825-primOpTag (VecNegOp FloatVec 8 W64) = 826-primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 827-primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 828-primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 829-primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 830-primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 831-primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 832-primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 833-primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 834-primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 835-primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 836-primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 837-primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 838-primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 839-primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 840-primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 841-primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 842-primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 843-primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 844-primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 845-primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 846-primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 847-primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 848-primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 849-primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 850-primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 851-primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 852-primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 853-primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 854-primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 855-primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 856-primOpTag (VecReadByteArrayOp IntVec 16 W8) = 857-primOpTag (VecReadByteArrayOp IntVec 8 W16) = 858-primOpTag (VecReadByteArrayOp IntVec 4 W32) = 859-primOpTag (VecReadByteArrayOp IntVec 2 W64) = 860-primOpTag (VecReadByteArrayOp IntVec 32 W8) = 861-primOpTag (VecReadByteArrayOp IntVec 16 W16) = 862-primOpTag (VecReadByteArrayOp IntVec 8 W32) = 863-primOpTag (VecReadByteArrayOp IntVec 4 W64) = 864-primOpTag (VecReadByteArrayOp IntVec 64 W8) = 865-primOpTag (VecReadByteArrayOp IntVec 32 W16) = 866-primOpTag (VecReadByteArrayOp IntVec 16 W32) = 867-primOpTag (VecReadByteArrayOp IntVec 8 W64) = 868-primOpTag (VecReadByteArrayOp WordVec 16 W8) = 869-primOpTag (VecReadByteArrayOp WordVec 8 W16) = 870-primOpTag (VecReadByteArrayOp WordVec 4 W32) = 871-primOpTag (VecReadByteArrayOp WordVec 2 W64) = 872-primOpTag (VecReadByteArrayOp WordVec 32 W8) = 873-primOpTag (VecReadByteArrayOp WordVec 16 W16) = 874-primOpTag (VecReadByteArrayOp WordVec 8 W32) = 875-primOpTag (VecReadByteArrayOp WordVec 4 W64) = 876-primOpTag (VecReadByteArrayOp WordVec 64 W8) = 877-primOpTag (VecReadByteArrayOp WordVec 32 W16) = 878-primOpTag (VecReadByteArrayOp WordVec 16 W32) = 879-primOpTag (VecReadByteArrayOp WordVec 8 W64) = 880-primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 881-primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 882-primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 883-primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 884-primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 885-primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 886-primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 887-primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 888-primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 889-primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 890-primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 891-primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 892-primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 893-primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 894-primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 895-primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 896-primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 897-primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 898-primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 899-primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 900-primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 901-primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 902-primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 903-primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 904-primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 905-primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 906-primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 907-primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 908-primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 909-primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 910-primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 911-primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 912-primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 913-primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 914-primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 915-primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 916-primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 917-primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 918-primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 919-primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 920-primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 921-primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 922-primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 923-primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 924-primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 925-primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 926-primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 927-primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 928-primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 929-primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 930-primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 931-primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 932-primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 933-primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 934-primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 935-primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 936-primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 937-primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 938-primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 939-primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 940-primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 941-primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 942-primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 943-primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 944-primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 945-primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 946-primOpTag (VecReadOffAddrOp IntVec 16 W8) = 947-primOpTag (VecReadOffAddrOp IntVec 8 W16) = 948-primOpTag (VecReadOffAddrOp IntVec 4 W32) = 949-primOpTag (VecReadOffAddrOp IntVec 2 W64) = 950-primOpTag (VecReadOffAddrOp IntVec 32 W8) = 951-primOpTag (VecReadOffAddrOp IntVec 16 W16) = 952-primOpTag (VecReadOffAddrOp IntVec 8 W32) = 953-primOpTag (VecReadOffAddrOp IntVec 4 W64) = 954-primOpTag (VecReadOffAddrOp IntVec 64 W8) = 955-primOpTag (VecReadOffAddrOp IntVec 32 W16) = 956-primOpTag (VecReadOffAddrOp IntVec 16 W32) = 957-primOpTag (VecReadOffAddrOp IntVec 8 W64) = 958-primOpTag (VecReadOffAddrOp WordVec 16 W8) = 959-primOpTag (VecReadOffAddrOp WordVec 8 W16) = 960-primOpTag (VecReadOffAddrOp WordVec 4 W32) = 961-primOpTag (VecReadOffAddrOp WordVec 2 W64) = 962-primOpTag (VecReadOffAddrOp WordVec 32 W8) = 963-primOpTag (VecReadOffAddrOp WordVec 16 W16) = 964-primOpTag (VecReadOffAddrOp WordVec 8 W32) = 965-primOpTag (VecReadOffAddrOp WordVec 4 W64) = 966-primOpTag (VecReadOffAddrOp WordVec 64 W8) = 967-primOpTag (VecReadOffAddrOp WordVec 32 W16) = 968-primOpTag (VecReadOffAddrOp WordVec 16 W32) = 969-primOpTag (VecReadOffAddrOp WordVec 8 W64) = 970-primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 971-primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 972-primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 973-primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 974-primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 975-primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 976-primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 977-primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 978-primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 979-primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 980-primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 981-primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 982-primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 983-primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 984-primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 985-primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 986-primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 987-primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 988-primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 989-primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 990-primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 991-primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 992-primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 993-primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 994-primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 995-primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 996-primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 997-primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 998-primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 999-primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1000-primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1001-primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1002-primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1003-primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1004-primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1005-primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1006-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1007-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1008-primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1009-primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1010-primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1011-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1012-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1013-primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1014-primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1015-primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1016-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1017-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1018-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1019-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1020-primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1021-primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1022-primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1023-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1024-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1025-primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1026-primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1027-primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1028-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1029-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1030-primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1031-primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1032-primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1033-primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1034-primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1035-primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1036-primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1037-primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1038-primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1039-primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1040-primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1041-primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1042-primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1043-primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1044-primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1045-primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1046-primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1047-primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1048-primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1049-primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1050-primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1051-primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1052-primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1053-primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1054-primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1055-primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1056-primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1057-primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1058-primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1059-primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1060-primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1061-primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1062-primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1063-primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1064-primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1065-primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1066-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1067-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1068-primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1069-primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1070-primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1071-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1072-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1073-primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1074-primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1075-primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1076-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1077-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1078-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1079-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1080-primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1081-primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1082-primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1083-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1084-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1085-primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1086-primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1087-primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1088-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1089-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1090-primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1091-primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1092-primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1093-primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1094-primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1095-primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1096-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1097-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1098-primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1099-primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1100-primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1101-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1102-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1103-primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1104-primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1105-primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1106-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1107-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1108-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1109-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1110-primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1111-primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1112-primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1113-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1114-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1115-primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1116-primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1117-primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1118-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1119-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1120-primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1121-primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1122-primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1123-primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1124-primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1125-primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1126-primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1127-primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1128-primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1129-primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1130-primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1131-primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1132-primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1133-primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1134-primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1135-primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1136-primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1137-primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1138-primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1139-primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1140-primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1141-primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1142-primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1143-primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1144-primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1145-primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1146-primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1147-primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1148-primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1149-primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1150-primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1151-primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1152-primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1153-primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1154-primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1155-primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1156-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1157-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1158-primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1159-primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1160-primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1161-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1162-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1163-primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1164-primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1165-primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1166-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1167-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1168-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1169-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1170-primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1171-primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1172-primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1173-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1174-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1175-primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1176-primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1177-primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1178-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1179-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1180-primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1181-primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1182-primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1183-primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1184-primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1185-primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1186-primOpTag PrefetchByteArrayOp3 = 1187-primOpTag PrefetchMutableByteArrayOp3 = 1188-primOpTag PrefetchAddrOp3 = 1189-primOpTag PrefetchValueOp3 = 1190-primOpTag PrefetchByteArrayOp2 = 1191-primOpTag PrefetchMutableByteArrayOp2 = 1192-primOpTag PrefetchAddrOp2 = 1193-primOpTag PrefetchValueOp2 = 1194-primOpTag PrefetchByteArrayOp1 = 1195-primOpTag PrefetchMutableByteArrayOp1 = 1196-primOpTag PrefetchAddrOp1 = 1197-primOpTag PrefetchValueOp1 = 1198-primOpTag PrefetchByteArrayOp0 = 1199-primOpTag PrefetchMutableByteArrayOp0 = 1200-primOpTag PrefetchAddrOp0 = 1201-primOpTag PrefetchValueOp0 = 1202+maxPrimOpTag = 1201+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 IntAddOp = 8+primOpTag IntSubOp = 9+primOpTag IntMulOp = 10+primOpTag IntMulMayOfloOp = 11+primOpTag IntQuotOp = 12+primOpTag IntRemOp = 13+primOpTag IntQuotRemOp = 14+primOpTag AndIOp = 15+primOpTag OrIOp = 16+primOpTag XorIOp = 17+primOpTag NotIOp = 18+primOpTag IntNegOp = 19+primOpTag IntAddCOp = 20+primOpTag IntSubCOp = 21+primOpTag IntGtOp = 22+primOpTag IntGeOp = 23+primOpTag IntEqOp = 24+primOpTag IntNeOp = 25+primOpTag IntLtOp = 26+primOpTag IntLeOp = 27+primOpTag ChrOp = 28+primOpTag Int2WordOp = 29+primOpTag Int2FloatOp = 30+primOpTag Int2DoubleOp = 31+primOpTag Word2FloatOp = 32+primOpTag Word2DoubleOp = 33+primOpTag ISllOp = 34+primOpTag ISraOp = 35+primOpTag ISrlOp = 36+primOpTag Int8Extend = 37+primOpTag Int8Narrow = 38+primOpTag Int8NegOp = 39+primOpTag Int8AddOp = 40+primOpTag Int8SubOp = 41+primOpTag Int8MulOp = 42+primOpTag Int8QuotOp = 43+primOpTag Int8RemOp = 44+primOpTag Int8QuotRemOp = 45+primOpTag Int8EqOp = 46+primOpTag Int8GeOp = 47+primOpTag Int8GtOp = 48+primOpTag Int8LeOp = 49+primOpTag Int8LtOp = 50+primOpTag Int8NeOp = 51+primOpTag Word8Extend = 52+primOpTag Word8Narrow = 53+primOpTag Word8NotOp = 54+primOpTag Word8AddOp = 55+primOpTag Word8SubOp = 56+primOpTag Word8MulOp = 57+primOpTag Word8QuotOp = 58+primOpTag Word8RemOp = 59+primOpTag Word8QuotRemOp = 60+primOpTag Word8EqOp = 61+primOpTag Word8GeOp = 62+primOpTag Word8GtOp = 63+primOpTag Word8LeOp = 64+primOpTag Word8LtOp = 65+primOpTag Word8NeOp = 66+primOpTag Int16Extend = 67+primOpTag Int16Narrow = 68+primOpTag Int16NegOp = 69+primOpTag Int16AddOp = 70+primOpTag Int16SubOp = 71+primOpTag Int16MulOp = 72+primOpTag Int16QuotOp = 73+primOpTag Int16RemOp = 74+primOpTag Int16QuotRemOp = 75+primOpTag Int16EqOp = 76+primOpTag Int16GeOp = 77+primOpTag Int16GtOp = 78+primOpTag Int16LeOp = 79+primOpTag Int16LtOp = 80+primOpTag Int16NeOp = 81+primOpTag Word16Extend = 82+primOpTag Word16Narrow = 83+primOpTag Word16NotOp = 84+primOpTag Word16AddOp = 85+primOpTag Word16SubOp = 86+primOpTag Word16MulOp = 87+primOpTag Word16QuotOp = 88+primOpTag Word16RemOp = 89+primOpTag Word16QuotRemOp = 90+primOpTag Word16EqOp = 91+primOpTag Word16GeOp = 92+primOpTag Word16GtOp = 93+primOpTag Word16LeOp = 94+primOpTag Word16LtOp = 95+primOpTag Word16NeOp = 96+primOpTag WordAddOp = 97+primOpTag WordAddCOp = 98+primOpTag WordSubCOp = 99+primOpTag WordAdd2Op = 100+primOpTag WordSubOp = 101+primOpTag WordMulOp = 102+primOpTag WordMul2Op = 103+primOpTag WordQuotOp = 104+primOpTag WordRemOp = 105+primOpTag WordQuotRemOp = 106+primOpTag WordQuotRem2Op = 107+primOpTag AndOp = 108+primOpTag OrOp = 109+primOpTag XorOp = 110+primOpTag NotOp = 111+primOpTag SllOp = 112+primOpTag SrlOp = 113+primOpTag Word2IntOp = 114+primOpTag WordGtOp = 115+primOpTag WordGeOp = 116+primOpTag WordEqOp = 117+primOpTag WordNeOp = 118+primOpTag WordLtOp = 119+primOpTag WordLeOp = 120+primOpTag PopCnt8Op = 121+primOpTag PopCnt16Op = 122+primOpTag PopCnt32Op = 123+primOpTag PopCnt64Op = 124+primOpTag PopCntOp = 125+primOpTag Pdep8Op = 126+primOpTag Pdep16Op = 127+primOpTag Pdep32Op = 128+primOpTag Pdep64Op = 129+primOpTag PdepOp = 130+primOpTag Pext8Op = 131+primOpTag Pext16Op = 132+primOpTag Pext32Op = 133+primOpTag Pext64Op = 134+primOpTag PextOp = 135+primOpTag Clz8Op = 136+primOpTag Clz16Op = 137+primOpTag Clz32Op = 138+primOpTag Clz64Op = 139+primOpTag ClzOp = 140+primOpTag Ctz8Op = 141+primOpTag Ctz16Op = 142+primOpTag Ctz32Op = 143+primOpTag Ctz64Op = 144+primOpTag CtzOp = 145+primOpTag BSwap16Op = 146+primOpTag BSwap32Op = 147+primOpTag BSwap64Op = 148+primOpTag BSwapOp = 149+primOpTag BRev8Op = 150+primOpTag BRev16Op = 151+primOpTag BRev32Op = 152+primOpTag BRev64Op = 153+primOpTag BRevOp = 154+primOpTag Narrow8IntOp = 155+primOpTag Narrow16IntOp = 156+primOpTag Narrow32IntOp = 157+primOpTag Narrow8WordOp = 158+primOpTag Narrow16WordOp = 159+primOpTag Narrow32WordOp = 160+primOpTag DoubleGtOp = 161+primOpTag DoubleGeOp = 162+primOpTag DoubleEqOp = 163+primOpTag DoubleNeOp = 164+primOpTag DoubleLtOp = 165+primOpTag DoubleLeOp = 166+primOpTag DoubleAddOp = 167+primOpTag DoubleSubOp = 168+primOpTag DoubleMulOp = 169+primOpTag DoubleDivOp = 170+primOpTag DoubleNegOp = 171+primOpTag DoubleFabsOp = 172+primOpTag Double2IntOp = 173+primOpTag Double2FloatOp = 174+primOpTag DoubleExpOp = 175+primOpTag DoubleExpM1Op = 176+primOpTag DoubleLogOp = 177+primOpTag DoubleLog1POp = 178+primOpTag DoubleSqrtOp = 179+primOpTag DoubleSinOp = 180+primOpTag DoubleCosOp = 181+primOpTag DoubleTanOp = 182+primOpTag DoubleAsinOp = 183+primOpTag DoubleAcosOp = 184+primOpTag DoubleAtanOp = 185+primOpTag DoubleSinhOp = 186+primOpTag DoubleCoshOp = 187+primOpTag DoubleTanhOp = 188+primOpTag DoubleAsinhOp = 189+primOpTag DoubleAcoshOp = 190+primOpTag DoubleAtanhOp = 191+primOpTag DoublePowerOp = 192+primOpTag DoubleDecode_2IntOp = 193+primOpTag DoubleDecode_Int64Op = 194+primOpTag FloatGtOp = 195+primOpTag FloatGeOp = 196+primOpTag FloatEqOp = 197+primOpTag FloatNeOp = 198+primOpTag FloatLtOp = 199+primOpTag FloatLeOp = 200+primOpTag FloatAddOp = 201+primOpTag FloatSubOp = 202+primOpTag FloatMulOp = 203+primOpTag FloatDivOp = 204+primOpTag FloatNegOp = 205+primOpTag FloatFabsOp = 206+primOpTag Float2IntOp = 207+primOpTag FloatExpOp = 208+primOpTag FloatExpM1Op = 209+primOpTag FloatLogOp = 210+primOpTag FloatLog1POp = 211+primOpTag FloatSqrtOp = 212+primOpTag FloatSinOp = 213+primOpTag FloatCosOp = 214+primOpTag FloatTanOp = 215+primOpTag FloatAsinOp = 216+primOpTag FloatAcosOp = 217+primOpTag FloatAtanOp = 218+primOpTag FloatSinhOp = 219+primOpTag FloatCoshOp = 220+primOpTag FloatTanhOp = 221+primOpTag FloatAsinhOp = 222+primOpTag FloatAcoshOp = 223+primOpTag FloatAtanhOp = 224+primOpTag FloatPowerOp = 225+primOpTag Float2DoubleOp = 226+primOpTag FloatDecode_IntOp = 227+primOpTag NewArrayOp = 228+primOpTag SameMutableArrayOp = 229+primOpTag ReadArrayOp = 230+primOpTag WriteArrayOp = 231+primOpTag SizeofArrayOp = 232+primOpTag SizeofMutableArrayOp = 233+primOpTag IndexArrayOp = 234+primOpTag UnsafeFreezeArrayOp = 235+primOpTag UnsafeThawArrayOp = 236+primOpTag CopyArrayOp = 237+primOpTag CopyMutableArrayOp = 238+primOpTag CloneArrayOp = 239+primOpTag CloneMutableArrayOp = 240+primOpTag FreezeArrayOp = 241+primOpTag ThawArrayOp = 242+primOpTag CasArrayOp = 243+primOpTag NewSmallArrayOp = 244+primOpTag SameSmallMutableArrayOp = 245+primOpTag ReadSmallArrayOp = 246+primOpTag WriteSmallArrayOp = 247+primOpTag SizeofSmallArrayOp = 248+primOpTag SizeofSmallMutableArrayOp = 249+primOpTag IndexSmallArrayOp = 250+primOpTag UnsafeFreezeSmallArrayOp = 251+primOpTag UnsafeThawSmallArrayOp = 252+primOpTag CopySmallArrayOp = 253+primOpTag CopySmallMutableArrayOp = 254+primOpTag CloneSmallArrayOp = 255+primOpTag CloneSmallMutableArrayOp = 256+primOpTag FreezeSmallArrayOp = 257+primOpTag ThawSmallArrayOp = 258+primOpTag CasSmallArrayOp = 259+primOpTag NewByteArrayOp_Char = 260+primOpTag NewPinnedByteArrayOp_Char = 261+primOpTag NewAlignedPinnedByteArrayOp_Char = 262+primOpTag MutableByteArrayIsPinnedOp = 263+primOpTag ByteArrayIsPinnedOp = 264+primOpTag ByteArrayContents_Char = 265+primOpTag SameMutableByteArrayOp = 266+primOpTag ShrinkMutableByteArrayOp_Char = 267+primOpTag ResizeMutableByteArrayOp_Char = 268+primOpTag UnsafeFreezeByteArrayOp = 269+primOpTag SizeofByteArrayOp = 270+primOpTag SizeofMutableByteArrayOp = 271+primOpTag GetSizeofMutableByteArrayOp = 272+primOpTag IndexByteArrayOp_Char = 273+primOpTag IndexByteArrayOp_WideChar = 274+primOpTag IndexByteArrayOp_Int = 275+primOpTag IndexByteArrayOp_Word = 276+primOpTag IndexByteArrayOp_Addr = 277+primOpTag IndexByteArrayOp_Float = 278+primOpTag IndexByteArrayOp_Double = 279+primOpTag IndexByteArrayOp_StablePtr = 280+primOpTag IndexByteArrayOp_Int8 = 281+primOpTag IndexByteArrayOp_Int16 = 282+primOpTag IndexByteArrayOp_Int32 = 283+primOpTag IndexByteArrayOp_Int64 = 284+primOpTag IndexByteArrayOp_Word8 = 285+primOpTag IndexByteArrayOp_Word16 = 286+primOpTag IndexByteArrayOp_Word32 = 287+primOpTag IndexByteArrayOp_Word64 = 288+primOpTag IndexByteArrayOp_Word8AsChar = 289+primOpTag IndexByteArrayOp_Word8AsWideChar = 290+primOpTag IndexByteArrayOp_Word8AsAddr = 291+primOpTag IndexByteArrayOp_Word8AsFloat = 292+primOpTag IndexByteArrayOp_Word8AsDouble = 293+primOpTag IndexByteArrayOp_Word8AsStablePtr = 294+primOpTag IndexByteArrayOp_Word8AsInt16 = 295+primOpTag IndexByteArrayOp_Word8AsInt32 = 296+primOpTag IndexByteArrayOp_Word8AsInt64 = 297+primOpTag IndexByteArrayOp_Word8AsInt = 298+primOpTag IndexByteArrayOp_Word8AsWord16 = 299+primOpTag IndexByteArrayOp_Word8AsWord32 = 300+primOpTag IndexByteArrayOp_Word8AsWord64 = 301+primOpTag IndexByteArrayOp_Word8AsWord = 302+primOpTag ReadByteArrayOp_Char = 303+primOpTag ReadByteArrayOp_WideChar = 304+primOpTag ReadByteArrayOp_Int = 305+primOpTag ReadByteArrayOp_Word = 306+primOpTag ReadByteArrayOp_Addr = 307+primOpTag ReadByteArrayOp_Float = 308+primOpTag ReadByteArrayOp_Double = 309+primOpTag ReadByteArrayOp_StablePtr = 310+primOpTag ReadByteArrayOp_Int8 = 311+primOpTag ReadByteArrayOp_Int16 = 312+primOpTag ReadByteArrayOp_Int32 = 313+primOpTag ReadByteArrayOp_Int64 = 314+primOpTag ReadByteArrayOp_Word8 = 315+primOpTag ReadByteArrayOp_Word16 = 316+primOpTag ReadByteArrayOp_Word32 = 317+primOpTag ReadByteArrayOp_Word64 = 318+primOpTag ReadByteArrayOp_Word8AsChar = 319+primOpTag ReadByteArrayOp_Word8AsWideChar = 320+primOpTag ReadByteArrayOp_Word8AsAddr = 321+primOpTag ReadByteArrayOp_Word8AsFloat = 322+primOpTag ReadByteArrayOp_Word8AsDouble = 323+primOpTag ReadByteArrayOp_Word8AsStablePtr = 324+primOpTag ReadByteArrayOp_Word8AsInt16 = 325+primOpTag ReadByteArrayOp_Word8AsInt32 = 326+primOpTag ReadByteArrayOp_Word8AsInt64 = 327+primOpTag ReadByteArrayOp_Word8AsInt = 328+primOpTag ReadByteArrayOp_Word8AsWord16 = 329+primOpTag ReadByteArrayOp_Word8AsWord32 = 330+primOpTag ReadByteArrayOp_Word8AsWord64 = 331+primOpTag ReadByteArrayOp_Word8AsWord = 332+primOpTag WriteByteArrayOp_Char = 333+primOpTag WriteByteArrayOp_WideChar = 334+primOpTag WriteByteArrayOp_Int = 335+primOpTag WriteByteArrayOp_Word = 336+primOpTag WriteByteArrayOp_Addr = 337+primOpTag WriteByteArrayOp_Float = 338+primOpTag WriteByteArrayOp_Double = 339+primOpTag WriteByteArrayOp_StablePtr = 340+primOpTag WriteByteArrayOp_Int8 = 341+primOpTag WriteByteArrayOp_Int16 = 342+primOpTag WriteByteArrayOp_Int32 = 343+primOpTag WriteByteArrayOp_Int64 = 344+primOpTag WriteByteArrayOp_Word8 = 345+primOpTag WriteByteArrayOp_Word16 = 346+primOpTag WriteByteArrayOp_Word32 = 347+primOpTag WriteByteArrayOp_Word64 = 348+primOpTag WriteByteArrayOp_Word8AsChar = 349+primOpTag WriteByteArrayOp_Word8AsWideChar = 350+primOpTag WriteByteArrayOp_Word8AsAddr = 351+primOpTag WriteByteArrayOp_Word8AsFloat = 352+primOpTag WriteByteArrayOp_Word8AsDouble = 353+primOpTag WriteByteArrayOp_Word8AsStablePtr = 354+primOpTag WriteByteArrayOp_Word8AsInt16 = 355+primOpTag WriteByteArrayOp_Word8AsInt32 = 356+primOpTag WriteByteArrayOp_Word8AsInt64 = 357+primOpTag WriteByteArrayOp_Word8AsInt = 358+primOpTag WriteByteArrayOp_Word8AsWord16 = 359+primOpTag WriteByteArrayOp_Word8AsWord32 = 360+primOpTag WriteByteArrayOp_Word8AsWord64 = 361+primOpTag WriteByteArrayOp_Word8AsWord = 362+primOpTag CompareByteArraysOp = 363+primOpTag CopyByteArrayOp = 364+primOpTag CopyMutableByteArrayOp = 365+primOpTag CopyByteArrayToAddrOp = 366+primOpTag CopyMutableByteArrayToAddrOp = 367+primOpTag CopyAddrToByteArrayOp = 368+primOpTag SetByteArrayOp = 369+primOpTag AtomicReadByteArrayOp_Int = 370+primOpTag AtomicWriteByteArrayOp_Int = 371+primOpTag CasByteArrayOp_Int = 372+primOpTag FetchAddByteArrayOp_Int = 373+primOpTag FetchSubByteArrayOp_Int = 374+primOpTag FetchAndByteArrayOp_Int = 375+primOpTag FetchNandByteArrayOp_Int = 376+primOpTag FetchOrByteArrayOp_Int = 377+primOpTag FetchXorByteArrayOp_Int = 378+primOpTag NewArrayArrayOp = 379+primOpTag SameMutableArrayArrayOp = 380+primOpTag UnsafeFreezeArrayArrayOp = 381+primOpTag SizeofArrayArrayOp = 382+primOpTag SizeofMutableArrayArrayOp = 383+primOpTag IndexArrayArrayOp_ByteArray = 384+primOpTag IndexArrayArrayOp_ArrayArray = 385+primOpTag ReadArrayArrayOp_ByteArray = 386+primOpTag ReadArrayArrayOp_MutableByteArray = 387+primOpTag ReadArrayArrayOp_ArrayArray = 388+primOpTag ReadArrayArrayOp_MutableArrayArray = 389+primOpTag WriteArrayArrayOp_ByteArray = 390+primOpTag WriteArrayArrayOp_MutableByteArray = 391+primOpTag WriteArrayArrayOp_ArrayArray = 392+primOpTag WriteArrayArrayOp_MutableArrayArray = 393+primOpTag CopyArrayArrayOp = 394+primOpTag CopyMutableArrayArrayOp = 395+primOpTag AddrAddOp = 396+primOpTag AddrSubOp = 397+primOpTag AddrRemOp = 398+primOpTag Addr2IntOp = 399+primOpTag Int2AddrOp = 400+primOpTag AddrGtOp = 401+primOpTag AddrGeOp = 402+primOpTag AddrEqOp = 403+primOpTag AddrNeOp = 404+primOpTag AddrLtOp = 405+primOpTag AddrLeOp = 406+primOpTag IndexOffAddrOp_Char = 407+primOpTag IndexOffAddrOp_WideChar = 408+primOpTag IndexOffAddrOp_Int = 409+primOpTag IndexOffAddrOp_Word = 410+primOpTag IndexOffAddrOp_Addr = 411+primOpTag IndexOffAddrOp_Float = 412+primOpTag IndexOffAddrOp_Double = 413+primOpTag IndexOffAddrOp_StablePtr = 414+primOpTag IndexOffAddrOp_Int8 = 415+primOpTag IndexOffAddrOp_Int16 = 416+primOpTag IndexOffAddrOp_Int32 = 417+primOpTag IndexOffAddrOp_Int64 = 418+primOpTag IndexOffAddrOp_Word8 = 419+primOpTag IndexOffAddrOp_Word16 = 420+primOpTag IndexOffAddrOp_Word32 = 421+primOpTag IndexOffAddrOp_Word64 = 422+primOpTag ReadOffAddrOp_Char = 423+primOpTag ReadOffAddrOp_WideChar = 424+primOpTag ReadOffAddrOp_Int = 425+primOpTag ReadOffAddrOp_Word = 426+primOpTag ReadOffAddrOp_Addr = 427+primOpTag ReadOffAddrOp_Float = 428+primOpTag ReadOffAddrOp_Double = 429+primOpTag ReadOffAddrOp_StablePtr = 430+primOpTag ReadOffAddrOp_Int8 = 431+primOpTag ReadOffAddrOp_Int16 = 432+primOpTag ReadOffAddrOp_Int32 = 433+primOpTag ReadOffAddrOp_Int64 = 434+primOpTag ReadOffAddrOp_Word8 = 435+primOpTag ReadOffAddrOp_Word16 = 436+primOpTag ReadOffAddrOp_Word32 = 437+primOpTag ReadOffAddrOp_Word64 = 438+primOpTag WriteOffAddrOp_Char = 439+primOpTag WriteOffAddrOp_WideChar = 440+primOpTag WriteOffAddrOp_Int = 441+primOpTag WriteOffAddrOp_Word = 442+primOpTag WriteOffAddrOp_Addr = 443+primOpTag WriteOffAddrOp_Float = 444+primOpTag WriteOffAddrOp_Double = 445+primOpTag WriteOffAddrOp_StablePtr = 446+primOpTag WriteOffAddrOp_Int8 = 447+primOpTag WriteOffAddrOp_Int16 = 448+primOpTag WriteOffAddrOp_Int32 = 449+primOpTag WriteOffAddrOp_Int64 = 450+primOpTag WriteOffAddrOp_Word8 = 451+primOpTag WriteOffAddrOp_Word16 = 452+primOpTag WriteOffAddrOp_Word32 = 453+primOpTag WriteOffAddrOp_Word64 = 454+primOpTag NewMutVarOp = 455+primOpTag ReadMutVarOp = 456+primOpTag WriteMutVarOp = 457+primOpTag SameMutVarOp = 458+primOpTag AtomicModifyMutVar2Op = 459+primOpTag AtomicModifyMutVar_Op = 460+primOpTag CasMutVarOp = 461+primOpTag CatchOp = 462+primOpTag RaiseOp = 463+primOpTag RaiseIOOp = 464+primOpTag MaskAsyncExceptionsOp = 465+primOpTag MaskUninterruptibleOp = 466+primOpTag UnmaskAsyncExceptionsOp = 467+primOpTag MaskStatus = 468+primOpTag AtomicallyOp = 469+primOpTag RetryOp = 470+primOpTag CatchRetryOp = 471+primOpTag CatchSTMOp = 472+primOpTag NewTVarOp = 473+primOpTag ReadTVarOp = 474+primOpTag ReadTVarIOOp = 475+primOpTag WriteTVarOp = 476+primOpTag SameTVarOp = 477+primOpTag NewMVarOp = 478+primOpTag TakeMVarOp = 479+primOpTag TryTakeMVarOp = 480+primOpTag PutMVarOp = 481+primOpTag TryPutMVarOp = 482+primOpTag ReadMVarOp = 483+primOpTag TryReadMVarOp = 484+primOpTag SameMVarOp = 485+primOpTag IsEmptyMVarOp = 486+primOpTag DelayOp = 487+primOpTag WaitReadOp = 488+primOpTag WaitWriteOp = 489+primOpTag ForkOp = 490+primOpTag ForkOnOp = 491+primOpTag KillThreadOp = 492+primOpTag YieldOp = 493+primOpTag MyThreadIdOp = 494+primOpTag LabelThreadOp = 495+primOpTag IsCurrentThreadBoundOp = 496+primOpTag NoDuplicateOp = 497+primOpTag ThreadStatusOp = 498+primOpTag MkWeakOp = 499+primOpTag MkWeakNoFinalizerOp = 500+primOpTag AddCFinalizerToWeakOp = 501+primOpTag DeRefWeakOp = 502+primOpTag FinalizeWeakOp = 503+primOpTag TouchOp = 504+primOpTag MakeStablePtrOp = 505+primOpTag DeRefStablePtrOp = 506+primOpTag EqStablePtrOp = 507+primOpTag MakeStableNameOp = 508+primOpTag EqStableNameOp = 509+primOpTag StableNameToIntOp = 510+primOpTag CompactNewOp = 511+primOpTag CompactResizeOp = 512+primOpTag CompactContainsOp = 513+primOpTag CompactContainsAnyOp = 514+primOpTag CompactGetFirstBlockOp = 515+primOpTag CompactGetNextBlockOp = 516+primOpTag CompactAllocateBlockOp = 517+primOpTag CompactFixupPointersOp = 518+primOpTag CompactAdd = 519+primOpTag CompactAddWithSharing = 520+primOpTag CompactSize = 521+primOpTag ReallyUnsafePtrEqualityOp = 522+primOpTag ParOp = 523+primOpTag SparkOp = 524+primOpTag SeqOp = 525+primOpTag GetSparkOp = 526+primOpTag NumSparks = 527+primOpTag DataToTagOp = 528+primOpTag TagToEnumOp = 529+primOpTag AddrToAnyOp = 530+primOpTag AnyToAddrOp = 531+primOpTag MkApUpd0_Op = 532+primOpTag NewBCOOp = 533+primOpTag UnpackClosureOp = 534+primOpTag ClosureSizeOp = 535+primOpTag GetApStackValOp = 536+primOpTag GetCCSOfOp = 537+primOpTag GetCurrentCCSOp = 538+primOpTag ClearCCSOp = 539+primOpTag TraceEventOp = 540+primOpTag TraceEventBinaryOp = 541+primOpTag TraceMarkerOp = 542+primOpTag SetThreadAllocationCounter = 543+primOpTag (VecBroadcastOp IntVec 16 W8) = 544+primOpTag (VecBroadcastOp IntVec 8 W16) = 545+primOpTag (VecBroadcastOp IntVec 4 W32) = 546+primOpTag (VecBroadcastOp IntVec 2 W64) = 547+primOpTag (VecBroadcastOp IntVec 32 W8) = 548+primOpTag (VecBroadcastOp IntVec 16 W16) = 549+primOpTag (VecBroadcastOp IntVec 8 W32) = 550+primOpTag (VecBroadcastOp IntVec 4 W64) = 551+primOpTag (VecBroadcastOp IntVec 64 W8) = 552+primOpTag (VecBroadcastOp IntVec 32 W16) = 553+primOpTag (VecBroadcastOp IntVec 16 W32) = 554+primOpTag (VecBroadcastOp IntVec 8 W64) = 555+primOpTag (VecBroadcastOp WordVec 16 W8) = 556+primOpTag (VecBroadcastOp WordVec 8 W16) = 557+primOpTag (VecBroadcastOp WordVec 4 W32) = 558+primOpTag (VecBroadcastOp WordVec 2 W64) = 559+primOpTag (VecBroadcastOp WordVec 32 W8) = 560+primOpTag (VecBroadcastOp WordVec 16 W16) = 561+primOpTag (VecBroadcastOp WordVec 8 W32) = 562+primOpTag (VecBroadcastOp WordVec 4 W64) = 563+primOpTag (VecBroadcastOp WordVec 64 W8) = 564+primOpTag (VecBroadcastOp WordVec 32 W16) = 565+primOpTag (VecBroadcastOp WordVec 16 W32) = 566+primOpTag (VecBroadcastOp WordVec 8 W64) = 567+primOpTag (VecBroadcastOp FloatVec 4 W32) = 568+primOpTag (VecBroadcastOp FloatVec 2 W64) = 569+primOpTag (VecBroadcastOp FloatVec 8 W32) = 570+primOpTag (VecBroadcastOp FloatVec 4 W64) = 571+primOpTag (VecBroadcastOp FloatVec 16 W32) = 572+primOpTag (VecBroadcastOp FloatVec 8 W64) = 573+primOpTag (VecPackOp IntVec 16 W8) = 574+primOpTag (VecPackOp IntVec 8 W16) = 575+primOpTag (VecPackOp IntVec 4 W32) = 576+primOpTag (VecPackOp IntVec 2 W64) = 577+primOpTag (VecPackOp IntVec 32 W8) = 578+primOpTag (VecPackOp IntVec 16 W16) = 579+primOpTag (VecPackOp IntVec 8 W32) = 580+primOpTag (VecPackOp IntVec 4 W64) = 581+primOpTag (VecPackOp IntVec 64 W8) = 582+primOpTag (VecPackOp IntVec 32 W16) = 583+primOpTag (VecPackOp IntVec 16 W32) = 584+primOpTag (VecPackOp IntVec 8 W64) = 585+primOpTag (VecPackOp WordVec 16 W8) = 586+primOpTag (VecPackOp WordVec 8 W16) = 587+primOpTag (VecPackOp WordVec 4 W32) = 588+primOpTag (VecPackOp WordVec 2 W64) = 589+primOpTag (VecPackOp WordVec 32 W8) = 590+primOpTag (VecPackOp WordVec 16 W16) = 591+primOpTag (VecPackOp WordVec 8 W32) = 592+primOpTag (VecPackOp WordVec 4 W64) = 593+primOpTag (VecPackOp WordVec 64 W8) = 594+primOpTag (VecPackOp WordVec 32 W16) = 595+primOpTag (VecPackOp WordVec 16 W32) = 596+primOpTag (VecPackOp WordVec 8 W64) = 597+primOpTag (VecPackOp FloatVec 4 W32) = 598+primOpTag (VecPackOp FloatVec 2 W64) = 599+primOpTag (VecPackOp FloatVec 8 W32) = 600+primOpTag (VecPackOp FloatVec 4 W64) = 601+primOpTag (VecPackOp FloatVec 16 W32) = 602+primOpTag (VecPackOp FloatVec 8 W64) = 603+primOpTag (VecUnpackOp IntVec 16 W8) = 604+primOpTag (VecUnpackOp IntVec 8 W16) = 605+primOpTag (VecUnpackOp IntVec 4 W32) = 606+primOpTag (VecUnpackOp IntVec 2 W64) = 607+primOpTag (VecUnpackOp IntVec 32 W8) = 608+primOpTag (VecUnpackOp IntVec 16 W16) = 609+primOpTag (VecUnpackOp IntVec 8 W32) = 610+primOpTag (VecUnpackOp IntVec 4 W64) = 611+primOpTag (VecUnpackOp IntVec 64 W8) = 612+primOpTag (VecUnpackOp IntVec 32 W16) = 613+primOpTag (VecUnpackOp IntVec 16 W32) = 614+primOpTag (VecUnpackOp IntVec 8 W64) = 615+primOpTag (VecUnpackOp WordVec 16 W8) = 616+primOpTag (VecUnpackOp WordVec 8 W16) = 617+primOpTag (VecUnpackOp WordVec 4 W32) = 618+primOpTag (VecUnpackOp WordVec 2 W64) = 619+primOpTag (VecUnpackOp WordVec 32 W8) = 620+primOpTag (VecUnpackOp WordVec 16 W16) = 621+primOpTag (VecUnpackOp WordVec 8 W32) = 622+primOpTag (VecUnpackOp WordVec 4 W64) = 623+primOpTag (VecUnpackOp WordVec 64 W8) = 624+primOpTag (VecUnpackOp WordVec 32 W16) = 625+primOpTag (VecUnpackOp WordVec 16 W32) = 626+primOpTag (VecUnpackOp WordVec 8 W64) = 627+primOpTag (VecUnpackOp FloatVec 4 W32) = 628+primOpTag (VecUnpackOp FloatVec 2 W64) = 629+primOpTag (VecUnpackOp FloatVec 8 W32) = 630+primOpTag (VecUnpackOp FloatVec 4 W64) = 631+primOpTag (VecUnpackOp FloatVec 16 W32) = 632+primOpTag (VecUnpackOp FloatVec 8 W64) = 633+primOpTag (VecInsertOp IntVec 16 W8) = 634+primOpTag (VecInsertOp IntVec 8 W16) = 635+primOpTag (VecInsertOp IntVec 4 W32) = 636+primOpTag (VecInsertOp IntVec 2 W64) = 637+primOpTag (VecInsertOp IntVec 32 W8) = 638+primOpTag (VecInsertOp IntVec 16 W16) = 639+primOpTag (VecInsertOp IntVec 8 W32) = 640+primOpTag (VecInsertOp IntVec 4 W64) = 641+primOpTag (VecInsertOp IntVec 64 W8) = 642+primOpTag (VecInsertOp IntVec 32 W16) = 643+primOpTag (VecInsertOp IntVec 16 W32) = 644+primOpTag (VecInsertOp IntVec 8 W64) = 645+primOpTag (VecInsertOp WordVec 16 W8) = 646+primOpTag (VecInsertOp WordVec 8 W16) = 647+primOpTag (VecInsertOp WordVec 4 W32) = 648+primOpTag (VecInsertOp WordVec 2 W64) = 649+primOpTag (VecInsertOp WordVec 32 W8) = 650+primOpTag (VecInsertOp WordVec 16 W16) = 651+primOpTag (VecInsertOp WordVec 8 W32) = 652+primOpTag (VecInsertOp WordVec 4 W64) = 653+primOpTag (VecInsertOp WordVec 64 W8) = 654+primOpTag (VecInsertOp WordVec 32 W16) = 655+primOpTag (VecInsertOp WordVec 16 W32) = 656+primOpTag (VecInsertOp WordVec 8 W64) = 657+primOpTag (VecInsertOp FloatVec 4 W32) = 658+primOpTag (VecInsertOp FloatVec 2 W64) = 659+primOpTag (VecInsertOp FloatVec 8 W32) = 660+primOpTag (VecInsertOp FloatVec 4 W64) = 661+primOpTag (VecInsertOp FloatVec 16 W32) = 662+primOpTag (VecInsertOp FloatVec 8 W64) = 663+primOpTag (VecAddOp IntVec 16 W8) = 664+primOpTag (VecAddOp IntVec 8 W16) = 665+primOpTag (VecAddOp IntVec 4 W32) = 666+primOpTag (VecAddOp IntVec 2 W64) = 667+primOpTag (VecAddOp IntVec 32 W8) = 668+primOpTag (VecAddOp IntVec 16 W16) = 669+primOpTag (VecAddOp IntVec 8 W32) = 670+primOpTag (VecAddOp IntVec 4 W64) = 671+primOpTag (VecAddOp IntVec 64 W8) = 672+primOpTag (VecAddOp IntVec 32 W16) = 673+primOpTag (VecAddOp IntVec 16 W32) = 674+primOpTag (VecAddOp IntVec 8 W64) = 675+primOpTag (VecAddOp WordVec 16 W8) = 676+primOpTag (VecAddOp WordVec 8 W16) = 677+primOpTag (VecAddOp WordVec 4 W32) = 678+primOpTag (VecAddOp WordVec 2 W64) = 679+primOpTag (VecAddOp WordVec 32 W8) = 680+primOpTag (VecAddOp WordVec 16 W16) = 681+primOpTag (VecAddOp WordVec 8 W32) = 682+primOpTag (VecAddOp WordVec 4 W64) = 683+primOpTag (VecAddOp WordVec 64 W8) = 684+primOpTag (VecAddOp WordVec 32 W16) = 685+primOpTag (VecAddOp WordVec 16 W32) = 686+primOpTag (VecAddOp WordVec 8 W64) = 687+primOpTag (VecAddOp FloatVec 4 W32) = 688+primOpTag (VecAddOp FloatVec 2 W64) = 689+primOpTag (VecAddOp FloatVec 8 W32) = 690+primOpTag (VecAddOp FloatVec 4 W64) = 691+primOpTag (VecAddOp FloatVec 16 W32) = 692+primOpTag (VecAddOp FloatVec 8 W64) = 693+primOpTag (VecSubOp IntVec 16 W8) = 694+primOpTag (VecSubOp IntVec 8 W16) = 695+primOpTag (VecSubOp IntVec 4 W32) = 696+primOpTag (VecSubOp IntVec 2 W64) = 697+primOpTag (VecSubOp IntVec 32 W8) = 698+primOpTag (VecSubOp IntVec 16 W16) = 699+primOpTag (VecSubOp IntVec 8 W32) = 700+primOpTag (VecSubOp IntVec 4 W64) = 701+primOpTag (VecSubOp IntVec 64 W8) = 702+primOpTag (VecSubOp IntVec 32 W16) = 703+primOpTag (VecSubOp IntVec 16 W32) = 704+primOpTag (VecSubOp IntVec 8 W64) = 705+primOpTag (VecSubOp WordVec 16 W8) = 706+primOpTag (VecSubOp WordVec 8 W16) = 707+primOpTag (VecSubOp WordVec 4 W32) = 708+primOpTag (VecSubOp WordVec 2 W64) = 709+primOpTag (VecSubOp WordVec 32 W8) = 710+primOpTag (VecSubOp WordVec 16 W16) = 711+primOpTag (VecSubOp WordVec 8 W32) = 712+primOpTag (VecSubOp WordVec 4 W64) = 713+primOpTag (VecSubOp WordVec 64 W8) = 714+primOpTag (VecSubOp WordVec 32 W16) = 715+primOpTag (VecSubOp WordVec 16 W32) = 716+primOpTag (VecSubOp WordVec 8 W64) = 717+primOpTag (VecSubOp FloatVec 4 W32) = 718+primOpTag (VecSubOp FloatVec 2 W64) = 719+primOpTag (VecSubOp FloatVec 8 W32) = 720+primOpTag (VecSubOp FloatVec 4 W64) = 721+primOpTag (VecSubOp FloatVec 16 W32) = 722+primOpTag (VecSubOp FloatVec 8 W64) = 723+primOpTag (VecMulOp IntVec 16 W8) = 724+primOpTag (VecMulOp IntVec 8 W16) = 725+primOpTag (VecMulOp IntVec 4 W32) = 726+primOpTag (VecMulOp IntVec 2 W64) = 727+primOpTag (VecMulOp IntVec 32 W8) = 728+primOpTag (VecMulOp IntVec 16 W16) = 729+primOpTag (VecMulOp IntVec 8 W32) = 730+primOpTag (VecMulOp IntVec 4 W64) = 731+primOpTag (VecMulOp IntVec 64 W8) = 732+primOpTag (VecMulOp IntVec 32 W16) = 733+primOpTag (VecMulOp IntVec 16 W32) = 734+primOpTag (VecMulOp IntVec 8 W64) = 735+primOpTag (VecMulOp WordVec 16 W8) = 736+primOpTag (VecMulOp WordVec 8 W16) = 737+primOpTag (VecMulOp WordVec 4 W32) = 738+primOpTag (VecMulOp WordVec 2 W64) = 739+primOpTag (VecMulOp WordVec 32 W8) = 740+primOpTag (VecMulOp WordVec 16 W16) = 741+primOpTag (VecMulOp WordVec 8 W32) = 742+primOpTag (VecMulOp WordVec 4 W64) = 743+primOpTag (VecMulOp WordVec 64 W8) = 744+primOpTag (VecMulOp WordVec 32 W16) = 745+primOpTag (VecMulOp WordVec 16 W32) = 746+primOpTag (VecMulOp WordVec 8 W64) = 747+primOpTag (VecMulOp FloatVec 4 W32) = 748+primOpTag (VecMulOp FloatVec 2 W64) = 749+primOpTag (VecMulOp FloatVec 8 W32) = 750+primOpTag (VecMulOp FloatVec 4 W64) = 751+primOpTag (VecMulOp FloatVec 16 W32) = 752+primOpTag (VecMulOp FloatVec 8 W64) = 753+primOpTag (VecDivOp FloatVec 4 W32) = 754+primOpTag (VecDivOp FloatVec 2 W64) = 755+primOpTag (VecDivOp FloatVec 8 W32) = 756+primOpTag (VecDivOp FloatVec 4 W64) = 757+primOpTag (VecDivOp FloatVec 16 W32) = 758+primOpTag (VecDivOp FloatVec 8 W64) = 759+primOpTag (VecQuotOp IntVec 16 W8) = 760+primOpTag (VecQuotOp IntVec 8 W16) = 761+primOpTag (VecQuotOp IntVec 4 W32) = 762+primOpTag (VecQuotOp IntVec 2 W64) = 763+primOpTag (VecQuotOp IntVec 32 W8) = 764+primOpTag (VecQuotOp IntVec 16 W16) = 765+primOpTag (VecQuotOp IntVec 8 W32) = 766+primOpTag (VecQuotOp IntVec 4 W64) = 767+primOpTag (VecQuotOp IntVec 64 W8) = 768+primOpTag (VecQuotOp IntVec 32 W16) = 769+primOpTag (VecQuotOp IntVec 16 W32) = 770+primOpTag (VecQuotOp IntVec 8 W64) = 771+primOpTag (VecQuotOp WordVec 16 W8) = 772+primOpTag (VecQuotOp WordVec 8 W16) = 773+primOpTag (VecQuotOp WordVec 4 W32) = 774+primOpTag (VecQuotOp WordVec 2 W64) = 775+primOpTag (VecQuotOp WordVec 32 W8) = 776+primOpTag (VecQuotOp WordVec 16 W16) = 777+primOpTag (VecQuotOp WordVec 8 W32) = 778+primOpTag (VecQuotOp WordVec 4 W64) = 779+primOpTag (VecQuotOp WordVec 64 W8) = 780+primOpTag (VecQuotOp WordVec 32 W16) = 781+primOpTag (VecQuotOp WordVec 16 W32) = 782+primOpTag (VecQuotOp WordVec 8 W64) = 783+primOpTag (VecRemOp IntVec 16 W8) = 784+primOpTag (VecRemOp IntVec 8 W16) = 785+primOpTag (VecRemOp IntVec 4 W32) = 786+primOpTag (VecRemOp IntVec 2 W64) = 787+primOpTag (VecRemOp IntVec 32 W8) = 788+primOpTag (VecRemOp IntVec 16 W16) = 789+primOpTag (VecRemOp IntVec 8 W32) = 790+primOpTag (VecRemOp IntVec 4 W64) = 791+primOpTag (VecRemOp IntVec 64 W8) = 792+primOpTag (VecRemOp IntVec 32 W16) = 793+primOpTag (VecRemOp IntVec 16 W32) = 794+primOpTag (VecRemOp IntVec 8 W64) = 795+primOpTag (VecRemOp WordVec 16 W8) = 796+primOpTag (VecRemOp WordVec 8 W16) = 797+primOpTag (VecRemOp WordVec 4 W32) = 798+primOpTag (VecRemOp WordVec 2 W64) = 799+primOpTag (VecRemOp WordVec 32 W8) = 800+primOpTag (VecRemOp WordVec 16 W16) = 801+primOpTag (VecRemOp WordVec 8 W32) = 802+primOpTag (VecRemOp WordVec 4 W64) = 803+primOpTag (VecRemOp WordVec 64 W8) = 804+primOpTag (VecRemOp WordVec 32 W16) = 805+primOpTag (VecRemOp WordVec 16 W32) = 806+primOpTag (VecRemOp WordVec 8 W64) = 807+primOpTag (VecNegOp IntVec 16 W8) = 808+primOpTag (VecNegOp IntVec 8 W16) = 809+primOpTag (VecNegOp IntVec 4 W32) = 810+primOpTag (VecNegOp IntVec 2 W64) = 811+primOpTag (VecNegOp IntVec 32 W8) = 812+primOpTag (VecNegOp IntVec 16 W16) = 813+primOpTag (VecNegOp IntVec 8 W32) = 814+primOpTag (VecNegOp IntVec 4 W64) = 815+primOpTag (VecNegOp IntVec 64 W8) = 816+primOpTag (VecNegOp IntVec 32 W16) = 817+primOpTag (VecNegOp IntVec 16 W32) = 818+primOpTag (VecNegOp IntVec 8 W64) = 819+primOpTag (VecNegOp FloatVec 4 W32) = 820+primOpTag (VecNegOp FloatVec 2 W64) = 821+primOpTag (VecNegOp FloatVec 8 W32) = 822+primOpTag (VecNegOp FloatVec 4 W64) = 823+primOpTag (VecNegOp FloatVec 16 W32) = 824+primOpTag (VecNegOp FloatVec 8 W64) = 825+primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 826+primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 827+primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 828+primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 829+primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 830+primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 831+primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 832+primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 833+primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 834+primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 835+primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 836+primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 837+primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 838+primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 839+primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 840+primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 841+primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 842+primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 843+primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 844+primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 845+primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 846+primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 847+primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 848+primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 849+primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 850+primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 851+primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 852+primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 853+primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 854+primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 855+primOpTag (VecReadByteArrayOp IntVec 16 W8) = 856+primOpTag (VecReadByteArrayOp IntVec 8 W16) = 857+primOpTag (VecReadByteArrayOp IntVec 4 W32) = 858+primOpTag (VecReadByteArrayOp IntVec 2 W64) = 859+primOpTag (VecReadByteArrayOp IntVec 32 W8) = 860+primOpTag (VecReadByteArrayOp IntVec 16 W16) = 861+primOpTag (VecReadByteArrayOp IntVec 8 W32) = 862+primOpTag (VecReadByteArrayOp IntVec 4 W64) = 863+primOpTag (VecReadByteArrayOp IntVec 64 W8) = 864+primOpTag (VecReadByteArrayOp IntVec 32 W16) = 865+primOpTag (VecReadByteArrayOp IntVec 16 W32) = 866+primOpTag (VecReadByteArrayOp IntVec 8 W64) = 867+primOpTag (VecReadByteArrayOp WordVec 16 W8) = 868+primOpTag (VecReadByteArrayOp WordVec 8 W16) = 869+primOpTag (VecReadByteArrayOp WordVec 4 W32) = 870+primOpTag (VecReadByteArrayOp WordVec 2 W64) = 871+primOpTag (VecReadByteArrayOp WordVec 32 W8) = 872+primOpTag (VecReadByteArrayOp WordVec 16 W16) = 873+primOpTag (VecReadByteArrayOp WordVec 8 W32) = 874+primOpTag (VecReadByteArrayOp WordVec 4 W64) = 875+primOpTag (VecReadByteArrayOp WordVec 64 W8) = 876+primOpTag (VecReadByteArrayOp WordVec 32 W16) = 877+primOpTag (VecReadByteArrayOp WordVec 16 W32) = 878+primOpTag (VecReadByteArrayOp WordVec 8 W64) = 879+primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 880+primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 881+primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 882+primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 883+primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 884+primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 885+primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 886+primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 887+primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 888+primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 889+primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 890+primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 891+primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 892+primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 893+primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 894+primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 895+primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 896+primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 897+primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 898+primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 899+primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 900+primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 901+primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 902+primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 903+primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 904+primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 905+primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 906+primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 907+primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 908+primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 909+primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 910+primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 911+primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 912+primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 913+primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 914+primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 915+primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 916+primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 917+primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 918+primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 919+primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 920+primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 921+primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 922+primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 923+primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 924+primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 925+primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 926+primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 927+primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 928+primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 929+primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 930+primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 931+primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 932+primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 933+primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 934+primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 935+primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 936+primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 937+primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 938+primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 939+primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 940+primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 941+primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 942+primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 943+primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 944+primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 945+primOpTag (VecReadOffAddrOp IntVec 16 W8) = 946+primOpTag (VecReadOffAddrOp IntVec 8 W16) = 947+primOpTag (VecReadOffAddrOp IntVec 4 W32) = 948+primOpTag (VecReadOffAddrOp IntVec 2 W64) = 949+primOpTag (VecReadOffAddrOp IntVec 32 W8) = 950+primOpTag (VecReadOffAddrOp IntVec 16 W16) = 951+primOpTag (VecReadOffAddrOp IntVec 8 W32) = 952+primOpTag (VecReadOffAddrOp IntVec 4 W64) = 953+primOpTag (VecReadOffAddrOp IntVec 64 W8) = 954+primOpTag (VecReadOffAddrOp IntVec 32 W16) = 955+primOpTag (VecReadOffAddrOp IntVec 16 W32) = 956+primOpTag (VecReadOffAddrOp IntVec 8 W64) = 957+primOpTag (VecReadOffAddrOp WordVec 16 W8) = 958+primOpTag (VecReadOffAddrOp WordVec 8 W16) = 959+primOpTag (VecReadOffAddrOp WordVec 4 W32) = 960+primOpTag (VecReadOffAddrOp WordVec 2 W64) = 961+primOpTag (VecReadOffAddrOp WordVec 32 W8) = 962+primOpTag (VecReadOffAddrOp WordVec 16 W16) = 963+primOpTag (VecReadOffAddrOp WordVec 8 W32) = 964+primOpTag (VecReadOffAddrOp WordVec 4 W64) = 965+primOpTag (VecReadOffAddrOp WordVec 64 W8) = 966+primOpTag (VecReadOffAddrOp WordVec 32 W16) = 967+primOpTag (VecReadOffAddrOp WordVec 16 W32) = 968+primOpTag (VecReadOffAddrOp WordVec 8 W64) = 969+primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 970+primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 971+primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 972+primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 973+primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 974+primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 975+primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 976+primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 977+primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 978+primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 979+primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 980+primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 981+primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 982+primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 983+primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 984+primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 985+primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 986+primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 987+primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 988+primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 989+primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 990+primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 991+primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 992+primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 993+primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 994+primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 995+primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 996+primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 997+primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 998+primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 999+primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1000+primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1001+primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1002+primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1003+primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1004+primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1005+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1006+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1007+primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1008+primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1009+primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1010+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1011+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1012+primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1013+primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1014+primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1015+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1016+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1017+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1018+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1019+primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1020+primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1021+primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1022+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1023+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1024+primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1025+primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1026+primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1027+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1028+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1029+primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1030+primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1031+primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1032+primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1033+primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1034+primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1035+primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1036+primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1037+primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1038+primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1039+primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1040+primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1041+primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1042+primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1043+primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1044+primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1045+primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1046+primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1047+primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1048+primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1049+primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1050+primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1051+primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1052+primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1053+primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1054+primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1055+primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1056+primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1057+primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1058+primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1059+primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1060+primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1061+primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1062+primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1063+primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1064+primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1065+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1066+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1067+primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1068+primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1069+primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1070+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1071+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1072+primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1073+primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1074+primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1075+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1076+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1077+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1078+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1079+primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1080+primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1081+primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1082+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1083+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1084+primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1085+primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1086+primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1087+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1088+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1089+primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1090+primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1091+primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1092+primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1093+primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1094+primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1095+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1096+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1097+primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1098+primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1099+primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1100+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1101+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1102+primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1103+primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1104+primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1105+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1106+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1107+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1108+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1109+primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1110+primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1111+primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1112+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1113+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1114+primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1115+primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1116+primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1117+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1118+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1119+primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1120+primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1121+primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1122+primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1123+primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1124+primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1125+primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1126+primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1127+primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1128+primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1129+primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1130+primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1131+primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1132+primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1133+primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1134+primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1135+primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1136+primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1137+primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1138+primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1139+primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1140+primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1141+primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1142+primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1143+primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1144+primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1145+primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1146+primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1147+primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1148+primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1149+primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1150+primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1151+primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1152+primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1153+primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1154+primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1155+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1156+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1157+primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1158+primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1159+primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1160+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1161+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1162+primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1163+primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1164+primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1165+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1166+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1167+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1168+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1169+primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1170+primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1171+primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1172+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1173+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1174+primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1175+primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1176+primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1177+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1178+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1179+primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1180+primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1181+primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1182+primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1183+primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1184+primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1185+primOpTag PrefetchByteArrayOp3 = 1186+primOpTag PrefetchMutableByteArrayOp3 = 1187+primOpTag PrefetchAddrOp3 = 1188+primOpTag PrefetchValueOp3 = 1189+primOpTag PrefetchByteArrayOp2 = 1190+primOpTag PrefetchMutableByteArrayOp2 = 1191+primOpTag PrefetchAddrOp2 = 1192+primOpTag PrefetchValueOp2 = 1193+primOpTag PrefetchByteArrayOp1 = 1194+primOpTag PrefetchMutableByteArrayOp1 = 1195+primOpTag PrefetchAddrOp1 = 1196+primOpTag PrefetchValueOp1 = 1197+primOpTag PrefetchByteArrayOp0 = 1198+primOpTag PrefetchMutableByteArrayOp0 = 1199+primOpTag PrefetchAddrOp0 = 1200+primOpTag PrefetchValueOp0 = 1201
ghc-lib/stage1/lib/platformConstants view
@@ -101,7 +101,7 @@ , pc_MAX_SPEC_AP_SIZE = 7 , pc_MIN_PAYLOAD_SIZE = 1 , pc_MIN_INTLIKE = -16- , pc_MAX_INTLIKE = 16+ , pc_MAX_INTLIKE = 255 , pc_MIN_CHARLIKE = 0 , pc_MAX_CHARLIKE = 255 , pc_MUT_ARR_PTRS_CARD_BITS = 7
ghc-lib/stage1/lib/settings view
@@ -31,6 +31,7 @@ ,("target has subsections via symbols", "True") ,("target has RTS linker", "YES") ,("Unregisterised", "NO")+,("LLVM target", "x86_64-apple-darwin") ,("LLVM llc command", "llc") ,("LLVM opt command", "opt") ,("LLVM clang command", "clang")
− ghc/GHCi/Leak.hs
@@ -1,74 +0,0 @@-{-# LANGUAGE RecordWildCards, LambdaCase #-}-module GHCi.Leak- ( LeakIndicators- , getLeakIndicators- , checkLeakIndicators- ) where--import Control.Monad-import Data.Bits-import Foreign.Ptr (ptrToIntPtr, intPtrToPtr)-import GHC-import GHC.Ptr (Ptr (..))-import GHCi.Util-import HscTypes-import Outputable-import GHC.Platform (target32Bit)-import Prelude-import System.Mem-import System.Mem.Weak-import UniqDFM---- Checking for space leaks in GHCi. See #15111, and the--- -fghci-leak-check flag.--data LeakIndicators = LeakIndicators [LeakModIndicators]--data LeakModIndicators = LeakModIndicators- { leakMod :: Weak HomeModInfo- , leakIface :: Weak ModIface- , leakDetails :: Weak ModDetails- , leakLinkable :: Maybe (Weak Linkable)- }---- | Grab weak references to some of the data structures representing--- the currently loaded modules.-getLeakIndicators :: HscEnv -> IO LeakIndicators-getLeakIndicators HscEnv{..} =- fmap LeakIndicators $- forM (eltsUDFM hsc_HPT) $ \hmi@HomeModInfo{..} -> do- leakMod <- mkWeakPtr hmi Nothing- leakIface <- mkWeakPtr hm_iface Nothing- leakDetails <- mkWeakPtr hm_details Nothing- leakLinkable <- mapM (`mkWeakPtr` Nothing) hm_linkable- return $ LeakModIndicators{..}---- | Look at the LeakIndicators collected by an earlier call to--- `getLeakIndicators`, and print messasges if any of them are still--- alive.-checkLeakIndicators :: DynFlags -> LeakIndicators -> IO ()-checkLeakIndicators dflags (LeakIndicators leakmods) = do- performGC- forM_ leakmods $ \LeakModIndicators{..} -> do- deRefWeak leakMod >>= \case- Nothing -> return ()- Just hmi ->- report ("HomeModInfo for " ++- showSDoc dflags (ppr (mi_module (hm_iface hmi)))) (Just hmi)- deRefWeak leakIface >>= report "ModIface"- deRefWeak leakDetails >>= report "ModDetails"- forM_ leakLinkable $ \l -> deRefWeak l >>= report "Linkable"- where- report :: String -> Maybe a -> IO ()- report _ Nothing = return ()- report msg (Just a) = do- addr <- anyToPtr a- putStrLn ("-fghci-leak-check: " ++ msg ++ " is still alive at " ++- show (maskTagBits addr))-- tagBits- | target32Bit (targetPlatform dflags) = 2- | otherwise = 3-- maskTagBits :: Ptr a -> Ptr a- maskTagBits p = intPtrToPtr (ptrToIntPtr p .&. complement (shiftL 1 tagBits - 1))
− ghc/GHCi/UI.hs
@@ -1,4134 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS -fno-cse #-}--- -fno-cse is needed for GLOBAL_VAR's to behave properly------------------------------------------------------------------------------------- GHC Interactive User Interface------ (c) The GHC Team 2005-2006-----------------------------------------------------------------------------------module GHCi.UI (- interactiveUI,- GhciSettings(..),- defaultGhciSettings,- ghciCommands,- ghciWelcomeMsg- ) where--#include "HsVersions.h"---- GHCi-import qualified GHCi.UI.Monad as GhciMonad ( args, runStmt, runDecls' )-import GHCi.UI.Monad hiding ( args, runStmt )-import GHCi.UI.Tags-import GHCi.UI.Info-import Debugger---- The GHC interface-import GHCi-import GHCi.RemoteTypes-import GHCi.BreakArray-import DynFlags-import ErrUtils hiding (traceCmd)-import Finder-import GhcMonad ( modifySession )-import qualified GHC-import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..),- TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,- GetDocsFailure(..),- getModuleGraph, handleSourceError )-import HscMain (hscParseDeclsWithLocation, hscParseStmtWithLocation)-import HsImpExp-import HsSyn-import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,- setInteractivePrintName, hsc_dflags, msObjFilePath, runInteractiveHsc,- hsc_dynLinker )-import Module-import Name-import Packages ( trusted, getPackageDetails, getInstalledPackageDetails,- listVisibleModuleNames, pprFlag )-import IfaceSyn ( showToHeader )-import PprTyThing-import PrelNames-import RdrName ( getGRE_NameQualifier_maybes, getRdrName )-import SrcLoc-import qualified Lexer--import StringBuffer-import Outputable hiding ( printForUser, printForUserPartWay )--import DynamicLoading ( initializePlugins )---- Other random utilities-import BasicTypes hiding ( isTopLevel )-import Config-import Digraph-import Encoding-import FastString-import Linker-import Maybes ( orElse, expectJust )-import NameSet-import Panic hiding ( showException )-import Util-import qualified GHC.LanguageExtensions as LangExt-import Bag (unitBag)---- Haskell Libraries-import System.Console.Haskeline as Haskeline--import Control.Applicative hiding (empty)-import Control.DeepSeq (deepseq)-import Control.Monad as Monad-import Control.Monad.IO.Class-import Control.Monad.Trans.Class-import Control.Monad.Trans.Except--import Data.Array-import qualified Data.ByteString.Char8 as BS-import Data.Char-import Data.Function-import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )-import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,- partition, sort, sortBy, (\\) )-import qualified Data.Set as S-import Data.Maybe-import Data.Map (Map)-import qualified Data.Map as M-import qualified Data.IntMap.Strict as IntMap-import Data.Time.LocalTime ( getZonedTime )-import Data.Time.Format ( formatTime, defaultTimeLocale )-import Data.Version ( showVersion )-import Prelude hiding ((<>))--import Exception hiding (catch)-import Foreign hiding (void)-import GHC.Stack hiding (SrcLoc(..))--import System.Directory-import System.Environment-import System.Exit ( exitWith, ExitCode(..) )-import System.FilePath-import System.Info-import System.IO-import System.IO.Error-import System.IO.Unsafe ( unsafePerformIO )-import System.Process-import Text.Printf-import Text.Read ( readMaybe )-import Text.Read.Lex (isSymbolChar)--import Unsafe.Coerce--#if !defined(mingw32_HOST_OS)-import System.Posix hiding ( getEnv )-#else-import qualified System.Win32-#endif--import GHC.IO.Exception ( IOErrorType(InvalidArgument) )-import GHC.IO.Handle ( hFlushAll )-import GHC.TopHandler ( topHandler )--import GHCi.Leak---------------------------------------------------------------------------------data GhciSettings = GhciSettings {- availableCommands :: [Command],- shortHelpText :: String,- fullHelpText :: String,- defPrompt :: PromptFunction,- defPromptCont :: PromptFunction- }--defaultGhciSettings :: GhciSettings-defaultGhciSettings =- GhciSettings {- availableCommands = ghciCommands,- shortHelpText = defShortHelpText,- defPrompt = default_prompt,- defPromptCont = default_prompt_cont,- fullHelpText = defFullHelpText- }--ghciWelcomeMsg :: String-ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++- ": https://www.haskell.org/ghc/ :? for help"--ghciCommands :: [Command]-ghciCommands = map mkCmd [- -- Hugs users are accustomed to :e, so make sure it doesn't overlap- ("?", keepGoing help, noCompletion),- ("add", keepGoingPaths addModule, completeFilename),- ("abandon", keepGoing abandonCmd, noCompletion),- ("break", keepGoing breakCmd, completeIdentifier),- ("back", keepGoing backCmd, noCompletion),- ("browse", keepGoing' (browseCmd False), completeModule),- ("browse!", keepGoing' (browseCmd True), completeModule),- ("cd", keepGoing' changeDirectory, completeFilename),- ("check", keepGoing' checkModule, completeHomeModule),- ("continue", keepGoing continueCmd, noCompletion),- ("cmd", keepGoing cmdCmd, completeExpression),- ("ctags", keepGoing createCTagsWithLineNumbersCmd, completeFilename),- ("ctags!", keepGoing createCTagsWithRegExesCmd, completeFilename),- ("def", keepGoing (defineMacro False), completeExpression),- ("def!", keepGoing (defineMacro True), completeExpression),- ("delete", keepGoing deleteCmd, noCompletion),- ("disable", keepGoing disableCmd, noCompletion),- ("doc", keepGoing' docCmd, completeIdentifier),- ("edit", keepGoing' editFile, completeFilename),- ("enable", keepGoing enableCmd, noCompletion),- ("etags", keepGoing createETagsFileCmd, completeFilename),- ("force", keepGoing forceCmd, completeExpression),- ("forward", keepGoing forwardCmd, noCompletion),- ("help", keepGoing help, noCompletion),- ("history", keepGoing historyCmd, noCompletion),- ("info", keepGoing' (info False), completeIdentifier),- ("info!", keepGoing' (info True), completeIdentifier),- ("issafe", keepGoing' isSafeCmd, completeModule),- ("kind", keepGoing' (kindOfType False), completeIdentifier),- ("kind!", keepGoing' (kindOfType True), completeIdentifier),- ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),- ("load!", keepGoingPaths loadModuleDefer, completeHomeModuleOrFile),- ("list", keepGoing' listCmd, noCompletion),- ("module", keepGoing moduleCmd, completeSetModule),- ("main", keepGoing runMain, completeFilename),- ("print", keepGoing printCmd, completeExpression),- ("quit", quit, noCompletion),- ("reload", keepGoing' reloadModule, noCompletion),- ("reload!", keepGoing' reloadModuleDefer, noCompletion),- ("run", keepGoing runRun, completeFilename),- ("script", keepGoing' scriptCmd, completeFilename),- ("set", keepGoing setCmd, completeSetOptions),- ("seti", keepGoing setiCmd, completeSeti),- ("show", keepGoing showCmd, completeShowOptions),- ("showi", keepGoing showiCmd, completeShowiOptions),- ("sprint", keepGoing sprintCmd, completeExpression),- ("step", keepGoing stepCmd, completeIdentifier),- ("steplocal", keepGoing stepLocalCmd, completeIdentifier),- ("stepmodule",keepGoing stepModuleCmd, completeIdentifier),- ("type", keepGoing' typeOfExpr, completeExpression),- ("trace", keepGoing traceCmd, completeExpression),- ("unadd", keepGoingPaths unAddModule, completeFilename),- ("undef", keepGoing undefineMacro, completeMacro),- ("unset", keepGoing unsetOptions, completeSetOptions),- ("where", keepGoing whereCmd, noCompletion),- ("instances", keepGoing' instancesCmd, completeExpression)- ] ++ map mkCmdHidden [ -- hidden commands- ("all-types", keepGoing' allTypesCmd),- ("complete", keepGoing completeCmd),- ("loc-at", keepGoing' locAtCmd),- ("type-at", keepGoing' typeAtCmd),- ("uses", keepGoing' usesCmd)- ]- where- mkCmd (n,a,c) = Command { cmdName = n- , cmdAction = a- , cmdHidden = False- , cmdCompletionFunc = c- }-- mkCmdHidden (n,a) = Command { cmdName = n- , cmdAction = a- , cmdHidden = True- , cmdCompletionFunc = noCompletion- }---- We initialize readline (in the interactiveUI function) to use--- word_break_chars as the default set of completion word break characters.--- This can be overridden for a particular command (for example, filename--- expansion shouldn't consider '/' to be a word break) by setting the third--- entry in the Command tuple above.------ NOTE: in order for us to override the default correctly, any custom entry--- must be a SUBSET of word_break_chars.-word_break_chars :: String-word_break_chars = spaces ++ specials ++ symbols--symbols, specials, spaces :: String-symbols = "!#$%&*+/<=>?@\\^|-~"-specials = "(),;[]`{}"-spaces = " \t\n"--flagWordBreakChars :: String-flagWordBreakChars = " \t\n"---keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool)-keepGoing a str = keepGoing' (lift . a) str--keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool-keepGoing' a str = a str >> return False--keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)-keepGoingPaths a str- = do case toArgs str of- Left err -> liftIO $ hPutStrLn stderr err- Right args -> a args- return False--defShortHelpText :: String-defShortHelpText = "use :? for help.\n"--defFullHelpText :: String-defFullHelpText =- " Commands available from the prompt:\n" ++- "\n" ++- " <statement> evaluate/run <statement>\n" ++- " : repeat last command\n" ++- " :{\\n ..lines.. \\n:}\\n multiline command\n" ++- " :add [*]<module> ... add module(s) to the current target set\n" ++- " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++- " (!: more details; *: all top-level names)\n" ++- " :cd <dir> change directory to <dir>\n" ++- " :cmd <expr> run the commands returned by <expr>::IO String\n" ++- " :complete <dom> [<rng>] <s> list completions for partial input string\n" ++- " :ctags[!] [<file>] create tags file <file> for Vi (default: \"tags\")\n" ++- " (!: use regex instead of line number)\n" ++- " :def <cmd> <expr> define command :<cmd> (later defined command has\n" ++- " precedence, ::<cmd> is always a builtin command)\n" ++- " :doc <name> display docs for the given name (experimental)\n" ++- " :edit <file> edit file\n" ++- " :edit edit last module\n" ++- " :etags [<file>] create tags file <file> for Emacs (default: \"TAGS\")\n" ++- " :help, :? display this list of commands\n" ++- " :info[!] [<name> ...] display information about the given names\n" ++- " (!: do not filter instances)\n" ++- " :issafe [<mod>] display safe haskell information of module <mod>\n" ++- " :kind[!] <type> show the kind of <type>\n" ++- " (!: also print the normalised type)\n" ++- " :load[!] [*]<module> ... load module(s) and their dependents\n" ++- " (!: defer type errors)\n" ++- " :main [<arguments> ...] run the main function with the given arguments\n" ++- " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++- " :quit exit GHCi\n" ++- " :reload[!] reload the current module set\n" ++- " (!: defer type errors)\n" ++- " :run function [<arguments> ...] run the function with the given arguments\n" ++- " :script <file> run the script <file>\n" ++- " :type <expr> show the type of <expr>\n" ++- " :type +d <expr> show the type of <expr>, defaulting type variables\n" ++- " :type +v <expr> show the type of <expr>, with its specified tyvars\n" ++- " :unadd <module> ... remove module(s) from the current target set\n" ++- " :undef <cmd> undefine user-defined command :<cmd>\n" ++- " :!<command> run the shell command <command>\n" ++- "\n" ++- " -- Commands for debugging:\n" ++- "\n" ++- " :abandon at a breakpoint, abandon current computation\n" ++- " :back [<n>] go back in the history N steps (after :trace)\n" ++- " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++- " :break <name> set a breakpoint on the specified function\n" ++- " :continue resume after a breakpoint\n" ++- " :delete <number> ... delete the specified breakpoints\n" ++- " :delete * delete all breakpoints\n" ++- " :disable <number> ... disable the specified breakpoints\n" ++- " :disable * disable all breakpoints\n" ++- " :enable <number> ... enable the specified breakpoints\n" ++- " :enable * enable all breakpoints\n" ++- " :force <expr> print <expr>, forcing unevaluated parts\n" ++- " :forward [<n>] go forward in the history N step s(after :back)\n" ++- " :history [<n>] after :trace, show the execution history\n" ++- " :list show the source code around current breakpoint\n" ++- " :list <identifier> show the source code for <identifier>\n" ++- " :list [<module>] <line> show the source code around line number <line>\n" ++- " :print [<name> ...] show a value without forcing its computation\n" ++- " :sprint [<name> ...] simplified version of :print\n" ++- " :step single-step after stopping at a breakpoint\n"++- " :step <expr> single-step into <expr>\n"++- " :steplocal single-step within the current top-level binding\n"++- " :stepmodule single-step restricted to the current module\n"++- " :trace trace after stopping at a breakpoint\n"++- " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++-- "\n" ++- " -- Commands for changing settings:\n" ++- "\n" ++- " :set <option> ... set options\n" ++- " :seti <option> ... set options for interactive evaluation only\n" ++- " :set local-config { source | ignore }\n" ++- " set whether to source .ghci in current dir\n" ++- " (loading untrusted config is a security issue)\n" ++- " :set args <arg> ... set the arguments returned by System.getArgs\n" ++- " :set prog <progname> set the value returned by System.getProgName\n" ++- " :set prompt <prompt> set the prompt used in GHCi\n" ++- " :set prompt-cont <prompt> set the continuation prompt used in GHCi\n" ++- " :set prompt-function <expr> set the function to handle the prompt\n" ++- " :set prompt-cont-function <expr>\n" ++- " set the function to handle the continuation prompt\n" ++- " :set editor <cmd> set the command used for :edit\n" ++- " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" ++- " :unset <option> ... unset options\n" ++- "\n" ++- " Options for ':set' and ':unset':\n" ++- "\n" ++- " +m allow multiline commands\n" ++- " +r revert top-level expressions after each evaluation\n" ++- " +s print timing/memory stats after each evaluation\n" ++- " +t print type after evaluation\n" ++- " +c collect type/location info after loading modules\n" ++- " -<flags> most GHC command line flags can also be set here\n" ++- " (eg. -v2, -XFlexibleInstances, etc.)\n" ++- " for GHCi-specific flags, see User's Guide,\n"++- " Flag reference, Interactive-mode options\n" ++- "\n" ++- " -- Commands for displaying information:\n" ++- "\n" ++- " :show bindings show the current bindings made at the prompt\n" ++- " :show breaks show the active breakpoints\n" ++- " :show context show the breakpoint context\n" ++- " :show imports show the current imports\n" ++- " :show linker show current linker state\n" ++- " :show modules show the currently loaded modules\n" ++- " :show packages show the currently active package flags\n" ++- " :show paths show the currently active search paths\n" ++- " :show language show the currently active language flags\n" ++- " :show targets show the current set of targets\n" ++- " :show <setting> show value of <setting>, which is one of\n" ++- " [args, prog, editor, stop]\n" ++- " :showi language show language flags for interactive evaluation\n" ++- "\n"--findEditor :: IO String-findEditor = do- getEnv "EDITOR"- `catchIO` \_ -> do-#if defined(mingw32_HOST_OS)- win <- System.Win32.getWindowsDirectory- return (win </> "notepad.exe")-#else- return ""-#endif--default_progname, default_stop :: String-default_progname = "<interactive>"-default_stop = ""--default_prompt, default_prompt_cont :: PromptFunction-default_prompt = generatePromptFunctionFromString "%s> "-default_prompt_cont = generatePromptFunctionFromString "%s| "--default_args :: [String]-default_args = []--interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String]- -> Ghc ()-interactiveUI config srcs maybe_exprs = do- -- HACK! If we happen to get into an infinite loop (eg the user- -- types 'let x=x in x' at the prompt), then the thread will block- -- on a blackhole, and become unreachable during GC. The GC will- -- detect that it is unreachable and send it the NonTermination- -- exception. However, since the thread is unreachable, everything- -- it refers to might be finalized, including the standard Handles.- -- This sounds like a bug, but we don't have a good solution right- -- now.- _ <- liftIO $ newStablePtr stdin- _ <- liftIO $ newStablePtr stdout- _ <- liftIO $ newStablePtr stderr-- -- Initialise buffering for the *interpreted* I/O system- (nobuffering, flush) <- initInterpBuffering-- -- The initial set of DynFlags used for interactive evaluation is the same- -- as the global DynFlags, plus -XExtendedDefaultRules and- -- -XNoMonomorphismRestriction.- -- See note [Changing language extensions for interactive evaluation] #10857- dflags <- getDynFlags- let dflags' = (xopt_set_unlessExplSpec- LangExt.ExtendedDefaultRules xopt_set)- . (xopt_set_unlessExplSpec- LangExt.MonomorphismRestriction xopt_unset)- $ dflags- GHC.setInteractiveDynFlags dflags'-- lastErrLocationsRef <- liftIO $ newIORef []- progDynFlags <- GHC.getProgramDynFlags- _ <- GHC.setProgramDynFlags $- -- Ensure we don't override the user's log action lest we break- -- -ddump-json (#14078)- progDynFlags { log_action = ghciLogAction (log_action progDynFlags)- lastErrLocationsRef }-- when (isNothing maybe_exprs) $ do- -- Only for GHCi (not runghc and ghc -e):-- -- Turn buffering off for the compiled program's stdout/stderr- turnOffBuffering_ nobuffering- -- Turn buffering off for GHCi's stdout- liftIO $ hFlush stdout- liftIO $ hSetBuffering stdout NoBuffering- -- We don't want the cmd line to buffer any input that might be- -- intended for the program, so unbuffer stdin.- liftIO $ hSetBuffering stdin NoBuffering- liftIO $ hSetBuffering stderr NoBuffering-#if defined(mingw32_HOST_OS)- -- On Unix, stdin will use the locale encoding. The IO library- -- doesn't do this on Windows (yet), so for now we use UTF-8,- -- for consistency with GHC 6.10 and to make the tests work.- liftIO $ hSetEncoding stdin utf8-#endif-- default_editor <- liftIO $ findEditor- eval_wrapper <- mkEvalWrapper default_progname default_args- let prelude_import = simpleImportDecl preludeModuleName- startGHCi (runGHCi srcs maybe_exprs)- GHCiState{ progname = default_progname,- args = default_args,- evalWrapper = eval_wrapper,- prompt = defPrompt config,- prompt_cont = defPromptCont config,- stop = default_stop,- editor = default_editor,- options = [],- localConfig = SourceLocalConfig,- -- We initialize line number as 0, not 1, because we use- -- current line number while reporting errors which is- -- incremented after reading a line.- line_number = 0,- break_ctr = 0,- breaks = IntMap.empty,- tickarrays = emptyModuleEnv,- ghci_commands = availableCommands config,- ghci_macros = [],- last_command = Nothing,- cmd_wrapper = (cmdSuccess =<<),- cmdqueue = [],- remembered_ctx = [],- transient_ctx = [],- extra_imports = [],- prelude_imports = [prelude_import],- ghc_e = isJust maybe_exprs,- short_help = shortHelpText config,- long_help = fullHelpText config,- lastErrorLocations = lastErrLocationsRef,- mod_infos = M.empty,- flushStdHandles = flush,- noBuffering = nobuffering- }-- return ()--{--Note [Changing language extensions for interactive evaluation]----------------------------------------------------------------GHCi maintains two sets of options:--- The "loading options" apply when loading modules-- The "interactive options" apply when evaluating expressions and commands- typed at the GHCi prompt.--The loading options are mostly created in ghc/Main.hs:main' from the command-line flags. In the function ghc/GHCi/UI.hs:interactiveUI the loading options-are copied to the interactive options.--These interactive options (but not the loading options!) are supplemented-unconditionally by setting ExtendedDefaultRules ON and-MonomorphismRestriction OFF. The unconditional setting of these options-eventually overwrite settings already specified at the command line.--Therefore instead of unconditionally setting ExtendedDefaultRules and-NoMonomorphismRestriction for the interactive options, we use the function-'xopt_set_unlessExplSpec' to first check whether the extension has already-specified at the command line.--The ghci config file has not yet been processed.--}--resetLastErrorLocations :: GhciMonad m => m ()-resetLastErrorLocations = do- st <- getGHCiState- liftIO $ writeIORef (lastErrorLocations st) []--ghciLogAction :: LogAction -> IORef [(FastString, Int)] -> LogAction-ghciLogAction old_log_action lastErrLocations- dflags flag severity srcSpan style msg = do- old_log_action dflags flag severity srcSpan style msg- case severity of- SevError -> case srcSpan of- RealSrcSpan rsp -> modifyIORef lastErrLocations- (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])- _ -> return ()- _ -> return ()--withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a-withGhcAppData right left = do- either_dir <- tryIO (getAppUserDataDirectory "ghc")- case either_dir of- Right dir ->- do createDirectoryIfMissing False dir `catchIO` \_ -> return ()- right dir- _ -> left--runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()-runGHCi paths maybe_exprs = do- dflags <- getDynFlags- let- ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags-- app_user_dir = liftIO $ withGhcAppData- (\dir -> return (Just (dir </> "ghci.conf")))- (return Nothing)-- home_dir = do- either_dir <- liftIO $ tryIO (getEnv "HOME")- case either_dir of- Right home -> return (Just (home </> ".ghci"))- _ -> return Nothing-- canonicalizePath' :: FilePath -> IO (Maybe FilePath)- canonicalizePath' fp = liftM Just (canonicalizePath fp)- `catchIO` \_ -> return Nothing-- sourceConfigFile :: FilePath -> GHCi ()- sourceConfigFile file = do- exists <- liftIO $ doesFileExist file- when exists $ do- either_hdl <- liftIO $ tryIO (openFile file ReadMode)- case either_hdl of- Left _e -> return ()- -- NOTE: this assumes that runInputT won't affect the terminal;- -- can we assume this will always be the case?- -- This would be a good place for runFileInputT.- Right hdl ->- do runInputTWithPrefs defaultPrefs defaultSettings $- runCommands $ fileLoop hdl- liftIO (hClose hdl `catchIO` \_ -> return ())- -- Don't print a message if this is really ghc -e (#11478).- -- Also, let the user silence the message with -v0- -- (the default verbosity in GHCi is 1).- when (isNothing maybe_exprs && verbosity dflags > 0) $- liftIO $ putStrLn ("Loaded GHCi configuration from " ++ file)-- ---- setGHCContextFromGHCiState-- processedCfgs <- if ignore_dot_ghci- then pure []- else do- userCfgs <- do- paths <- catMaybes <$> sequence [ app_user_dir, home_dir ]- checkedPaths <- liftIO $ filterM checkFileAndDirPerms paths- liftIO . fmap (nub . catMaybes) $ mapM canonicalizePath' checkedPaths-- localCfg <- do- let path = ".ghci"- ok <- liftIO $ checkFileAndDirPerms path- if ok then liftIO $ canonicalizePath' path else pure Nothing-- mapM_ sourceConfigFile userCfgs- -- Process the global and user .ghci- -- (but not $CWD/.ghci or CLI args, yet)-- behaviour <- localConfig <$> getGHCiState-- processedLocalCfg <- case localCfg of- Just path | path `notElem` userCfgs ->- -- don't read .ghci twice if CWD is $HOME- case behaviour of- SourceLocalConfig -> localCfg <$ sourceConfigFile path- IgnoreLocalConfig -> pure Nothing- _ -> pure Nothing-- pure $ maybe id (:) processedLocalCfg userCfgs-- let arg_cfgs = reverse $ ghciScripts dflags- -- -ghci-script are collected in reverse order- -- We don't require that a script explicitly added by -ghci-script- -- is owned by the current user. (#6017)-- mapM_ sourceConfigFile $ nub arg_cfgs \\ processedCfgs- -- Dedup, and remove any configs we already processed.- -- Importantly, if $PWD/.ghci was ignored due to configuration,- -- explicitly specifying it does cause it to be processed.-- -- Perform a :load for files given on the GHCi command line- -- When in -e mode, if the load fails then we want to stop- -- immediately rather than going on to evaluate the expression.- when (not (null paths)) $ do- ok <- ghciHandle (\e -> do showException e; return Failed) $- -- TODO: this is a hack.- runInputTWithPrefs defaultPrefs defaultSettings $- loadModule paths- when (isJust maybe_exprs && failed ok) $- liftIO (exitWith (ExitFailure 1))-- installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)-- -- if verbosity is greater than 0, or we are connected to a- -- terminal, display the prompt in the interactive loop.- is_tty <- liftIO (hIsTerminalDevice stdin)- let show_prompt = verbosity dflags > 0 || is_tty-- -- reset line number- modifyGHCiState $ \st -> st{line_number=0}-- case maybe_exprs of- Nothing ->- do- -- enter the interactive loop- runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty- Just exprs -> do- -- just evaluate the expression we were given- enqueueCommands exprs- let hdle e = do st <- getGHCiState- -- flush the interpreter's stdout/stderr on exit (#3890)- flushInterpBuffers- -- Jump through some hoops to get the- -- current progname in the exception text:- -- <progname>: <exception>- liftIO $ withProgName (progname st)- $ topHandler e- -- this used to be topHandlerFastExit, see #2228- runInputTWithPrefs defaultPrefs defaultSettings $ do- -- make `ghc -e` exit nonzero on invalid input, see #7962- _ <- runCommands' hdle- (Just $ hdle (toException $ ExitFailure 1) >> return ())- (return Nothing)- return ()-- -- and finally, exit- liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."--runGHCiInput :: InputT GHCi a -> GHCi a-runGHCiInput f = do- dflags <- getDynFlags- let ghciHistory = gopt Opt_GhciHistory dflags- let localGhciHistory = gopt Opt_LocalGhciHistory dflags- currentDirectory <- liftIO $ getCurrentDirectory-- histFile <- case (ghciHistory, localGhciHistory) of- (True, True) -> return (Just (currentDirectory </> ".ghci_history"))- (True, _) -> liftIO $ withGhcAppData- (\dir -> return (Just (dir </> "ghci_history"))) (return Nothing)- _ -> return Nothing-- runInputT- (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})- f---- | How to get the next input line from the user-nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)-nextInputLine show_prompt is_tty- | is_tty = do- prmpt <- if show_prompt then lift mkPrompt else return ""- r <- getInputLine prmpt- incrementLineNo- return r- | otherwise = do- when show_prompt $ lift mkPrompt >>= liftIO . putStr- fileLoop stdin---- NOTE: We only read .ghci files if they are owned by the current user,--- and aren't world writable (files owned by root are ok, see #9324).--- Otherwise, we could be accidentally running code planted by--- a malicious third party.---- Furthermore, We only read ./.ghci if . is owned by the current user--- and isn't writable by anyone else. I think this is sufficient: we--- don't need to check .. and ../.. etc. because "." always refers to--- the same directory while a process is running.--checkFileAndDirPerms :: FilePath -> IO Bool-checkFileAndDirPerms file = do- file_ok <- checkPerms file- -- Do not check dir perms when .ghci doesn't exist, otherwise GHCi will- -- print some confusing and useless warnings in some cases (e.g. in- -- travis). Note that we can't add a test for this, as all ghci tests should- -- run with -ignore-dot-ghci, which means we never get here.- if file_ok then checkPerms (getDirectory file) else return False- where- getDirectory f = case takeDirectory f of- "" -> "."- d -> d--checkPerms :: FilePath -> IO Bool-#if defined(mingw32_HOST_OS)-checkPerms _ = return True-#else-checkPerms file =- handleIO (\_ -> return False) $ do- st <- getFileStatus file- me <- getRealUserID- let mode = System.Posix.fileMode st- ok = (fileOwner st == me || fileOwner st == 0) &&- groupWriteMode /= mode `intersectFileModes` groupWriteMode &&- otherWriteMode /= mode `intersectFileModes` otherWriteMode- unless ok $- -- #8248: Improving warning to include a possible fix.- putStrLn $ "*** WARNING: " ++ file ++- " is writable by someone else, IGNORING!" ++- "\nSuggested fix: execute 'chmod go-w " ++ file ++ "'"- return ok-#endif--incrementLineNo :: GhciMonad m => m ()-incrementLineNo = modifyGHCiState incLineNo- where- incLineNo st = st { line_number = line_number st + 1 }--fileLoop :: GhciMonad m => Handle -> m (Maybe String)-fileLoop hdl = do- l <- liftIO $ tryIO $ hGetLine hdl- case l of- Left e | isEOFError e -> return Nothing- | -- as we share stdin with the program, the program- -- might have already closed it, so we might get a- -- handle-closed exception. We therefore catch that- -- too.- isIllegalOperation e -> return Nothing- | InvalidArgument <- etype -> return Nothing- | otherwise -> liftIO $ ioError e- where etype = ioeGetErrorType e- -- treat InvalidArgument in the same way as EOF:- -- this can happen if the user closed stdin, or- -- perhaps did getContents which closes stdin at- -- EOF.- Right l' -> do- incrementLineNo- return (Just l')--formatCurrentTime :: String -> IO String-formatCurrentTime format =- getZonedTime >>= return . (formatTime defaultTimeLocale format)--getUserName :: IO String-getUserName = do-#if defined(mingw32_HOST_OS)- getEnv "USERNAME"- `catchIO` \e -> do- putStrLn $ show e- return ""-#else- getLoginName-#endif--getInfoForPrompt :: GhciMonad m => m (SDoc, [String], Int)-getInfoForPrompt = do- st <- getGHCiState- imports <- GHC.getContext- resumes <- GHC.getResumeContext-- context_bit <-- case resumes of- [] -> return empty- r:_ -> do- let ix = GHC.resumeHistoryIx r- if ix == 0- then return (brackets (ppr (GHC.resumeSpan r)) <> space)- else do- let hist = GHC.resumeHistory r !! (ix-1)- pan <- GHC.getHistorySpan hist- return (brackets (ppr (negate ix) <> char ':'- <+> ppr pan) <> space)-- let- dots | _:rs <- resumes, not (null rs) = text "... "- | otherwise = empty-- rev_imports = reverse imports -- rightmost are the most recent-- myIdeclName d | Just m <- ideclAs d = unLoc m- | otherwise = unLoc (ideclName d)-- modules_names =- ['*':(moduleNameString m) | IIModule m <- rev_imports] ++- [moduleNameString (myIdeclName d) | IIDecl d <- rev_imports]- line = 1 + line_number st-- return (dots <> context_bit, modules_names, line)--parseCallEscape :: String -> (String, String)-parseCallEscape s- | not (all isSpace beforeOpen) = ("", "")- | null sinceOpen = ("", "")- | null sinceClosed = ("", "")- | null cmd = ("", "")- | otherwise = (cmd, tail sinceClosed)- where- (beforeOpen, sinceOpen) = span (/='(') s- (cmd, sinceClosed) = span (/=')') (tail sinceOpen)--checkPromptStringForErrors :: String -> Maybe String-checkPromptStringForErrors ('%':'c':'a':'l':'l':xs) =- case parseCallEscape xs of- ("", "") -> Just ("Incorrect %call syntax. " ++- "Should be %call(a command and arguments).")- (_, afterClosed) -> checkPromptStringForErrors afterClosed-checkPromptStringForErrors ('%':'%':xs) = checkPromptStringForErrors xs-checkPromptStringForErrors (_:xs) = checkPromptStringForErrors xs-checkPromptStringForErrors "" = Nothing--generatePromptFunctionFromString :: String -> PromptFunction-generatePromptFunctionFromString promptS modules_names line =- processString promptS- where- processString :: String -> GHCi SDoc- processString ('%':'s':xs) =- liftM2 (<>) (return modules_list) (processString xs)- where- modules_list = hsep $ map text modules_names- processString ('%':'l':xs) =- liftM2 (<>) (return $ ppr line) (processString xs)- processString ('%':'d':xs) =- liftM2 (<>) (liftM text formatted_time) (processString xs)- where- formatted_time = liftIO $ formatCurrentTime "%a %b %d"- processString ('%':'t':xs) =- liftM2 (<>) (liftM text formatted_time) (processString xs)- where- formatted_time = liftIO $ formatCurrentTime "%H:%M:%S"- processString ('%':'T':xs) = do- liftM2 (<>) (liftM text formatted_time) (processString xs)- where- formatted_time = liftIO $ formatCurrentTime "%I:%M:%S"- processString ('%':'@':xs) = do- liftM2 (<>) (liftM text formatted_time) (processString xs)- where- formatted_time = liftIO $ formatCurrentTime "%I:%M %P"- processString ('%':'A':xs) = do- liftM2 (<>) (liftM text formatted_time) (processString xs)- where- formatted_time = liftIO $ formatCurrentTime "%H:%M"- processString ('%':'u':xs) =- liftM2 (<>) (liftM text user_name) (processString xs)- where- user_name = liftIO $ getUserName- processString ('%':'w':xs) =- liftM2 (<>) (liftM text current_directory) (processString xs)- where- current_directory = liftIO $ getCurrentDirectory- processString ('%':'o':xs) =- liftM ((text os) <>) (processString xs)- processString ('%':'a':xs) =- liftM ((text arch) <>) (processString xs)- processString ('%':'N':xs) =- liftM ((text compilerName) <>) (processString xs)- processString ('%':'V':xs) =- liftM ((text $ showVersion compilerVersion) <>) (processString xs)- processString ('%':'c':'a':'l':'l':xs) = do- respond <- liftIO $ do- (code, out, err) <-- readProcessWithExitCode- (head list_words) (tail list_words) ""- `catchIO` \e -> return (ExitFailure 1, "", show e)- case code of- ExitSuccess -> return out- _ -> do- hPutStrLn stderr err- return ""- liftM ((text respond) <>) (processString afterClosed)- where- (cmd, afterClosed) = parseCallEscape xs- list_words = words cmd- processString ('%':'%':xs) =- liftM ((char '%') <>) (processString xs)- processString (x:xs) =- liftM (char x <>) (processString xs)- processString "" =- return empty--mkPrompt :: GHCi String-mkPrompt = do- st <- getGHCiState- dflags <- getDynFlags- (context, modules_names, line) <- getInfoForPrompt-- prompt_string <- (prompt st) modules_names line- let prompt_doc = context <> prompt_string-- return (showSDoc dflags prompt_doc)--queryQueue :: GhciMonad m => m (Maybe String)-queryQueue = do- st <- getGHCiState- case cmdqueue st of- [] -> return Nothing- c:cs -> do setGHCiState st{ cmdqueue = cs }- return (Just c)---- Reconfigurable pretty-printing Ticket #5461-installInteractivePrint :: GHC.GhcMonad m => Maybe String -> Bool -> m ()-installInteractivePrint Nothing _ = return ()-installInteractivePrint (Just ipFun) exprmode = do- ok <- trySuccess $ do- names <- GHC.parseName ipFun- let name = case names of- name':_ -> name'- [] -> panic "installInteractivePrint"- modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name- in he{hsc_IC = new_ic})- return Succeeded-- when (failed ok && exprmode) $ liftIO (exitWith (ExitFailure 1))---- | The main read-eval-print loop-runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()-runCommands gCmd = runCommands' handler Nothing gCmd >> return ()--runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler- -> Maybe (GHCi ()) -- ^ Source error handler- -> InputT GHCi (Maybe String)- -> InputT GHCi (Maybe Bool)- -- We want to return () here, but have to return (Maybe Bool)- -- because gmask is not polymorphic enough: we want to use- -- unmask at two different types.-runCommands' eh sourceErrorHandler gCmd = gmask $ \unmask -> do- b <- ghandle (\e -> case fromException e of- Just UserInterrupt -> return $ Just False- _ -> case fromException e of- Just ghce ->- do liftIO (print (ghce :: GhcException))- return Nothing- _other ->- liftIO (Exception.throwIO e))- (unmask $ runOneCommand eh gCmd)- case b of- Nothing -> return Nothing- Just success -> do- unless success $ maybe (return ()) lift sourceErrorHandler- unmask $ runCommands' eh sourceErrorHandler gCmd---- | Evaluate a single line of user input (either :<command> or Haskell code).--- A result of Nothing means there was no more input to process.--- Otherwise the result is Just b where b is True if the command succeeded;--- this is relevant only to ghc -e, which will exit with status 1--- if the command was unsuccessful. GHCi will continue in either case.-runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)- -> InputT GHCi (Maybe Bool)-runOneCommand eh gCmd = do- -- run a previously queued command if there is one, otherwise get new- -- input from user- mb_cmd0 <- noSpace (lift queryQueue)- mb_cmd1 <- maybe (noSpace gCmd) (return . Just) mb_cmd0- case mb_cmd1 of- Nothing -> return Nothing- Just c -> do- st <- getGHCiState- ghciHandle (\e -> lift $ eh e >>= return . Just) $- handleSourceError printErrorAndFail $- cmd_wrapper st $ doCommand c- -- source error's are handled by runStmt- -- is the handler necessary here?- where- printErrorAndFail err = do- GHC.printException err- return $ Just False -- Exit ghc -e, but not GHCi-- noSpace q = q >>= maybe (return Nothing)- (\c -> case removeSpaces c of- "" -> noSpace q- ":{" -> multiLineCmd q- _ -> return (Just c) )- multiLineCmd q = do- st <- getGHCiState- let p = prompt st- setGHCiState st{ prompt = prompt_cont st }- mb_cmd <- collectCommand q "" `GHC.gfinally`- modifyGHCiState (\st' -> st' { prompt = p })- return mb_cmd- -- we can't use removeSpaces for the sublines here, so- -- multiline commands are somewhat more brittle against- -- fileformat errors (such as \r in dos input on unix),- -- we get rid of any extra spaces for the ":}" test;- -- we also avoid silent failure if ":}" is not found;- -- and since there is no (?) valid occurrence of \r (as- -- opposed to its String representation, "\r") inside a- -- ghci command, we replace any such with ' ' (argh:-(- collectCommand q c = q >>=- maybe (liftIO (ioError collectError))- (\l->if removeSpaces l == ":}"- then return (Just c)- else collectCommand q (c ++ "\n" ++ map normSpace l))- where normSpace '\r' = ' '- normSpace x = x- -- SDM (2007-11-07): is userError the one to use here?- collectError = userError "unterminated multiline command :{ .. :}"-- -- | Handle a line of input- doCommand :: String -> InputT GHCi CommandResult-- -- command- doCommand stmt | stmt'@(':' : cmd) <- removeSpaces stmt = do- (stats, result) <- runWithStats (const Nothing) $ specialCommand cmd- let processResult True = Nothing- processResult False = Just True- return $ CommandComplete stmt' (processResult <$> result) stats-- -- haskell- doCommand stmt = do- -- if 'stmt' was entered via ':{' it will contain '\n's- let stmt_nl_cnt = length [ () | '\n' <- stmt ]- ml <- lift $ isOptionSet Multiline- if ml && stmt_nl_cnt == 0 -- don't trigger automatic multi-line mode for ':{'-multiline input- then do- fst_line_num <- line_number <$> getGHCiState- mb_stmt <- checkInputForLayout stmt gCmd- case mb_stmt of- Nothing -> return CommandIncomplete- Just ml_stmt -> do- -- temporarily compensate line-number for multi-line input- (stats, result) <- runAndPrintStats runAllocs $ lift $- runStmtWithLineNum fst_line_num ml_stmt GHC.RunToCompletion- return $- CommandComplete ml_stmt (Just . runSuccess <$> result) stats- else do -- single line input and :{ - multiline input- last_line_num <- line_number <$> getGHCiState- -- reconstruct first line num from last line num and stmt- let fst_line_num | stmt_nl_cnt > 0 = last_line_num - (stmt_nl_cnt2 + 1)- | otherwise = last_line_num -- single line input- stmt_nl_cnt2 = length [ () | '\n' <- stmt' ]- stmt' = dropLeadingWhiteLines stmt -- runStmt doesn't like leading empty lines- -- temporarily compensate line-number for multi-line input- (stats, result) <- runAndPrintStats runAllocs $ lift $- runStmtWithLineNum fst_line_num stmt' GHC.RunToCompletion- return $ CommandComplete stmt' (Just . runSuccess <$> result) stats-- -- runStmt wrapper for temporarily overridden line-number- runStmtWithLineNum :: Int -> String -> SingleStep- -> GHCi (Maybe GHC.ExecResult)- runStmtWithLineNum lnum stmt step = do- st0 <- getGHCiState- setGHCiState st0 { line_number = lnum }- result <- runStmt stmt step- -- restore original line_number- getGHCiState >>= \st -> setGHCiState st { line_number = line_number st0 }- return result-- -- note: this is subtly different from 'unlines . dropWhile (all isSpace) . lines'- dropLeadingWhiteLines s | (l0,'\n':r) <- break (=='\n') s- , all isSpace l0 = dropLeadingWhiteLines r- | otherwise = s----- #4316--- lex the input. If there is an unclosed layout context, request input-checkInputForLayout- :: GhciMonad m => String -> m (Maybe String) -> m (Maybe String)-checkInputForLayout stmt getStmt = do- dflags' <- getDynFlags- let dflags = xopt_set dflags' LangExt.AlternativeLayoutRule- st0 <- getGHCiState- let buf' = stringToStringBuffer stmt- loc = mkRealSrcLoc (fsLit (progname st0)) (line_number st0) 1- pstate = Lexer.mkPState dflags buf' loc- case Lexer.unP goToEnd pstate of- (Lexer.POk _ False) -> return $ Just stmt- _other -> do- st1 <- getGHCiState- let p = prompt st1- setGHCiState st1{ prompt = prompt_cont st1 }- mb_stmt <- ghciHandle (\ex -> case fromException ex of- Just UserInterrupt -> return Nothing- _ -> case fromException ex of- Just ghce ->- do liftIO (print (ghce :: GhcException))- return Nothing- _other -> liftIO (Exception.throwIO ex))- getStmt- modifyGHCiState (\st' -> st' { prompt = p })- -- the recursive call does not recycle parser state- -- as we use a new string buffer- case mb_stmt of- Nothing -> return Nothing- Just str -> if str == ""- then return $ Just stmt- else do- checkInputForLayout (stmt++"\n"++str) getStmt- where goToEnd = do- eof <- Lexer.nextIsEOF- if eof- then Lexer.activeContext- else Lexer.lexer False return >> goToEnd--enqueueCommands :: GhciMonad m => [String] -> m ()-enqueueCommands cmds = do- -- make sure we force any exceptions in the commands while we're- -- still inside the exception handler, otherwise bad things will- -- happen (see #10501)- cmds `deepseq` return ()- modifyGHCiState $ \st -> st{ cmdqueue = cmds ++ cmdqueue st }---- | Entry point to execute some haskell code from user.--- The return value True indicates success, as in `runOneCommand`.-runStmt :: GhciMonad m => String -> SingleStep -> m (Maybe GHC.ExecResult)-runStmt input step = do- dflags <- GHC.getInteractiveDynFlags- -- In GHCi, we disable `-fdefer-type-errors`, as well as `-fdefer-type-holes`- -- and `-fdefer-out-of-scope-variables` for **naked expressions**. The- -- declarations and statements are not affected.- -- See Note [Deferred type errors in GHCi] in typecheck/TcRnDriver.hs- st <- getGHCiState- let source = progname st- let line = line_number st-- if | GHC.isStmt dflags input -> do- hsc_env <- GHC.getSession- mb_stmt <- liftIO (runInteractiveHsc hsc_env (hscParseStmtWithLocation source line input))- case mb_stmt of- Nothing ->- -- empty statement / comment- return (Just exec_complete)- Just stmt ->- run_stmt stmt-- | GHC.isImport dflags input -> run_import-- -- Every import declaration should be handled by `run_import`. As GHCi- -- in general only accepts one command at a time, we simply throw an- -- exception when the input contains multiple commands of which at least- -- one is an import command (see #10663).- | GHC.hasImport dflags input -> throwGhcException- (CmdLineError "error: expecting a single import declaration")-- -- Otherwise assume a declaration (or a list of declarations)- -- Note: `GHC.isDecl` returns False on input like- -- `data Infix a b = a :@: b; infixl 4 :@:`- -- and should therefore not be used here.- | otherwise -> do- hsc_env <- GHC.getSession- decls <- liftIO (hscParseDeclsWithLocation hsc_env source line input)- run_decls decls- where- exec_complete = GHC.ExecComplete (Right []) 0-- run_import = do- addImportToContext input- return (Just exec_complete)-- run_stmt :: GhciMonad m => GhciLStmt GhcPs -> m (Maybe GHC.ExecResult)- run_stmt stmt = do- m_result <- GhciMonad.runStmt stmt input step- case m_result of- Nothing -> return Nothing- Just result -> Just <$> afterRunStmt (const True) result-- -- `x = y` (a declaration) should be treated as `let x = y` (a statement).- -- The reason is because GHCi wasn't designed to support `x = y`, but then- -- b98ff3 (#7253) added support for it, except it did not do a good job and- -- caused problems like:- --- -- - not adding the binders defined this way in the necessary places caused- -- `x = y` to not work in some cases (#12091).- -- - some GHCi command crashed after `x = y` (#15721)- -- - warning generation did not work for `x = y` (#11606)- -- - because `x = y` is a declaration (instead of a statement) differences- -- in generated code caused confusion (#16089)- --- -- Instead of dealing with all these problems individually here we fix this- -- mess by just treating `x = y` as `let x = y`.- run_decls :: GhciMonad m => [LHsDecl GhcPs] -> m (Maybe GHC.ExecResult)- -- Only turn `FunBind` and `VarBind` into statements, other bindings- -- (e.g. `PatBind`) need to stay as decls.- run_decls [L l (ValD _ bind@FunBind{})] = run_stmt (mk_stmt l bind)- run_decls [L l (ValD _ bind@VarBind{})] = run_stmt (mk_stmt l bind)- -- Note that any `x = y` declarations below will be run as declarations- -- instead of statements (e.g. `...; x = y; ...`)- run_decls decls = do- -- In the new IO library, read handles buffer data even if the Handle- -- is set to NoBuffering. This causes problems for GHCi where there- -- are really two stdin Handles. So we flush any bufferred data in- -- GHCi's stdin Handle here (only relevant if stdin is attached to- -- a file, otherwise the read buffer can't be flushed).- _ <- liftIO $ tryIO $ hFlushAll stdin- m_result <- GhciMonad.runDecls' decls- forM m_result $ \result ->- afterRunStmt (const True) (GHC.ExecComplete (Right result) 0)-- mk_stmt :: SrcSpan -> HsBind GhcPs -> GhciLStmt GhcPs- mk_stmt loc bind =- let l = L loc- in l (LetStmt noExt (l (HsValBinds noExt (ValBinds noExt (unitBag (l bind)) []))))---- | Clean up the GHCi environment after a statement has run-afterRunStmt :: GhciMonad m- => (SrcSpan -> Bool) -> GHC.ExecResult -> m GHC.ExecResult-afterRunStmt step_here run_result = do- resumes <- GHC.getResumeContext- case run_result of- GHC.ExecComplete{..} ->- case execResult of- Left ex -> liftIO $ Exception.throwIO ex- Right names -> do- show_types <- isOptionSet ShowType- when show_types $ printTypeOfNames names- GHC.ExecBreak names mb_info- | isNothing mb_info ||- step_here (GHC.resumeSpan $ head resumes) -> do- mb_id_loc <- toBreakIdAndLocation mb_info- let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc- if (null bCmd)- then printStoppedAtBreakInfo (head resumes) names- else enqueueCommands [bCmd]- -- run the command set with ":set stop <cmd>"- st <- getGHCiState- enqueueCommands [stop st]- return ()- | otherwise -> resume step_here GHC.SingleStep >>=- afterRunStmt step_here >> return ()-- flushInterpBuffers- withSignalHandlers $ do- b <- isOptionSet RevertCAFs- when b revertCAFs-- return run_result--runSuccess :: Maybe GHC.ExecResult -> Bool-runSuccess run_result- | Just (GHC.ExecComplete { execResult = Right _ }) <- run_result = True- | otherwise = False--runAllocs :: Maybe GHC.ExecResult -> Maybe Integer-runAllocs m = do- res <- m- case res of- GHC.ExecComplete{..} -> Just (fromIntegral execAllocation)- _ -> Nothing--toBreakIdAndLocation :: GhciMonad m- => Maybe GHC.BreakInfo -> m (Maybe (Int, BreakLocation))-toBreakIdAndLocation Nothing = return Nothing-toBreakIdAndLocation (Just inf) = do- let md = GHC.breakInfo_module inf- nm = GHC.breakInfo_number inf- st <- getGHCiState- return $ listToMaybe [ id_loc | id_loc@(_,loc) <- IntMap.assocs (breaks st),- breakModule loc == md,- breakTick loc == nm ]--printStoppedAtBreakInfo :: GHC.GhcMonad m => Resume -> [Name] -> m ()-printStoppedAtBreakInfo res names = do- printForUser $ pprStopped res- -- printTypeOfNames session names- let namesSorted = sortBy compareNames names- tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted- docs <- mapM pprTypeAndContents [i | AnId i <- tythings]- printForUserPartWay $ vcat docs--printTypeOfNames :: GHC.GhcMonad m => [Name] -> m ()-printTypeOfNames names- = mapM_ (printTypeOfName ) $ sortBy compareNames names--compareNames :: Name -> Name -> Ordering-n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2- where compareWith n = (getOccString n, getSrcSpan n)--printTypeOfName :: GHC.GhcMonad m => Name -> m ()-printTypeOfName n- = do maybe_tything <- GHC.lookupName n- case maybe_tything of- Nothing -> return ()- Just thing -> printTyThing thing---data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand---- | Entry point for execution a ':<command>' input from user-specialCommand :: String -> InputT GHCi Bool-specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)-specialCommand str = do- let (cmd,rest) = break isSpace str- maybe_cmd <- lookupCommand cmd- htxt <- short_help <$> getGHCiState- case maybe_cmd of- GotCommand cmd -> (cmdAction cmd) (dropWhile isSpace rest)- BadCommand ->- do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"- ++ htxt)- return False- NoLastCommand ->- do liftIO $ hPutStr stdout ("there is no last command to perform\n"- ++ htxt)- return False--shellEscape :: MonadIO m => String -> m Bool-shellEscape str = liftIO (system str >> return False)--lookupCommand :: GhciMonad m => String -> m (MaybeCommand)-lookupCommand "" = do- st <- getGHCiState- case last_command st of- Just c -> return $ GotCommand c- Nothing -> return NoLastCommand-lookupCommand str = do- mc <- lookupCommand' str- modifyGHCiState (\st -> st { last_command = mc })- return $ case mc of- Just c -> GotCommand c- Nothing -> BadCommand--lookupCommand' :: GhciMonad m => String -> m (Maybe Command)-lookupCommand' ":" = return Nothing-lookupCommand' str' = do- macros <- ghci_macros <$> getGHCiState- ghci_cmds <- ghci_commands <$> getGHCiState-- let ghci_cmds_nohide = filter (not . cmdHidden) ghci_cmds-- let (str, xcmds) = case str' of- ':' : rest -> (rest, []) -- "::" selects a builtin command- _ -> (str', macros) -- otherwise include macros in lookup-- lookupExact s = find $ (s ==) . cmdName- lookupPrefix s = find $ (s `isPrefixOf`) . cmdName-- -- hidden commands can only be matched exact- builtinPfxMatch = lookupPrefix str ghci_cmds_nohide-- -- first, look for exact match (while preferring macros); then, look- -- for first prefix match (preferring builtins), *unless* a macro- -- overrides the builtin; see #8305 for motivation- return $ lookupExact str xcmds <|>- lookupExact str ghci_cmds <|>- (builtinPfxMatch >>= \c -> lookupExact (cmdName c) xcmds) <|>- builtinPfxMatch <|>- lookupPrefix str xcmds--getCurrentBreakSpan :: GHC.GhcMonad m => m (Maybe SrcSpan)-getCurrentBreakSpan = do- resumes <- GHC.getResumeContext- case resumes of- [] -> return Nothing- (r:_) -> do- let ix = GHC.resumeHistoryIx r- if ix == 0- then return (Just (GHC.resumeSpan r))- else do- let hist = GHC.resumeHistory r !! (ix-1)- pan <- GHC.getHistorySpan hist- return (Just pan)--getCallStackAtCurrentBreakpoint :: GHC.GhcMonad m => m (Maybe [String])-getCallStackAtCurrentBreakpoint = do- resumes <- GHC.getResumeContext- case resumes of- [] -> return Nothing- (r:_) -> do- hsc_env <- GHC.getSession- Just <$> liftIO (costCentreStackInfo hsc_env (GHC.resumeCCS r))--getCurrentBreakModule :: GHC.GhcMonad m => m (Maybe Module)-getCurrentBreakModule = do- resumes <- GHC.getResumeContext- case resumes of- [] -> return Nothing- (r:_) -> do- let ix = GHC.resumeHistoryIx r- if ix == 0- then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)- else do- let hist = GHC.resumeHistory r !! (ix-1)- return $ Just $ GHC.getHistoryModule hist------------------------------------------------------------------------------------- Commands-----------------------------------------------------------------------------------noArgs :: MonadIO m => m () -> String -> m ()-noArgs m "" = m-noArgs _ _ = liftIO $ putStrLn "This command takes no arguments"--withSandboxOnly :: GHC.GhcMonad m => String -> m () -> m ()-withSandboxOnly cmd this = do- dflags <- getDynFlags- if not (gopt Opt_GhciSandbox dflags)- then printForUser (text cmd <+>- ptext (sLit "is not supported with -fno-ghci-sandbox"))- else this---------------------------------------------------------------------------------- :help--help :: GhciMonad m => String -> m ()-help _ = do- txt <- long_help `fmap` getGHCiState- liftIO $ putStr txt---------------------------------------------------------------------------------- :info--info :: GHC.GhcMonad m => Bool -> String -> m ()-info _ "" = throwGhcException (CmdLineError "syntax: ':i <thing-you-want-info-about>'")-info allInfo s = handleSourceError GHC.printException $ do- unqual <- GHC.getPrintUnqual- dflags <- getDynFlags- sdocs <- mapM (infoThing allInfo) (words s)- mapM_ (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs--infoThing :: GHC.GhcMonad m => Bool -> String -> m SDoc-infoThing allInfo str = do- names <- GHC.parseName str- mb_stuffs <- mapM (GHC.getInfo allInfo) names- let filtered = filterOutChildren (\(t,_f,_ci,_fi,_sd) -> t)- (catMaybes mb_stuffs)- return $ vcat (intersperse (text "") $ map pprInfo filtered)-- -- Filter out names whose parent is also there Good- -- example is '[]', which is both a type and data- -- constructor in the same type-filterOutChildren :: (a -> TyThing) -> [a] -> [a]-filterOutChildren get_thing xs- = filterOut has_parent xs- where- all_names = mkNameSet (map (getName . get_thing) xs)- has_parent x = case tyThingParent_maybe (get_thing x) of- Just p -> getName p `elemNameSet` all_names- Nothing -> False--pprInfo :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst], SDoc) -> SDoc-pprInfo (thing, fixity, cls_insts, fam_insts, docs)- = docs- $$ pprTyThingInContextLoc thing- $$ show_fixity- $$ vcat (map GHC.pprInstance cls_insts)- $$ vcat (map GHC.pprFamInst fam_insts)- where- show_fixity- | fixity == GHC.defaultFixity = empty- | otherwise = ppr fixity <+> pprInfixName (GHC.getName thing)---------------------------------------------------------------------------------- :main--runMain :: GhciMonad m => String -> m ()-runMain s = case toArgs s of- Left err -> liftIO (hPutStrLn stderr err)- Right args ->- do dflags <- getDynFlags- let main = fromMaybe "main" (mainFunIs dflags)- -- Wrap the main function in 'void' to discard its value instead- -- of printing it (#9086). See Haskell 2010 report Chapter 5.- doWithArgs args $ "Control.Monad.void (" ++ main ++ ")"---------------------------------------------------------------------------------- :run--runRun :: GhciMonad m => String -> m ()-runRun s = case toCmdArgs s of- Left err -> liftIO (hPutStrLn stderr err)- Right (cmd, args) -> doWithArgs args cmd--doWithArgs :: GhciMonad m => [String] -> String -> m ()-doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++- show args ++ " (" ++ cmd ++ ")"]---------------------------------------------------------------------------------- :cd--changeDirectory :: GhciMonad m => String -> m ()-changeDirectory "" = do- -- :cd on its own changes to the user's home directory- either_dir <- liftIO $ tryIO getHomeDirectory- case either_dir of- Left _e -> return ()- Right dir -> changeDirectory dir-changeDirectory dir = do- graph <- GHC.getModuleGraph- when (not (null $ GHC.mgModSummaries graph)) $- liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed."- -- delete targets and all eventually defined breakpoints (#1620)- clearAllTargets- setContextAfterLoad False []- GHC.workingDirectoryChanged- dir' <- expandPath dir- liftIO $ setCurrentDirectory dir'- dflags <- getDynFlags- -- With -fexternal-interpreter, we have to change the directory of the subprocess too.- -- (this gives consistent behaviour with and without -fexternal-interpreter)- when (gopt Opt_ExternalInterpreter dflags) $ do- hsc_env <- GHC.getSession- fhv <- compileGHCiExpr $- "System.Directory.setCurrentDirectory " ++ show dir'- liftIO $ evalIO hsc_env fhv--trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag-trySuccess act =- handleSourceError (\e -> do GHC.printException e- return Failed) $ do- act---------------------------------------------------------------------------------- :edit--editFile :: GhciMonad m => String -> m ()-editFile str =- do file <- if null str then chooseEditFile else expandPath str- st <- getGHCiState- errs <- liftIO $ readIORef $ lastErrorLocations st- let cmd = editor st- when (null cmd)- $ throwGhcException (CmdLineError "editor not set, use :set editor")- lineOpt <- liftIO $ do- let sameFile p1 p2 = liftA2 (==) (canonicalizePath p1) (canonicalizePath p2)- `catchIO` (\_ -> return False)-- curFileErrs <- filterM (\(f, _) -> unpackFS f `sameFile` file) errs- return $ case curFileErrs of- (_, line):_ -> " +" ++ show line- _ -> ""- let cmdArgs = ' ':(file ++ lineOpt)- code <- liftIO $ system (cmd ++ cmdArgs)-- when (code == ExitSuccess)- $ reloadModule ""---- The user didn't specify a file so we pick one for them.--- Our strategy is to pick the first module that failed to load,--- or otherwise the first target.------ XXX: Can we figure out what happened if the depndecy analysis fails--- (e.g., because the porgrammeer mistyped the name of a module)?--- XXX: Can we figure out the location of an error to pass to the editor?--- XXX: if we could figure out the list of errors that occured during the--- last load/reaload, then we could start the editor focused on the first--- of those.-chooseEditFile :: GHC.GhcMonad m => m String-chooseEditFile =- do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x-- graph <- GHC.getModuleGraph- failed_graph <-- GHC.mkModuleGraph <$> filterM hasFailed (GHC.mgModSummaries graph)- let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing- pick xs = case xs of- x : _ -> GHC.ml_hs_file (GHC.ms_location x)- _ -> Nothing-- case pick (order failed_graph) of- Just file -> return file- Nothing ->- do targets <- GHC.getTargets- case msum (map fromTarget targets) of- Just file -> return file- Nothing -> throwGhcException (CmdLineError "No files to edit.")-- where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f- fromTarget _ = Nothing -- when would we get a module target?----------------------------------------------------------------------------------- :def--defineMacro :: GhciMonad m => Bool{-overwrite-} -> String -> m ()-defineMacro _ (':':_) = liftIO $ putStrLn- "macro name cannot start with a colon"-defineMacro _ ('!':_) = liftIO $ putStrLn- "macro name cannot start with an exclamation mark"- -- little code duplication allows to grep error msg-defineMacro overwrite s = do- let (macro_name, definition) = break isSpace s- macros <- ghci_macros <$> getGHCiState- let defined = map cmdName macros- if null macro_name- then if null defined- then liftIO $ putStrLn "no macros defined"- else liftIO $ putStr ("the following macros are defined:\n" ++- unlines defined)- else do- isCommand <- isJust <$> lookupCommand' macro_name- let check_newname- | macro_name `elem` defined = throwGhcException (CmdLineError- ("macro '" ++ macro_name ++ "' is already defined. " ++ hint))- | isCommand = throwGhcException (CmdLineError- ("macro '" ++ macro_name ++ "' overwrites builtin command. " ++ hint))- | otherwise = return ()- hint = " Use ':def!' to overwrite."-- unless overwrite check_newname- -- compile the expression- handleSourceError GHC.printException $ do- step <- getGhciStepIO- expr <- GHC.parseExpr definition- -- > ghciStepIO . definition :: String -> IO String- let stringTy = nlHsTyVar stringTy_RDR- ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy- body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step)- `mkHsApp` (nlHsPar expr)- tySig = mkLHsSigWcType (stringTy `nlHsFunTy` ioM)- new_expr = L (getLoc expr) $ ExprWithTySig noExt body tySig- hv <- GHC.compileParsedExprRemote new_expr-- let newCmd = Command { cmdName = macro_name- , cmdAction = lift . runMacro hv- , cmdHidden = False- , cmdCompletionFunc = noCompletion- }-- -- later defined macros have precedence- modifyGHCiState $ \s ->- let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]- in s { ghci_macros = newCmd : filtered }--runMacro- :: GhciMonad m- => GHC.ForeignHValue -- String -> IO String- -> String- -> m Bool-runMacro fun s = do- hsc_env <- GHC.getSession- str <- liftIO $ evalStringToIOString hsc_env fun s- enqueueCommands (lines str)- return False----------------------------------------------------------------------------------- :undef--undefineMacro :: GhciMonad m => String -> m ()-undefineMacro str = mapM_ undef (words str)- where undef macro_name = do- cmds <- ghci_macros <$> getGHCiState- if (macro_name `notElem` map cmdName cmds)- then throwGhcException (CmdLineError- ("macro '" ++ macro_name ++ "' is not defined"))- else do- -- This is a tad racy but really, it's a shell- modifyGHCiState $ \s ->- s { ghci_macros = filter ((/= macro_name) . cmdName)- (ghci_macros s) }----------------------------------------------------------------------------------- :cmd--cmdCmd :: GhciMonad m => String -> m ()-cmdCmd str = handleSourceError GHC.printException $ do- step <- getGhciStepIO- expr <- GHC.parseExpr str- -- > ghciStepIO str :: IO String- let new_expr = step `mkHsApp` expr- hv <- GHC.compileParsedExprRemote new_expr-- hsc_env <- GHC.getSession- cmds <- liftIO $ evalString hsc_env hv- enqueueCommands (lines cmds)---- | Generate a typed ghciStepIO expression--- @ghciStepIO :: Ty String -> IO String@.-getGhciStepIO :: GHC.GhcMonad m => m (LHsExpr GhcPs)-getGhciStepIO = do- ghciTyConName <- GHC.getGHCiMonad- let stringTy = nlHsTyVar stringTy_RDR- ghciM = nlHsTyVar (getRdrName ghciTyConName) `nlHsAppTy` stringTy- ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy- body = nlHsVar (getRdrName ghciStepIoMName)- tySig = mkLHsSigWcType (ghciM `nlHsFunTy` ioM)- return $ noLoc $ ExprWithTySig noExt body tySig---------------------------------------------------------------------------------- :check--checkModule :: GhciMonad m => String -> m ()-checkModule m = do- let modl = GHC.mkModuleName m- ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do- r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl- dflags <- getDynFlags- liftIO $ putStrLn $ showSDoc dflags $- case GHC.moduleInfo r of- cm | Just scope <- GHC.modInfoTopLevelScope cm ->- let- (loc, glob) = ASSERT( all isExternalName scope )- partition ((== modl) . GHC.moduleName . GHC.nameModule) scope- in- (text "global names: " <+> ppr glob) $$- (text "local names: " <+> ppr loc)- _ -> empty- return True- afterLoad (successIf ok) False---------------------------------------------------------------------------------- :doc--docCmd :: GHC.GhcMonad m => String -> m ()-docCmd "" =- throwGhcException (CmdLineError "syntax: ':doc <thing-you-want-docs-for>'")-docCmd s = do- -- TODO: Maybe also get module headers for module names- names <- GHC.parseName s- e_docss <- mapM GHC.getDocs names- sdocs <- mapM (either handleGetDocsFailure (pure . pprDocs)) e_docss- let sdocs' = vcat (intersperse (text "") sdocs)- unqual <- GHC.getPrintUnqual- dflags <- getDynFlags- (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs'---- TODO: also print arg docs.-pprDocs :: (Maybe HsDocString, Map Int HsDocString) -> SDoc-pprDocs (mb_decl_docs, _arg_docs) =- maybe- (text "<has no documentation>")- (text . unpackHDS)- mb_decl_docs--handleGetDocsFailure :: GHC.GhcMonad m => GetDocsFailure -> m SDoc-handleGetDocsFailure no_docs = do- dflags <- getDynFlags- let msg = showPpr dflags no_docs- throwGhcException $ case no_docs of- NameHasNoModule {} -> Sorry msg- NoDocsInIface {} -> InstallationError msg- InteractiveName -> ProgramError msg---------------------------------------------------------------------------------- :instances--instancesCmd :: String -> InputT GHCi ()-instancesCmd "" =- throwGhcException (CmdLineError "syntax: ':instances <type-you-want-instances-for>'")-instancesCmd s = do- handleSourceError GHC.printException $ do- ty <- GHC.parseInstanceHead s- res <- GHC.getInstancesForType ty-- printForUser $ vcat $ map ppr res---------------------------------------------------------------------------------- :load, :add, :reload---- | Sets '-fdefer-type-errors' if 'defer' is true, executes 'load' and unsets--- '-fdefer-type-errors' again if it has not been set before.-wrapDeferTypeErrors :: GHC.GhcMonad m => m a -> m a-wrapDeferTypeErrors load =- gbracket- (do- -- Force originalFlags to avoid leaking the associated HscEnv- !originalFlags <- getDynFlags- void $ GHC.setProgramDynFlags $- setGeneralFlag' Opt_DeferTypeErrors originalFlags- return originalFlags)- (\originalFlags -> void $ GHC.setProgramDynFlags originalFlags)- (\_ -> load)--loadModule :: GhciMonad m => [(FilePath, Maybe Phase)] -> m SuccessFlag-loadModule fs = do- (_, result) <- runAndPrintStats (const Nothing) (loadModule' fs)- either (liftIO . Exception.throwIO) return result---- | @:load@ command-loadModule_ :: GhciMonad m => [FilePath] -> m ()-loadModule_ fs = void $ loadModule (zip fs (repeat Nothing))--loadModuleDefer :: GhciMonad m => [FilePath] -> m ()-loadModuleDefer = wrapDeferTypeErrors . loadModule_--loadModule' :: GhciMonad m => [(FilePath, Maybe Phase)] -> m SuccessFlag-loadModule' files = do- let (filenames, phases) = unzip files- exp_filenames <- mapM expandPath filenames- let files' = zip exp_filenames phases- targets <- mapM (uncurry GHC.guessTarget) files'-- -- NOTE: we used to do the dependency anal first, so that if it- -- fails we didn't throw away the current set of modules. This would- -- require some re-working of the GHC interface, so we'll leave it- -- as a ToDo for now.-- hsc_env <- GHC.getSession-- -- Grab references to the currently loaded modules so that we can- -- see if they leak.- let !dflags = hsc_dflags hsc_env- leak_indicators <- if gopt Opt_GhciLeakCheck dflags- then liftIO $ getLeakIndicators hsc_env- else return (panic "no leak indicators")-- -- unload first- _ <- GHC.abandonAll- clearAllTargets-- GHC.setTargets targets- success <- doLoadAndCollectInfo False LoadAllTargets- when (gopt Opt_GhciLeakCheck dflags) $- liftIO $ checkLeakIndicators dflags leak_indicators- return success---- | @:add@ command-addModule :: GhciMonad m => [FilePath] -> m ()-addModule files = do- revertCAFs -- always revert CAFs on load/add.- files' <- mapM expandPath files- targets <- mapM (\m -> GHC.guessTarget m Nothing) files'- targets' <- filterM checkTarget targets- -- remove old targets with the same id; e.g. for :add *M- mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets' ]- mapM_ GHC.addTarget targets'- _ <- doLoadAndCollectInfo False LoadAllTargets- return ()- where- checkTarget :: GHC.GhcMonad m => Target -> m Bool- checkTarget (Target (TargetModule m) _ _) = checkTargetModule m- checkTarget (Target (TargetFile f _) _ _) = liftIO $ checkTargetFile f-- checkTargetModule :: GHC.GhcMonad m => ModuleName -> m Bool- checkTargetModule m = do- hsc_env <- GHC.getSession- result <- liftIO $- Finder.findImportedModule hsc_env m (Just (fsLit "this"))- case result of- Found _ _ -> return True- _ -> (liftIO $ putStrLn $- "Module " ++ moduleNameString m ++ " not found") >> return False-- checkTargetFile :: String -> IO Bool- checkTargetFile f = do- exists <- (doesFileExist f) :: IO Bool- unless exists $ putStrLn $ "File " ++ f ++ " not found"- return exists---- | @:unadd@ command-unAddModule :: GhciMonad m => [FilePath] -> m ()-unAddModule files = do- files' <- mapM expandPath files- targets <- mapM (\m -> GHC.guessTarget m Nothing) files'- mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]- _ <- doLoadAndCollectInfo False LoadAllTargets- return ()---- | @:reload@ command-reloadModule :: GhciMonad m => String -> m ()-reloadModule m = void $ doLoadAndCollectInfo True loadTargets- where- loadTargets | null m = LoadAllTargets- | otherwise = LoadUpTo (GHC.mkModuleName m)--reloadModuleDefer :: GhciMonad m => String -> m ()-reloadModuleDefer = wrapDeferTypeErrors . reloadModule---- | Load/compile targets and (optionally) collect module-info------ This collects the necessary SrcSpan annotated type information (via--- 'collectInfo') required by the @:all-types@, @:loc-at@, @:type-at@,--- and @:uses@ commands.------ Meta-info collection is not enabled by default and needs to be--- enabled explicitly via @:set +c@. The reason is that collecting--- the type-information for all sub-spans can be quite expensive, and--- since those commands are designed to be used by editors and--- tooling, it's useless to collect this data for normal GHCi--- sessions.-doLoadAndCollectInfo :: GhciMonad m => Bool -> LoadHowMuch -> m SuccessFlag-doLoadAndCollectInfo retain_context howmuch = do- doCollectInfo <- isOptionSet CollectInfo-- doLoad retain_context howmuch >>= \case- Succeeded | doCollectInfo -> do- mod_summaries <- GHC.mgModSummaries <$> getModuleGraph- loaded <- filterM GHC.isLoaded $ map GHC.ms_mod_name mod_summaries- v <- mod_infos <$> getGHCiState- !newInfos <- collectInfo v loaded- modifyGHCiState (\st -> st { mod_infos = newInfos })- return Succeeded- flag -> return flag--doLoad :: GhciMonad m => Bool -> LoadHowMuch -> m SuccessFlag-doLoad retain_context howmuch = do- -- turn off breakpoints before we load: we can't turn them off later, because- -- the ModBreaks will have gone away.- discardActiveBreakPoints-- resetLastErrorLocations- -- Enable buffering stdout and stderr as we're compiling. Keeping these- -- handles unbuffered will just slow the compilation down, especially when- -- compiling in parallel.- gbracket (liftIO $ do hSetBuffering stdout LineBuffering- hSetBuffering stderr LineBuffering)- (\_ ->- liftIO $ do hSetBuffering stdout NoBuffering- hSetBuffering stderr NoBuffering) $ \_ -> do- ok <- trySuccess $ GHC.load howmuch- afterLoad ok retain_context- return ok---afterLoad- :: GhciMonad m- => SuccessFlag- -> Bool -- keep the remembered_ctx, as far as possible (:reload)- -> m ()-afterLoad ok retain_context = do- revertCAFs -- always revert CAFs on load.- discardTickArrays- loaded_mods <- getLoadedModules- modulesLoadedMsg ok loaded_mods- setContextAfterLoad retain_context loaded_mods--setContextAfterLoad :: GhciMonad m => Bool -> [GHC.ModSummary] -> m ()-setContextAfterLoad keep_ctxt [] = do- setContextKeepingPackageModules keep_ctxt []-setContextAfterLoad keep_ctxt ms = do- -- load a target if one is available, otherwise load the topmost module.- targets <- GHC.getTargets- case [ m | Just m <- map (findTarget ms) targets ] of- [] ->- let graph = GHC.mkModuleGraph ms- graph' = flattenSCCs (GHC.topSortModuleGraph True graph Nothing)- in load_this (last graph')- (m:_) ->- load_this m- where- findTarget mds t- = case filter (`matches` t) mds of- [] -> Nothing- (m:_) -> Just m-- summary `matches` Target (TargetModule m) _ _- = GHC.ms_mod_name summary == m- summary `matches` Target (TargetFile f _) _ _- | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'- _ `matches` _- = False-- load_this summary | m <- GHC.ms_mod summary = do- is_interp <- GHC.moduleIsInterpreted m- dflags <- getDynFlags- let star_ok = is_interp && not (safeLanguageOn dflags)- -- We import the module with a * iff- -- - it is interpreted, and- -- - -XSafe is off (it doesn't allow *-imports)- let new_ctx | star_ok = [mkIIModule (GHC.moduleName m)]- | otherwise = [mkIIDecl (GHC.moduleName m)]- setContextKeepingPackageModules keep_ctxt new_ctx----- | Keep any package modules (except Prelude) when changing the context.-setContextKeepingPackageModules- :: GhciMonad m- => Bool -- True <=> keep all of remembered_ctx- -- False <=> just keep package imports- -> [InteractiveImport] -- new context- -> m ()-setContextKeepingPackageModules keep_ctx trans_ctx = do-- st <- getGHCiState- let rem_ctx = remembered_ctx st- new_rem_ctx <- if keep_ctx then return rem_ctx- else keepPackageImports rem_ctx- setGHCiState st{ remembered_ctx = new_rem_ctx,- transient_ctx = filterSubsumed new_rem_ctx trans_ctx }- setGHCContextFromGHCiState---- | Filters a list of 'InteractiveImport', clearing out any home package--- imports so only imports from external packages are preserved. ('IIModule'--- counts as a home package import, because we are only able to bring a--- full top-level into scope when the source is available.)-keepPackageImports- :: GHC.GhcMonad m => [InteractiveImport] -> m [InteractiveImport]-keepPackageImports = filterM is_pkg_import- where- is_pkg_import :: GHC.GhcMonad m => InteractiveImport -> m Bool- is_pkg_import (IIModule _) = return False- is_pkg_import (IIDecl d)- = do e <- gtry $ GHC.findModule mod_name (fmap sl_fs $ ideclPkgQual d)- case e :: Either SomeException Module of- Left _ -> return False- Right m -> return (not (isHomeModule m))- where- mod_name = unLoc (ideclName d)---modulesLoadedMsg :: GHC.GhcMonad m => SuccessFlag -> [GHC.ModSummary] -> m ()-modulesLoadedMsg ok mods = do- dflags <- getDynFlags- unqual <- GHC.getPrintUnqual-- msg <- if gopt Opt_ShowLoadedModules dflags- then do- mod_names <- mapM mod_name mods- let mod_commas- | null mods = text "none."- | otherwise = hsep (punctuate comma mod_names) <> text "."- return $ status <> text ", modules loaded:" <+> mod_commas- else do- return $ status <> text ","- <+> speakNOf (length mods) (text "module") <+> "loaded."-- when (verbosity dflags > 0) $- liftIO $ putStrLn $ showSDocForUser dflags unqual msg- where- status = case ok of- Failed -> text "Failed"- Succeeded -> text "Ok"-- mod_name mod = do- is_interpreted <- GHC.moduleIsBootOrNotObjectLinkable mod- return $ if is_interpreted- then ppr (GHC.ms_mod mod)- else ppr (GHC.ms_mod mod)- <+> parens (text $ normalise $ msObjFilePath mod)- -- Fix #9887---- | Run an 'ExceptT' wrapped 'GhcMonad' while handling source errors--- and printing 'throwE' strings to 'stderr'-runExceptGhcMonad :: GHC.GhcMonad m => ExceptT SDoc m () -> m ()-runExceptGhcMonad act = handleSourceError GHC.printException $- either handleErr pure =<<- runExceptT act- where- handleErr sdoc = do- dflags <- getDynFlags- liftIO . hPutStrLn stderr . showSDocForUser dflags alwaysQualify $ sdoc---- | Inverse of 'runExceptT' for \"pure\" computations--- (c.f. 'except' for 'Except')-exceptT :: Applicative m => Either e a -> ExceptT e m a-exceptT = ExceptT . pure---------------------------------------------------------------------------------- | @:type@ command. See also Note [TcRnExprMode] in TcRnDriver.--typeOfExpr :: GHC.GhcMonad m => String -> m ()-typeOfExpr str = handleSourceError GHC.printException $ do- let (mode, expr_str) = case break isSpace str of- ("+d", rest) -> (GHC.TM_Default, dropWhile isSpace rest)- ("+v", rest) -> (GHC.TM_NoInst, dropWhile isSpace rest)- _ -> (GHC.TM_Inst, str)- ty <- GHC.exprType mode expr_str- printForUser $ sep [text expr_str, nest 2 (dcolon <+> pprTypeForUser ty)]---------------------------------------------------------------------------------- | @:type-at@ command--typeAtCmd :: GhciMonad m => String -> m ()-typeAtCmd str = runExceptGhcMonad $ do- (span',sample) <- exceptT $ parseSpanArg str- infos <- lift $ mod_infos <$> getGHCiState- (info, ty) <- findType infos span' sample- lift $ printForUserModInfo (modinfoInfo info)- (sep [text sample,nest 2 (dcolon <+> ppr ty)])---------------------------------------------------------------------------------- | @:uses@ command--usesCmd :: GhciMonad m => String -> m ()-usesCmd str = runExceptGhcMonad $ do- (span',sample) <- exceptT $ parseSpanArg str- infos <- lift $ mod_infos <$> getGHCiState- uses <- findNameUses infos span' sample- forM_ uses (liftIO . putStrLn . showSrcSpan)---------------------------------------------------------------------------------- | @:loc-at@ command--locAtCmd :: GhciMonad m => String -> m ()-locAtCmd str = runExceptGhcMonad $ do- (span',sample) <- exceptT $ parseSpanArg str- infos <- lift $ mod_infos <$> getGHCiState- (_,_,sp) <- findLoc infos span' sample- liftIO . putStrLn . showSrcSpan $ sp---------------------------------------------------------------------------------- | @:all-types@ command--allTypesCmd :: GhciMonad m => String -> m ()-allTypesCmd _ = runExceptGhcMonad $ do- infos <- lift $ mod_infos <$> getGHCiState- forM_ (M.elems infos) $ \mi ->- forM_ (modinfoSpans mi) (lift . printSpan)- where- printSpan span'- | Just ty <- spaninfoType span' = do- df <- getDynFlags- let tyInfo = unwords . words $- showSDocForUser df alwaysQualify (pprTypeForUser ty)- liftIO . putStrLn $- showRealSrcSpan (spaninfoSrcSpan span') ++ ": " ++ tyInfo- | otherwise = return ()---------------------------------------------------------------------------------- Helpers for locAtCmd/typeAtCmd/usesCmd---- | Parse a span: <module-name/filepath> <sl> <sc> <el> <ec> <string>-parseSpanArg :: String -> Either SDoc (RealSrcSpan,String)-parseSpanArg s = do- (fp,s0) <- readAsString (skipWs s)- s0' <- skipWs1 s0- (sl,s1) <- readAsInt s0'- s1' <- skipWs1 s1- (sc,s2) <- readAsInt s1'- s2' <- skipWs1 s2- (el,s3) <- readAsInt s2'- s3' <- skipWs1 s3- (ec,s4) <- readAsInt s3'-- trailer <- case s4 of- [] -> Right ""- _ -> skipWs1 s4-- let fs = mkFastString fp- span' = mkRealSrcSpan (mkRealSrcLoc fs sl sc)- -- End column of RealSrcSpan is the column- -- after the end of the span.- (mkRealSrcLoc fs el (ec + 1))-- return (span',trailer)- where- readAsInt :: String -> Either SDoc (Int,String)- readAsInt "" = Left "Premature end of string while expecting Int"- readAsInt s0 = case reads s0 of- [s_rest] -> Right s_rest- _ -> Left ("Couldn't read" <+> text (show s0) <+> "as Int")-- readAsString :: String -> Either SDoc (String,String)- readAsString s0- | '"':_ <- s0 = case reads s0 of- [s_rest] -> Right s_rest- _ -> leftRes- | s_rest@(_:_,_) <- breakWs s0 = Right s_rest- | otherwise = leftRes- where- leftRes = Left ("Couldn't read" <+> text (show s0) <+> "as String")-- skipWs1 :: String -> Either SDoc String- skipWs1 (c:cs) | isWs c = Right (skipWs cs)- skipWs1 s0 = Left ("Expected whitespace in" <+> text (show s0))-- isWs = (`elem` [' ','\t'])- skipWs = dropWhile isWs- breakWs = break isWs----- | Pretty-print \"real\" 'SrcSpan's as--- @<filename>:(<line>,<col>)-(<line-end>,<col-end>)@--- while simply unpacking 'UnhelpfulSpan's-showSrcSpan :: SrcSpan -> String-showSrcSpan (UnhelpfulSpan s) = unpackFS s-showSrcSpan (RealSrcSpan spn) = showRealSrcSpan spn---- | Variant of 'showSrcSpan' for 'RealSrcSpan's-showRealSrcSpan :: RealSrcSpan -> String-showRealSrcSpan spn = concat [ fp, ":(", show sl, ",", show sc- , ")-(", show el, ",", show ec, ")"- ]- where- fp = unpackFS (srcSpanFile spn)- sl = srcSpanStartLine spn- sc = srcSpanStartCol spn- el = srcSpanEndLine spn- -- The end column is the column after the end of the span see the- -- RealSrcSpan module- ec = let ec' = srcSpanEndCol spn in if ec' == 0 then 0 else ec' - 1---------------------------------------------------------------------------------- | @:kind@ command--kindOfType :: GHC.GhcMonad m => Bool -> String -> m ()-kindOfType norm str = handleSourceError GHC.printException $ do- (ty, kind) <- GHC.typeKind norm str- printForUser $ vcat [ text str <+> dcolon <+> pprTypeForUser kind- , ppWhen norm $ equals <+> pprTypeForUser ty ]---------------------------------------------------------------------------------- :quit--quit :: Monad m => String -> m Bool-quit _ = return True----------------------------------------------------------------------------------- :script---- running a script file #1363--scriptCmd :: String -> InputT GHCi ()-scriptCmd ws = do- case words ws of- [s] -> runScript s- _ -> throwGhcException (CmdLineError "syntax: :script <filename>")--runScript :: String -- ^ filename- -> InputT GHCi ()-runScript filename = do- filename' <- expandPath filename- either_script <- liftIO $ tryIO (openFile filename' ReadMode)- case either_script of- Left _err -> throwGhcException (CmdLineError $ "IO error: \""++filename++"\" "- ++(ioeGetErrorString _err))- Right script -> do- st <- getGHCiState- let prog = progname st- line = line_number st- setGHCiState st{progname=filename',line_number=0}- scriptLoop script- liftIO $ hClose script- new_st <- getGHCiState- setGHCiState new_st{progname=prog,line_number=line}- where scriptLoop script = do- res <- runOneCommand handler $ fileLoop script- case res of- Nothing -> return ()- Just s -> if s- then scriptLoop script- else return ()---------------------------------------------------------------------------------- :issafe---- Displaying Safe Haskell properties of a module--isSafeCmd :: GHC.GhcMonad m => String -> m ()-isSafeCmd m =- case words m of- [s] | looksLikeModuleName s -> do- md <- lookupModule s- isSafeModule md- [] -> do md <- guessCurrentModule "issafe"- isSafeModule md- _ -> throwGhcException (CmdLineError "syntax: :issafe <module>")--isSafeModule :: GHC.GhcMonad m => Module -> m ()-isSafeModule m = do- mb_mod_info <- GHC.getModuleInfo m- when (isNothing mb_mod_info)- (throwGhcException $ CmdLineError $ "unknown module: " ++ mname)-- dflags <- getDynFlags- let iface = GHC.modInfoIface $ fromJust mb_mod_info- when (isNothing iface)- (throwGhcException $ CmdLineError $ "can't load interface file for module: " ++- (GHC.moduleNameString $ GHC.moduleName m))-- (msafe, pkgs) <- GHC.moduleTrustReqs m- let trust = showPpr dflags $ getSafeMode $ GHC.mi_trust $ fromJust iface- pkg = if packageTrusted dflags m then "trusted" else "untrusted"- (good, bad) = tallyPkgs dflags pkgs-- -- print info to user...- liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")"- liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off")- when (not $ S.null good)- (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " ++- (intercalate ", " $ map (showPpr dflags) (S.toList good)))- case msafe && S.null bad of- True -> liftIO $ putStrLn $ mname ++ " is trusted!"- False -> do- when (not $ null bad)- (liftIO $ putStrLn $ "Trusted package dependencies (untrusted): "- ++ (intercalate ", " $ map (showPpr dflags) (S.toList bad)))- liftIO $ putStrLn $ mname ++ " is NOT trusted!"-- where- mname = GHC.moduleNameString $ GHC.moduleName m-- packageTrusted dflags md- | thisPackage dflags == moduleUnitId md = True- | otherwise = trusted $ getPackageDetails dflags (moduleUnitId md)-- tallyPkgs dflags deps | not (packageTrustOn dflags) = (S.empty, S.empty)- | otherwise = S.partition part deps- where part pkg = trusted $ getInstalledPackageDetails dflags pkg---------------------------------------------------------------------------------- :browse---- Browsing a module's contents--browseCmd :: GHC.GhcMonad m => Bool -> String -> m ()-browseCmd bang m =- case words m of- ['*':s] | looksLikeModuleName s -> do- md <- wantInterpretedModule s- browseModule bang md False- [s] | looksLikeModuleName s -> do- md <- lookupModule s- browseModule bang md True- [] -> do md <- guessCurrentModule ("browse" ++ if bang then "!" else "")- browseModule bang md True- _ -> throwGhcException (CmdLineError "syntax: :browse <module>")--guessCurrentModule :: GHC.GhcMonad m => String -> m Module--- Guess which module the user wants to browse. Pick--- modules that are interpreted first. The most--- recently-added module occurs last, it seems.-guessCurrentModule cmd- = do imports <- GHC.getContext- when (null imports) $ throwGhcException $- CmdLineError (':' : cmd ++ ": no current module")- case (head imports) of- IIModule m -> GHC.findModule m Nothing- IIDecl d -> GHC.findModule (unLoc (ideclName d))- (fmap sl_fs $ ideclPkgQual d)---- without bang, show items in context of their parents and omit children--- with bang, show class methods and data constructors separately, and--- indicate import modules, to aid qualifying unqualified names--- with sorted, sort items alphabetically-browseModule :: GHC.GhcMonad m => Bool -> Module -> Bool -> m ()-browseModule bang modl exports_only = do- -- :browse reports qualifiers wrt current context- unqual <- GHC.getPrintUnqual-- mb_mod_info <- GHC.getModuleInfo modl- case mb_mod_info of- Nothing -> throwGhcException (CmdLineError ("unknown module: " ++- GHC.moduleNameString (GHC.moduleName modl)))- Just mod_info -> do- dflags <- getDynFlags- let names- | exports_only = GHC.modInfoExports mod_info- | otherwise = GHC.modInfoTopLevelScope mod_info- `orElse` []-- -- sort alphabetically name, but putting locally-defined- -- identifiers first. We would like to improve this; see #1799.- sorted_names = loc_sort local ++ occ_sort external- where- (local,external) = ASSERT( all isExternalName names )- partition ((==modl) . nameModule) names- occ_sort = sortBy (compare `on` nameOccName)- -- try to sort by src location. If the first name in our list- -- has a good source location, then they all should.- loc_sort ns- | n:_ <- ns, isGoodSrcSpan (nameSrcSpan n)- = sortBy (compare `on` nameSrcSpan) ns- | otherwise- = occ_sort ns-- mb_things <- mapM GHC.lookupName sorted_names- let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)-- rdr_env <- GHC.getGRE-- let things | bang = catMaybes mb_things- | otherwise = filtered_things- pretty | bang = pprTyThing showToHeader- | otherwise = pprTyThingInContext showToHeader-- labels [] = text "-- not currently imported"- labels l = text $ intercalate "\n" $ map qualifier l-- qualifier :: Maybe [ModuleName] -> String- qualifier = maybe "-- defined locally"- (("-- imported via "++) . intercalate ", "- . map GHC.moduleNameString)- importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env-- modNames :: [[Maybe [ModuleName]]]- modNames = map (importInfo . GHC.getName) things-- -- annotate groups of imports with their import modules- -- the default ordering is somewhat arbitrary, so we group- -- by header and sort groups; the names themselves should- -- really come in order of source appearance.. (trac #1799)- annotate mts = concatMap (\(m,ts)->labels m:ts)- $ sortBy cmpQualifiers $ grp mts- where cmpQualifiers =- compare `on` (map (fmap (map moduleNameFS)) . fst)- grp [] = []- grp mts@((m,_):_) = (m,map snd g) : grp ng- where (g,ng) = partition ((==m).fst) mts-- let prettyThings, prettyThings' :: [SDoc]- prettyThings = map pretty things- prettyThings' | bang = annotate $ zip modNames prettyThings- | otherwise = prettyThings- liftIO $ putStrLn $ showSDocForUser dflags unqual (vcat prettyThings')- -- ToDo: modInfoInstances currently throws an exception for- -- package modules. When it works, we can do this:- -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))----------------------------------------------------------------------------------- :module---- Setting the module context. For details on context handling see--- "remembered_ctx" and "transient_ctx" in GhciMonad.--moduleCmd :: GhciMonad m => String -> m ()-moduleCmd str- | all sensible strs = cmd- | otherwise = throwGhcException (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")- where- (cmd, strs) =- case str of- '+':stuff -> rest addModulesToContext stuff- '-':stuff -> rest remModulesFromContext stuff- stuff -> rest setContext stuff-- rest op stuff = (op as bs, stuffs)- where (as,bs) = partitionWith starred stuffs- stuffs = words stuff-- sensible ('*':m) = looksLikeModuleName m- sensible m = looksLikeModuleName m-- starred ('*':m) = Left (GHC.mkModuleName m)- starred m = Right (GHC.mkModuleName m)----- -------------------------------------------------------------------------------- Four ways to manipulate the context:--- (a) :module +<stuff>: addModulesToContext--- (b) :module -<stuff>: remModulesFromContext--- (c) :module <stuff>: setContext--- (d) import <module>...: addImportToContext--addModulesToContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()-addModulesToContext starred unstarred = restoreContextOnFailure $ do- addModulesToContext_ starred unstarred--addModulesToContext_ :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()-addModulesToContext_ starred unstarred = do- mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred)- setGHCContextFromGHCiState--remModulesFromContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()-remModulesFromContext starred unstarred = do- -- we do *not* call restoreContextOnFailure here. If the user- -- is trying to fix up a context that contains errors by removing- -- modules, we don't want GHC to silently put them back in again.- mapM_ rm (starred ++ unstarred)- setGHCContextFromGHCiState- where- rm :: GhciMonad m => ModuleName -> m ()- rm str = do- m <- moduleName <$> lookupModuleName str- let filt = filter ((/=) m . iiModuleName)- modifyGHCiState $ \st ->- st { remembered_ctx = filt (remembered_ctx st)- , transient_ctx = filt (transient_ctx st) }--setContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()-setContext starred unstarred = restoreContextOnFailure $ do- modifyGHCiState $ \st -> st { remembered_ctx = [], transient_ctx = [] }- -- delete the transient context- addModulesToContext_ starred unstarred--addImportToContext :: GhciMonad m => String -> m ()-addImportToContext str = restoreContextOnFailure $ do- idecl <- GHC.parseImportDecl str- addII (IIDecl idecl) -- #5836- setGHCContextFromGHCiState---- Util used by addImportToContext and addModulesToContext-addII :: GhciMonad m => InteractiveImport -> m ()-addII iidecl = do- checkAdd iidecl- modifyGHCiState $ \st ->- st { remembered_ctx = addNotSubsumed iidecl (remembered_ctx st)- , transient_ctx = filter (not . (iidecl `iiSubsumes`))- (transient_ctx st)- }---- Sometimes we can't tell whether an import is valid or not until--- we finally call 'GHC.setContext'. e.g.------ import System.IO (foo)------ will fail because System.IO does not export foo. In this case we--- don't want to store the import in the context permanently, so we--- catch the failure from 'setGHCContextFromGHCiState' and set the--- context back to what it was.------ See #6007----restoreContextOnFailure :: GhciMonad m => m a -> m a-restoreContextOnFailure do_this = do- st <- getGHCiState- let rc = remembered_ctx st; tc = transient_ctx st- do_this `gonException` (modifyGHCiState $ \st' ->- st' { remembered_ctx = rc, transient_ctx = tc })---- -------------------------------------------------------------------------------- Validate a module that we want to add to the context--checkAdd :: GHC.GhcMonad m => InteractiveImport -> m ()-checkAdd ii = do- dflags <- getDynFlags- let safe = safeLanguageOn dflags- case ii of- IIModule modname- | safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell"- | otherwise -> wantInterpretedModuleName modname >> return ()-- IIDecl d -> do- let modname = unLoc (ideclName d)- pkgqual = ideclPkgQual d- m <- GHC.lookupModule modname (fmap sl_fs pkgqual)- when safe $ do- t <- GHC.isModuleTrusted m- when (not t) $ throwGhcException $ ProgramError $ ""---- -------------------------------------------------------------------------------- Update the GHC API's view of the context---- | Sets the GHC context from the GHCi state. The GHC context is--- always set this way, we never modify it incrementally.------ We ignore any imports for which the ModuleName does not currently--- exist. This is so that the remembered_ctx can contain imports for--- modules that are not currently loaded, perhaps because we just did--- a :reload and encountered errors.------ Prelude is added if not already present in the list. Therefore to--- override the implicit Prelude import you can say 'import Prelude ()'--- at the prompt, just as in Haskell source.----setGHCContextFromGHCiState :: GhciMonad m => m ()-setGHCContextFromGHCiState = do- st <- getGHCiState- -- re-use checkAdd to check whether the module is valid. If the- -- module does not exist, we do *not* want to print an error- -- here, we just want to silently keep the module in the context- -- until such time as the module reappears again. So we ignore- -- the actual exception thrown by checkAdd, using tryBool to- -- turn it into a Bool.- iidecls <- filterM (tryBool.checkAdd) (transient_ctx st ++ remembered_ctx st)-- prel_iidecls <- getImplicitPreludeImports iidecls- valid_prel_iidecls <- filterM (tryBool . checkAdd) prel_iidecls-- extra_imports <- filterM (tryBool . checkAdd) (map IIDecl (extra_imports st))-- GHC.setContext $ iidecls ++ extra_imports ++ valid_prel_iidecls---getImplicitPreludeImports :: GhciMonad m- => [InteractiveImport] -> m [InteractiveImport]-getImplicitPreludeImports iidecls = do- dflags <- GHC.getInteractiveDynFlags- -- allow :seti to override -XNoImplicitPrelude- st <- getGHCiState-- -- We add the prelude imports if there are no *-imports, and we also- -- allow each prelude import to be subsumed by another explicit import- -- of the same module. This means that you can override the prelude import- -- with "import Prelude hiding (map)", for example.- let prel_iidecls =- if xopt LangExt.ImplicitPrelude dflags && not (any isIIModule iidecls)- then [ IIDecl imp- | imp <- prelude_imports st- , not (any (sameImpModule imp) iidecls) ]- else []-- return prel_iidecls---- -------------------------------------------------------------------------------- Utils on InteractiveImport--mkIIModule :: ModuleName -> InteractiveImport-mkIIModule = IIModule--mkIIDecl :: ModuleName -> InteractiveImport-mkIIDecl = IIDecl . simpleImportDecl--iiModules :: [InteractiveImport] -> [ModuleName]-iiModules is = [m | IIModule m <- is]--isIIModule :: InteractiveImport -> Bool-isIIModule (IIModule _) = True-isIIModule _ = False--iiModuleName :: InteractiveImport -> ModuleName-iiModuleName (IIModule m) = m-iiModuleName (IIDecl d) = unLoc (ideclName d)--preludeModuleName :: ModuleName-preludeModuleName = GHC.mkModuleName "Prelude"--sameImpModule :: ImportDecl GhcPs -> InteractiveImport -> Bool-sameImpModule _ (IIModule _) = False -- we only care about imports here-sameImpModule imp (IIDecl d) = unLoc (ideclName d) == unLoc (ideclName imp)--addNotSubsumed :: InteractiveImport- -> [InteractiveImport] -> [InteractiveImport]-addNotSubsumed i is- | any (`iiSubsumes` i) is = is- | otherwise = i : filter (not . (i `iiSubsumes`)) is---- | @filterSubsumed is js@ returns the elements of @js@ not subsumed--- by any of @is@.-filterSubsumed :: [InteractiveImport] -> [InteractiveImport]- -> [InteractiveImport]-filterSubsumed is js = filter (\j -> not (any (`iiSubsumes` j) is)) js---- | Returns True if the left import subsumes the right one. Doesn't--- need to be 100% accurate, conservatively returning False is fine.--- (EXCEPT: (IIModule m) *must* subsume itself, otherwise a panic in--- plusProv will ensue (#5904))------ Note that an IIModule does not necessarily subsume an IIDecl,--- because e.g. a module might export a name that is only available--- qualified within the module itself.------ Note that 'import M' does not necessarily subsume 'import M(foo)',--- because M might not export foo and we want an error to be produced--- in that case.----iiSubsumes :: InteractiveImport -> InteractiveImport -> Bool-iiSubsumes (IIModule m1) (IIModule m2) = m1==m2-iiSubsumes (IIDecl d1) (IIDecl d2) -- A bit crude- = unLoc (ideclName d1) == unLoc (ideclName d2)- && ideclAs d1 == ideclAs d2- && (not (isImportDeclQualified (ideclQualified d1)) || isImportDeclQualified (ideclQualified d2))- && (ideclHiding d1 `hidingSubsumes` ideclHiding d2)- where- _ `hidingSubsumes` Just (False,L _ []) = True- Just (False, L _ xs) `hidingSubsumes` Just (False,L _ ys)- = all (`elem` xs) ys- h1 `hidingSubsumes` h2 = h1 == h2-iiSubsumes _ _ = False---------------------------------------------------------------------------------- :set---- set options in the interpreter. Syntax is exactly the same as the--- ghc command line, except that certain options aren't available (-C,--- -E etc.)------ This is pretty fragile: most options won't work as expected. ToDo:--- figure out which ones & disallow them.--setCmd :: GhciMonad m => String -> m ()-setCmd "" = showOptions False-setCmd "-a" = showOptions True-setCmd str- = case getCmd str of- Right ("args", rest) ->- case toArgs rest of- Left err -> liftIO (hPutStrLn stderr err)- Right args -> setArgs args- Right ("prog", rest) ->- case toArgs rest of- Right [prog] -> setProg prog- _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>")-- Right ("prompt", rest) ->- setPromptString setPrompt (dropWhile isSpace rest)- "syntax: set prompt <string>"- Right ("prompt-function", rest) ->- setPromptFunc setPrompt $ dropWhile isSpace rest- Right ("prompt-cont", rest) ->- setPromptString setPromptCont (dropWhile isSpace rest)- "syntax: :set prompt-cont <string>"- Right ("prompt-cont-function", rest) ->- setPromptFunc setPromptCont $ dropWhile isSpace rest-- Right ("editor", rest) -> setEditor $ dropWhile isSpace rest- Right ("stop", rest) -> setStop $ dropWhile isSpace rest- Right ("local-config", rest) ->- setLocalConfigBehaviour $ dropWhile isSpace rest- _ -> case toArgs str of- Left err -> liftIO (hPutStrLn stderr err)- Right wds -> setOptions wds--setiCmd :: GhciMonad m => String -> m ()-setiCmd "" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags False-setiCmd "-a" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags True-setiCmd str =- case toArgs str of- Left err -> liftIO (hPutStrLn stderr err)- Right wds -> newDynFlags True wds--showOptions :: GhciMonad m => Bool -> m ()-showOptions show_all- = do st <- getGHCiState- dflags <- getDynFlags- let opts = options st- liftIO $ putStrLn (showSDoc dflags (- text "options currently set: " <>- if null opts- then text "none."- else hsep (map (\o -> char '+' <> text (optToStr o)) opts)- ))- getDynFlags >>= liftIO . showDynFlags show_all---showDynFlags :: Bool -> DynFlags -> IO ()-showDynFlags show_all dflags = do- showLanguages' show_all dflags- putStrLn $ showSDoc dflags $- text "GHCi-specific dynamic flag settings:" $$- nest 2 (vcat (map (setting "-f" "-fno-" gopt) ghciFlags))- putStrLn $ showSDoc dflags $- text "other dynamic, non-language, flag settings:" $$- nest 2 (vcat (map (setting "-f" "-fno-" gopt) others))- putStrLn $ showSDoc dflags $- text "warning settings:" $$- nest 2 (vcat (map (setting "-W" "-Wno-" wopt) DynFlags.wWarningFlags))- where- setting prefix noPrefix test flag- | quiet = empty- | is_on = text prefix <> text name- | otherwise = text noPrefix <> text name- where name = flagSpecName flag- f = flagSpecFlag flag- is_on = test f dflags- quiet = not show_all && test f default_dflags == is_on-- llvmConfig = (llvmTargets dflags, llvmPasses dflags)-- default_dflags = defaultDynFlags (settings dflags) llvmConfig-- (ghciFlags,others) = partition (\f -> flagSpecFlag f `elem` flgs)- DynFlags.fFlags- flgs = [ Opt_PrintExplicitForalls- , Opt_PrintExplicitKinds- , Opt_PrintUnicodeSyntax- , Opt_PrintBindResult- , Opt_BreakOnException- , Opt_BreakOnError- , Opt_PrintEvldWithShow- ]--setArgs, setOptions :: GhciMonad m => [String] -> m ()-setProg, setEditor, setStop :: GhciMonad m => String -> m ()-setLocalConfigBehaviour :: GhciMonad m => String -> m ()--setArgs args = do- st <- getGHCiState- wrapper <- mkEvalWrapper (progname st) args- setGHCiState st { GhciMonad.args = args, evalWrapper = wrapper }--setProg prog = do- st <- getGHCiState- wrapper <- mkEvalWrapper prog (GhciMonad.args st)- setGHCiState st { progname = prog, evalWrapper = wrapper }--setEditor cmd = modifyGHCiState (\st -> st { editor = cmd })--setLocalConfigBehaviour s- | s == "source" =- modifyGHCiState (\st -> st { localConfig = SourceLocalConfig })- | s == "ignore" =- modifyGHCiState (\st -> st { localConfig = IgnoreLocalConfig })- | otherwise = throwGhcException- (CmdLineError "syntax: :set local-config { source | ignore }")--setStop str@(c:_) | isDigit c- = do let (nm_str,rest) = break (not.isDigit) str- nm = read nm_str- st <- getGHCiState- let old_breaks = breaks st- case IntMap.lookup nm old_breaks of- Nothing -> printForUser (text "Breakpoint" <+> ppr nm <+>- text "does not exist")- Just loc -> do- let new_breaks = IntMap.insert nm- loc { onBreakCmd = dropWhile isSpace rest }- old_breaks- setGHCiState st{ breaks = new_breaks }-setStop cmd = modifyGHCiState (\st -> st { stop = cmd })--setPrompt :: GhciMonad m => PromptFunction -> m ()-setPrompt v = modifyGHCiState (\st -> st {prompt = v})--setPromptCont :: GhciMonad m => PromptFunction -> m ()-setPromptCont v = modifyGHCiState (\st -> st {prompt_cont = v})--setPromptFunc :: GHC.GhcMonad m => (PromptFunction -> m ()) -> String -> m ()-setPromptFunc fSetPrompt s = do- -- We explicitly annotate the type of the expression to ensure- -- that unsafeCoerce# is passed the exact type necessary rather- -- than a more general one- let exprStr = "(" ++ s ++ ") :: [String] -> Int -> IO String"- (HValue funValue) <- GHC.compileExpr exprStr- fSetPrompt (convertToPromptFunction $ unsafeCoerce funValue)- where- convertToPromptFunction :: ([String] -> Int -> IO String)- -> PromptFunction- convertToPromptFunction func = (\mods line -> liftIO $- liftM text (func mods line))--setPromptString :: MonadIO m- => (PromptFunction -> m ()) -> String -> String -> m ()-setPromptString fSetPrompt value err = do- if null value- then liftIO $ hPutStrLn stderr $ err- else case value of- ('\"':_) ->- case reads value of- [(value', xs)] | all isSpace xs ->- setParsedPromptString fSetPrompt value'- _ -> liftIO $ hPutStrLn stderr- "Can't parse prompt string. Use Haskell syntax."- _ ->- setParsedPromptString fSetPrompt value--setParsedPromptString :: MonadIO m- => (PromptFunction -> m ()) -> String -> m ()-setParsedPromptString fSetPrompt s = do- case (checkPromptStringForErrors s) of- Just err ->- liftIO $ hPutStrLn stderr err- Nothing ->- fSetPrompt $ generatePromptFunctionFromString s--setOptions wds =- do -- first, deal with the GHCi opts (+s, +t, etc.)- let (plus_opts, minus_opts) = partitionWith isPlus wds- mapM_ setOpt plus_opts- -- then, dynamic flags- when (not (null minus_opts)) $ newDynFlags False minus_opts--newDynFlags :: GhciMonad m => Bool -> [String] -> m ()-newDynFlags interactive_only minus_opts = do- let lopts = map noLoc minus_opts-- idflags0 <- GHC.getInteractiveDynFlags- (idflags1, leftovers, warns) <- GHC.parseDynamicFlags idflags0 lopts-- liftIO $ handleFlagWarnings idflags1 warns- when (not $ null leftovers)- (throwGhcException . CmdLineError- $ "Some flags have not been recognized: "- ++ (concat . intersperse ", " $ map unLoc leftovers))-- when (interactive_only && packageFlagsChanged idflags1 idflags0) $ do- liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"- -- Load any new plugins- hsc_env0 <- GHC.getSession- idflags2 <- liftIO (initializePlugins hsc_env0 idflags1)- GHC.setInteractiveDynFlags idflags2- installInteractivePrint (interactivePrint idflags1) False-- dflags0 <- getDynFlags-- when (not interactive_only) $ do- (dflags1, _, _) <- liftIO $ GHC.parseDynamicFlags dflags0 lopts- new_pkgs <- GHC.setProgramDynFlags dflags1-- -- if the package flags changed, reset the context and link- -- the new packages.- hsc_env <- GHC.getSession- let dflags2 = hsc_dflags hsc_env- when (packageFlagsChanged dflags2 dflags0) $ do- when (verbosity dflags2 > 0) $- liftIO . putStrLn $- "package flags have changed, resetting and loading new packages..."- -- delete targets and all eventually defined breakpoints. (#1620)- clearAllTargets- liftIO $ linkPackages hsc_env new_pkgs- -- package flags changed, we can't re-use any of the old context- setContextAfterLoad False []- -- and copy the package state to the interactive DynFlags- idflags <- GHC.getInteractiveDynFlags- GHC.setInteractiveDynFlags- idflags{ pkgState = pkgState dflags2- , pkgDatabase = pkgDatabase dflags2- , packageFlags = packageFlags dflags2 }-- let ld0length = length $ ldInputs dflags0- fmrk0length = length $ cmdlineFrameworks dflags0-- newLdInputs = drop ld0length (ldInputs dflags2)- newCLFrameworks = drop fmrk0length (cmdlineFrameworks dflags2)-- hsc_env' = hsc_env { hsc_dflags =- dflags2 { ldInputs = newLdInputs- , cmdlineFrameworks = newCLFrameworks } }-- when (not (null newLdInputs && null newCLFrameworks)) $- liftIO $ linkCmdLineLibs hsc_env'-- return ()---unsetOptions :: GhciMonad m => String -> m ()-unsetOptions str- = -- first, deal with the GHCi opts (+s, +t, etc.)- let opts = words str- (minus_opts, rest1) = partition isMinus opts- (plus_opts, rest2) = partitionWith isPlus rest1- (other_opts, rest3) = partition (`elem` map fst defaulters) rest2-- defaulters =- [ ("args" , setArgs default_args)- , ("prog" , setProg default_progname)- , ("prompt" , setPrompt default_prompt)- , ("prompt-cont", setPromptCont default_prompt_cont)- , ("editor" , liftIO findEditor >>= setEditor)- , ("stop" , setStop default_stop)- ]-- no_flag ('-':'f':rest) = return ("-fno-" ++ rest)- no_flag ('-':'X':rest) = return ("-XNo" ++ rest)- no_flag f = throwGhcException (ProgramError ("don't know how to reverse " ++ f))-- in if (not (null rest3))- then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'"))- else do- mapM_ (fromJust.flip lookup defaulters) other_opts-- mapM_ unsetOpt plus_opts-- no_flags <- mapM no_flag minus_opts- when (not (null no_flags)) $ newDynFlags False no_flags--isMinus :: String -> Bool-isMinus ('-':_) = True-isMinus _ = False--isPlus :: String -> Either String String-isPlus ('+':opt) = Left opt-isPlus other = Right other--setOpt, unsetOpt :: GhciMonad m => String -> m ()--setOpt str- = case strToGHCiOpt str of- Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))- Just o -> setOption o--unsetOpt str- = case strToGHCiOpt str of- Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))- Just o -> unsetOption o--strToGHCiOpt :: String -> (Maybe GHCiOption)-strToGHCiOpt "m" = Just Multiline-strToGHCiOpt "s" = Just ShowTiming-strToGHCiOpt "t" = Just ShowType-strToGHCiOpt "r" = Just RevertCAFs-strToGHCiOpt "c" = Just CollectInfo-strToGHCiOpt _ = Nothing--optToStr :: GHCiOption -> String-optToStr Multiline = "m"-optToStr ShowTiming = "s"-optToStr ShowType = "t"-optToStr RevertCAFs = "r"-optToStr CollectInfo = "c"----- ------------------------------------------------------------------------------ :show--showCmd :: forall m. GhciMonad m => String -> m ()-showCmd "" = showOptions False-showCmd "-a" = showOptions True-showCmd str = do- st <- getGHCiState- dflags <- getDynFlags- hsc_env <- GHC.getSession-- let lookupCmd :: String -> Maybe (m ())- lookupCmd name = lookup name $ map (\(_,b,c) -> (b,c)) cmds-- -- (show in help?, command name, action)- action :: String -> m () -> (Bool, String, m ())- action name m = (True, name, m)-- hidden :: String -> m () -> (Bool, String, m ())- hidden name m = (False, name, m)-- cmds =- [ action "args" $ liftIO $ putStrLn (show (GhciMonad.args st))- , action "prog" $ liftIO $ putStrLn (show (progname st))- , action "editor" $ liftIO $ putStrLn (show (editor st))- , action "stop" $ liftIO $ putStrLn (show (stop st))- , action "imports" $ showImports- , action "modules" $ showModules- , action "bindings" $ showBindings- , action "linker" $ getDynFlags >>= liftIO . (showLinkerState (hsc_dynLinker hsc_env))- , action "breaks" $ showBkptTable- , action "context" $ showContext- , action "packages" $ showPackages- , action "paths" $ showPaths- , action "language" $ showLanguages- , hidden "languages" $ showLanguages -- backwards compat- , hidden "lang" $ showLanguages -- useful abbreviation- , action "targets" $ showTargets- ]-- case words str of- [w] | Just action <- lookupCmd w -> action-- _ -> let helpCmds = [ text name | (True, name, _) <- cmds ]- in throwGhcException $ CmdLineError $ showSDoc dflags- $ hang (text "syntax:") 4- $ hang (text ":show") 6- $ brackets (fsep $ punctuate (text " |") helpCmds)--showiCmd :: GHC.GhcMonad m => String -> m ()-showiCmd str = do- case words str of- ["languages"] -> showiLanguages -- backwards compat- ["language"] -> showiLanguages- ["lang"] -> showiLanguages -- useful abbreviation- _ -> throwGhcException (CmdLineError ("syntax: :showi language"))--showImports :: GhciMonad m => m ()-showImports = do- st <- getGHCiState- dflags <- getDynFlags- let rem_ctx = reverse (remembered_ctx st)- trans_ctx = transient_ctx st-- show_one (IIModule star_m)- = ":module +*" ++ moduleNameString star_m- show_one (IIDecl imp) = showPpr dflags imp-- prel_iidecls <- getImplicitPreludeImports (rem_ctx ++ trans_ctx)-- let show_prel p = show_one p ++ " -- implicit"- show_extra p = show_one (IIDecl p) ++ " -- fixed"-- trans_comment s = s ++ " -- added automatically" :: String- --- liftIO $ mapM_ putStrLn (map show_one rem_ctx ++- map (trans_comment . show_one) trans_ctx ++- map show_prel prel_iidecls ++- map show_extra (extra_imports st))--showModules :: GHC.GhcMonad m => m ()-showModules = do- loaded_mods <- getLoadedModules- -- we want *loaded* modules only, see #1734- let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m)- mapM_ show_one loaded_mods--getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]-getLoadedModules = do- graph <- GHC.getModuleGraph- filterM (GHC.isLoaded . GHC.ms_mod_name) (GHC.mgModSummaries graph)--showBindings :: GHC.GhcMonad m => m ()-showBindings = do- bindings <- GHC.getBindings- (insts, finsts) <- GHC.getInsts- let idocs = map GHC.pprInstanceHdr insts- fidocs = map GHC.pprFamInst finsts- binds = filter (not . isDerivedOccName . getOccName) bindings -- #12525- -- See Note [Filter bindings]- docs <- mapM makeDoc (reverse binds)- -- reverse so the new ones come last- mapM_ printForUserPartWay (docs ++ idocs ++ fidocs)- where- makeDoc (AnId i) = pprTypeAndContents i- makeDoc tt = do- mb_stuff <- GHC.getInfo False (getName tt)- return $ maybe (text "") pprTT mb_stuff-- pprTT :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst], SDoc) -> SDoc- pprTT (thing, fixity, _cls_insts, _fam_insts, _docs)- = pprTyThing showToHeader thing- $$ show_fixity- where- show_fixity- | fixity == GHC.defaultFixity = empty- | otherwise = ppr fixity <+> ppr (GHC.getName thing)---printTyThing :: GHC.GhcMonad m => TyThing -> m ()-printTyThing tyth = printForUser (pprTyThing showToHeader tyth)--{--Note [Filter bindings]-~~~~~~~~~~~~~~~~~~~~~~--If we don't filter the bindings returned by the function GHC.getBindings,-then the :show bindings command will also show unwanted bound names,-internally generated by GHC, eg:- $tcFoo :: GHC.Types.TyCon = _- $trModule :: GHC.Types.Module = _ .--The filter was introduced as a fix for #12525 [1]. Comment:1 [2] to this-ticket contains an analysis of the situation and suggests the solution-implemented above.--The same filter was also implemented to fix #11051 [3]. See the-Note [What to show to users] in compiler/main/InteractiveEval.hs--[1] https://gitlab.haskell.org/ghc/ghc/issues/12525-[2] https://gitlab.haskell.org/ghc/ghc/issues/12525#note_123489-[3] https://gitlab.haskell.org/ghc/ghc/issues/11051--}---showBkptTable :: GhciMonad m => m ()-showBkptTable = do- st <- getGHCiState- printForUser $ prettyLocations (breaks st)--showContext :: GHC.GhcMonad m => m ()-showContext = do- resumes <- GHC.getResumeContext- printForUser $ vcat (map pp_resume (reverse resumes))- where- pp_resume res =- ptext (sLit "--> ") <> text (GHC.resumeStmt res)- $$ nest 2 (pprStopped res)--pprStopped :: GHC.Resume -> SDoc-pprStopped res =- ptext (sLit "Stopped in")- <+> ((case mb_mod_name of- Nothing -> empty- Just mod_name -> text (moduleNameString mod_name) <> char '.')- <> text (GHC.resumeDecl res))- <> char ',' <+> ppr (GHC.resumeSpan res)- where- mb_mod_name = moduleName <$> GHC.breakInfo_module <$> GHC.resumeBreakInfo res--showPackages :: GHC.GhcMonad m => m ()-showPackages = do- dflags <- getDynFlags- let pkg_flags = packageFlags dflags- liftIO $ putStrLn $ showSDoc dflags $- text ("active package flags:"++if null pkg_flags then " none" else "") $$- nest 2 (vcat (map pprFlag pkg_flags))--showPaths :: GHC.GhcMonad m => m ()-showPaths = do- dflags <- getDynFlags- liftIO $ do- cwd <- getCurrentDirectory- putStrLn $ showSDoc dflags $- text "current working directory: " $$- nest 2 (text cwd)- let ipaths = importPaths dflags- putStrLn $ showSDoc dflags $- text ("module import search paths:"++if null ipaths then " none" else "") $$- nest 2 (vcat (map text ipaths))--showLanguages :: GHC.GhcMonad m => m ()-showLanguages = getDynFlags >>= liftIO . showLanguages' False--showiLanguages :: GHC.GhcMonad m => m ()-showiLanguages = GHC.getInteractiveDynFlags >>= liftIO . showLanguages' False--showLanguages' :: Bool -> DynFlags -> IO ()-showLanguages' show_all dflags =- putStrLn $ showSDoc dflags $ vcat- [ text "base language is: " <>- case language dflags of- Nothing -> text "Haskell2010"- Just Haskell98 -> text "Haskell98"- Just Haskell2010 -> text "Haskell2010"- , (if show_all then text "all active language options:"- else text "with the following modifiers:") $$- nest 2 (vcat (map (setting xopt) DynFlags.xFlags))- ]- where- setting test flag- | quiet = empty- | is_on = text "-X" <> text name- | otherwise = text "-XNo" <> text name- where name = flagSpecName flag- f = flagSpecFlag flag- is_on = test f dflags- quiet = not show_all && test f default_dflags == is_on-- llvmConfig = (llvmTargets dflags, llvmPasses dflags)-- default_dflags =- defaultDynFlags (settings dflags) llvmConfig `lang_set`- case language dflags of- Nothing -> Just Haskell2010- other -> other--showTargets :: GHC.GhcMonad m => m ()-showTargets = mapM_ showTarget =<< GHC.getTargets- where- showTarget :: GHC.GhcMonad m => Target -> m ()- showTarget (Target (TargetFile f _) _ _) = liftIO (putStrLn f)- showTarget (Target (TargetModule m) _ _) =- liftIO (putStrLn $ moduleNameString m)---- -------------------------------------------------------------------------------- Completion--completeCmd :: String -> GHCi ()-completeCmd argLine0 = case parseLine argLine0 of- Just ("repl", resultRange, left) -> do- (unusedLine,compls) <- ghciCompleteWord (reverse left,"")- let compls' = takeRange resultRange compls- liftIO . putStrLn $ unwords [ show (length compls'), show (length compls), show (reverse unusedLine) ]- forM_ (takeRange resultRange compls) $ \(Completion r _ _) -> do- liftIO $ print r- _ -> throwGhcException (CmdLineError "Syntax: :complete repl [<range>] <quoted-string-to-complete>")- where- parseLine argLine- | null argLine = Nothing- | null rest1 = Nothing- | otherwise = (,,) dom <$> resRange <*> s- where- (dom, rest1) = breakSpace argLine- (rng, rest2) = breakSpace rest1- resRange | head rest1 == '"' = parseRange ""- | otherwise = parseRange rng- s | head rest1 == '"' = readMaybe rest1 :: Maybe String- | otherwise = readMaybe rest2- breakSpace = fmap (dropWhile isSpace) . break isSpace-- takeRange (lb,ub) = maybe id (drop . pred) lb . maybe id take ub-- -- syntax: [n-][m] with semantics "drop (n-1) . take m"- parseRange :: String -> Maybe (Maybe Int,Maybe Int)- parseRange s = case span isDigit s of- (_, "") ->- -- upper limit only- Just (Nothing, bndRead s)- (s1, '-' : s2)- | all isDigit s2 ->- Just (bndRead s1, bndRead s2)- _ ->- Nothing- where- bndRead x = if null x then Nothing else Just (read x)----completeGhciCommand, completeMacro, completeIdentifier, completeModule,- completeSetModule, completeSeti, completeShowiOptions,- completeHomeModule, completeSetOptions, completeShowOptions,- completeHomeModuleOrFile, completeExpression- :: GhciMonad m => CompletionFunc m---- | Provide completions for last word in a given string.------ Takes a tuple of two strings. First string is a reversed line to be--- completed. Second string is likely unused, 'completeCmd' always passes an--- empty string as second item in tuple.-ghciCompleteWord :: CompletionFunc GHCi-ghciCompleteWord line@(left,_) = case firstWord of- -- If given string starts with `:` colon, and there is only one following- -- word then provide REPL command completions. If there is more than one- -- word complete either filename or builtin ghci commands or macros.- ':':cmd | null rest -> completeGhciCommand line- | otherwise -> do- completion <- lookupCompletion cmd- completion line- -- If given string starts with `import` keyword provide module name- -- completions- "import" -> completeModule line- -- otherwise provide identifier completions- _ -> completeExpression line- where- (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left- lookupCompletion ('!':_) = return completeFilename- lookupCompletion c = do- maybe_cmd <- lookupCommand' c- case maybe_cmd of- Just cmd -> return (cmdCompletionFunc cmd)- Nothing -> return completeFilename--completeGhciCommand = wrapCompleter " " $ \w -> do- macros <- ghci_macros <$> getGHCiState- cmds <- ghci_commands `fmap` getGHCiState- let macro_names = map (':':) . map cmdName $ macros- let command_names = map (':':) . map cmdName $ filter (not . cmdHidden) cmds- let{ candidates = case w of- ':' : ':' : _ -> map (':':) command_names- _ -> nub $ macro_names ++ command_names }- return $ filter (w `isPrefixOf`) candidates--completeMacro = wrapIdentCompleter $ \w -> do- cmds <- ghci_macros <$> getGHCiState- return (filter (w `isPrefixOf`) (map cmdName cmds))--completeIdentifier line@(left, _) =- -- Note: `left` is a reversed input- case left of- (x:_) | isSymbolChar x -> wrapCompleter (specials ++ spaces) complete line- _ -> wrapIdentCompleter complete line- where- complete w = do- rdrs <- GHC.getRdrNamesInScope- dflags <- GHC.getSessionDynFlags- return (filter (w `isPrefixOf`) (map (showPpr dflags) rdrs))--completeModule = wrapIdentCompleter $ \w -> do- dflags <- GHC.getSessionDynFlags- let pkg_mods = allVisibleModules dflags- loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules- return $ filter (w `isPrefixOf`)- $ map (showPpr dflags) $ loaded_mods ++ pkg_mods--completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do- dflags <- GHC.getSessionDynFlags- modules <- case m of- Just '-' -> do- imports <- GHC.getContext- return $ map iiModuleName imports- _ -> do- let pkg_mods = allVisibleModules dflags- loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules- return $ loaded_mods ++ pkg_mods- return $ filter (w `isPrefixOf`) $ map (showPpr dflags) modules--completeHomeModule = wrapIdentCompleter listHomeModules--listHomeModules :: GHC.GhcMonad m => String -> m [String]-listHomeModules w = do- g <- GHC.getModuleGraph- let home_mods = map GHC.ms_mod_name (GHC.mgModSummaries g)- dflags <- getDynFlags- return $ sort $ filter (w `isPrefixOf`)- $ map (showPpr dflags) home_mods--completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do- return (filter (w `isPrefixOf`) opts)- where opts = "args":"prog":"prompt":"prompt-cont":"prompt-function":- "prompt-cont-function":"editor":"stop":flagList- flagList = map head $ group $ sort allNonDeprecatedFlags--completeSeti = wrapCompleter flagWordBreakChars $ \w -> do- return (filter (w `isPrefixOf`) flagList)- where flagList = map head $ group $ sort allNonDeprecatedFlags--completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do- return (filter (w `isPrefixOf`) opts)- where opts = ["args", "prog", "editor", "stop",- "modules", "bindings", "linker", "breaks",- "context", "packages", "paths", "language", "imports"]--completeShowiOptions = wrapCompleter flagWordBreakChars $ \w -> do- return (filter (w `isPrefixOf`) ["language"])--completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars- $ unionComplete (fmap (map simpleCompletion) . listHomeModules)- listFiles--unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]-unionComplete f1 f2 line = do- cs1 <- f1 line- cs2 <- f2 line- return (cs1 ++ cs2)--wrapCompleter :: Monad m => String -> (String -> m [String]) -> CompletionFunc m-wrapCompleter breakChars fun = completeWord Nothing breakChars- $ fmap (map simpleCompletion . nubSort) . fun--wrapIdentCompleter :: Monad m => (String -> m [String]) -> CompletionFunc m-wrapIdentCompleter = wrapCompleter word_break_chars--wrapIdentCompleterWithModifier- :: Monad m- => String -> (Maybe Char -> String -> m [String]) -> CompletionFunc m-wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars- $ \rest -> fmap (map simpleCompletion . nubSort) . fun (getModifier rest)- where- getModifier = find (`elem` modifChars)---- | Return a list of visible module names for autocompletion.--- (NB: exposed != visible)-allVisibleModules :: DynFlags -> [ModuleName]-allVisibleModules dflags = listVisibleModuleNames dflags--completeExpression = completeQuotedWord (Just '\\') "\"" listFiles- completeIdentifier----- -------------------------------------------------------------------------------- commands for debugger--sprintCmd, printCmd, forceCmd :: GHC.GhcMonad m => String -> m ()-sprintCmd = pprintClosureCommand False False-printCmd = pprintClosureCommand True False-forceCmd = pprintClosureCommand False True--stepCmd :: GhciMonad m => String -> m ()-stepCmd arg = withSandboxOnly ":step" $ step arg- where- step [] = doContinue (const True) GHC.SingleStep- step expression = runStmt expression GHC.SingleStep >> return ()--stepLocalCmd :: GhciMonad m => String -> m ()-stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg- where- step expr- | not (null expr) = stepCmd expr- | otherwise = do- mb_span <- getCurrentBreakSpan- case mb_span of- Nothing -> stepCmd []- Just loc -> do- md <- fromMaybe (panic "stepLocalCmd") <$> getCurrentBreakModule- current_toplevel_decl <- enclosingTickSpan md loc- doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl) GHC.SingleStep--stepModuleCmd :: GhciMonad m => String -> m ()-stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg- where- step expr- | not (null expr) = stepCmd expr- | otherwise = do- mb_span <- getCurrentBreakSpan- case mb_span of- Nothing -> stepCmd []- Just pan -> do- let f some_span = srcSpanFileName_maybe pan == srcSpanFileName_maybe some_span- doContinue f GHC.SingleStep---- | Returns the span of the largest tick containing the srcspan given-enclosingTickSpan :: GhciMonad m => Module -> SrcSpan -> m RealSrcSpan-enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"-enclosingTickSpan md (RealSrcSpan src) = do- ticks <- getTickArray md- let line = srcSpanStartLine src- ASSERT(inRange (bounds ticks) line) do- let enclosing_spans = [ pan | (_,pan) <- ticks ! line- , realSrcSpanEnd pan >= realSrcSpanEnd src]- return . head . sortBy leftmostLargestRealSrcSpan $ enclosing_spans- where--leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering-leftmostLargestRealSrcSpan a b =- (realSrcSpanStart a `compare` realSrcSpanStart b)- `thenCmp`- (realSrcSpanEnd b `compare` realSrcSpanEnd a)--traceCmd :: GhciMonad m => String -> m ()-traceCmd arg- = withSandboxOnly ":trace" $ tr arg- where- tr [] = doContinue (const True) GHC.RunAndLogSteps- tr expression = runStmt expression GHC.RunAndLogSteps >> return ()--continueCmd :: GhciMonad m => String -> m ()-continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion--doContinue :: GhciMonad m => (SrcSpan -> Bool) -> SingleStep -> m ()-doContinue pre step = do- runResult <- resume pre step- _ <- afterRunStmt pre runResult- return ()--abandonCmd :: GhciMonad m => String -> m ()-abandonCmd = noArgs $ withSandboxOnly ":abandon" $ do- b <- GHC.abandon -- the prompt will change to indicate the new context- when (not b) $ liftIO $ putStrLn "There is no computation running."--deleteCmd :: GhciMonad m => String -> m ()-deleteCmd argLine = withSandboxOnly ":delete" $ do- deleteSwitch $ words argLine- where- deleteSwitch :: GhciMonad m => [String] -> m ()- deleteSwitch [] =- liftIO $ putStrLn "The delete command requires at least one argument."- -- delete all break points- deleteSwitch ("*":_rest) = discardActiveBreakPoints- deleteSwitch idents = do- mapM_ deleteOneBreak idents- where- deleteOneBreak :: GhciMonad m => String -> m ()- deleteOneBreak str- | all isDigit str = deleteBreak (read str)- | otherwise = return ()--enableCmd :: GhciMonad m => String -> m ()-enableCmd argLine = withSandboxOnly ":enable" $ do- enaDisaSwitch True $ words argLine--disableCmd :: GhciMonad m => String -> m ()-disableCmd argLine = withSandboxOnly ":disable" $ do- enaDisaSwitch False $ words argLine--enaDisaSwitch :: GhciMonad m => Bool -> [String] -> m ()-enaDisaSwitch enaDisa [] =- printForUser (text "The" <+> text strCmd <+>- text "command requires at least one argument.")- where- strCmd = if enaDisa then ":enable" else ":disable"-enaDisaSwitch enaDisa ("*" : _) = enaDisaAllBreaks enaDisa-enaDisaSwitch enaDisa idents = do- mapM_ (enaDisaOneBreak enaDisa) idents- where- enaDisaOneBreak :: GhciMonad m => Bool -> String -> m ()- enaDisaOneBreak enaDisa strId = do- sdoc_loc <- getBreakLoc enaDisa strId- case sdoc_loc of- Left sdoc -> printForUser sdoc- Right loc -> enaDisaAssoc enaDisa (read strId, loc)--getBreakLoc :: GhciMonad m => Bool -> String -> m (Either SDoc BreakLocation)-getBreakLoc enaDisa strId = do- st <- getGHCiState- case readMaybe strId >>= flip IntMap.lookup (breaks st) of- Nothing -> return $ Left (text "Breakpoint" <+> text strId <+>- text "not found")- Just loc ->- if breakEnabled loc == enaDisa- then return $ Left- (text "Breakpoint" <+> text strId <+>- text "already in desired state")- else return $ Right loc--enaDisaAssoc :: GhciMonad m => Bool -> (Int, BreakLocation) -> m ()-enaDisaAssoc enaDisa (intId, loc) = do- st <- getGHCiState- newLoc <- turnBreakOnOff enaDisa loc- let new_breaks = IntMap.insert intId newLoc (breaks st)- setGHCiState $ st { breaks = new_breaks }--enaDisaAllBreaks :: GhciMonad m => Bool -> m()-enaDisaAllBreaks enaDisa = do- st <- getGHCiState- mapM_ (enaDisaAssoc enaDisa) $ IntMap.assocs $ breaks st--historyCmd :: GHC.GhcMonad m => String -> m ()-historyCmd arg- | null arg = history 20- | all isDigit arg = history (read arg)- | otherwise = liftIO $ putStrLn "Syntax: :history [num]"- where- history num = do- resumes <- GHC.getResumeContext- case resumes of- [] -> liftIO $ putStrLn "Not stopped at a breakpoint"- (r:_) -> do- let hist = GHC.resumeHistory r- (took,rest) = splitAt num hist- case hist of- [] -> liftIO $ putStrLn $- "Empty history. Perhaps you forgot to use :trace?"- _ -> do- pans <- mapM GHC.getHistorySpan took- let nums = map (printf "-%-3d:") [(1::Int)..]- names = map GHC.historyEnclosingDecls took- printForUser (vcat(zipWith3- (\x y z -> x <+> y <+> z)- (map text nums)- (map (bold . hcat . punctuate colon . map text) names)- (map (parens . ppr) pans)))- liftIO $ putStrLn $ if null rest then "<end of history>" else "..."--bold :: SDoc -> SDoc-bold c | do_bold = text start_bold <> c <> text end_bold- | otherwise = c--backCmd :: GhciMonad m => String -> m ()-backCmd arg- | null arg = back 1- | all isDigit arg = back (read arg)- | otherwise = liftIO $ putStrLn "Syntax: :back [num]"- where- back num = withSandboxOnly ":back" $ do- (names, _, pan, _) <- GHC.back num- printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr pan- printTypeOfNames names- -- run the command set with ":set stop <cmd>"- st <- getGHCiState- enqueueCommands [stop st]--forwardCmd :: GhciMonad m => String -> m ()-forwardCmd arg- | null arg = forward 1- | all isDigit arg = forward (read arg)- | otherwise = liftIO $ putStrLn "Syntax: :forward [num]"- where- forward num = withSandboxOnly ":forward" $ do- (names, ix, pan, _) <- GHC.forward num- printForUser $ (if (ix == 0)- then ptext (sLit "Stopped at")- else ptext (sLit "Logged breakpoint at")) <+> ppr pan- printTypeOfNames names- -- run the command set with ":set stop <cmd>"- st <- getGHCiState- enqueueCommands [stop st]---- handle the "break" command-breakCmd :: GhciMonad m => String -> m ()-breakCmd argLine = withSandboxOnly ":break" $ breakSwitch $ words argLine--breakSwitch :: GhciMonad m => [String] -> m ()-breakSwitch [] = do- liftIO $ putStrLn "The break command requires at least one argument."-breakSwitch (arg1:rest)- | looksLikeModuleName arg1 && not (null rest) = do- md <- wantInterpretedModule arg1- breakByModule md rest- | all isDigit arg1 = do- imports <- GHC.getContext- case iiModules imports of- (mn : _) -> do- md <- lookupModuleName mn- breakByModuleLine md (read arg1) rest- [] -> do- liftIO $ putStrLn "No modules are loaded with debugging support."- | otherwise = do -- try parsing it as an identifier- wantNameFromInterpretedModule noCanDo arg1 $ \name -> do- maybe_info <- GHC.getModuleInfo (GHC.nameModule name)- case maybe_info of- Nothing -> noCanDo name (ptext (sLit "cannot get module info"))- Just minf ->- ASSERT( isExternalName name )- findBreakAndSet (GHC.nameModule name) $- findBreakForBind name (GHC.modInfoModBreaks minf)- where- noCanDo n why = printForUser $- text "cannot set breakpoint on " <> ppr n <> text ": " <> why--breakByModule :: GhciMonad m => Module -> [String] -> m ()-breakByModule md (arg1:rest)- | all isDigit arg1 = do -- looks like a line number- breakByModuleLine md (read arg1) rest-breakByModule _ _- = breakSyntax--breakByModuleLine :: GhciMonad m => Module -> Int -> [String] -> m ()-breakByModuleLine md line args- | [] <- args = findBreakAndSet md $ maybeToList . findBreakByLine line- | [col] <- args, all isDigit col =- findBreakAndSet md $ maybeToList . findBreakByCoord Nothing (line, read col)- | otherwise = breakSyntax--breakSyntax :: a-breakSyntax = throwGhcException (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")--findBreakAndSet :: GhciMonad m- => Module -> (TickArray -> [(Int, RealSrcSpan)]) -> m ()-findBreakAndSet md lookupTickTree = do- tickArray <- getTickArray md- (breakArray, _) <- getModBreak md- case lookupTickTree tickArray of- [] -> liftIO $ putStrLn $ "No breakpoints found at that location."- some -> mapM_ (breakAt breakArray) some- where- breakAt breakArray (tick, pan) = do- setBreakFlag True breakArray tick- (alreadySet, nm) <-- recordBreak $ BreakLocation- { breakModule = md- , breakLoc = RealSrcSpan pan- , breakTick = tick- , onBreakCmd = ""- , breakEnabled = True- }- printForUser $- text "Breakpoint " <> ppr nm <>- if alreadySet- then text " was already set at " <> ppr pan- else text " activated at " <> ppr pan---- When a line number is specified, the current policy for choosing--- the best breakpoint is this:--- - the leftmost complete subexpression on the specified line, or--- - the leftmost subexpression starting on the specified line, or--- - the rightmost subexpression enclosing the specified line----findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,RealSrcSpan)-findBreakByLine line arr- | not (inRange (bounds arr) line) = Nothing- | otherwise =- listToMaybe (sortBy (leftmostLargestRealSrcSpan `on` snd) comp) `mplus`- listToMaybe (sortBy (compare `on` snd) incomp) `mplus`- listToMaybe (sortBy (flip compare `on` snd) ticks)- where- ticks = arr ! line-- starts_here = [ (ix,pan) | (ix, pan) <- ticks,- GHC.srcSpanStartLine pan == line ]-- (comp, incomp) = partition ends_here starts_here- where ends_here (_,pan) = GHC.srcSpanEndLine pan == line---- The aim is to find the breakpoints for all the RHSs of the--- equations corresponding to a binding. So we find all breakpoints--- for--- (a) this binder only (not a nested declaration)--- (b) that do not have an enclosing breakpoint-findBreakForBind :: Name -> GHC.ModBreaks -> TickArray- -> [(BreakIndex,RealSrcSpan)]-findBreakForBind name modbreaks _ = filter (not . enclosed) ticks- where- ticks = [ (index, span)- | (index, [n]) <- assocs (GHC.modBreaks_decls modbreaks),- n == occNameString (nameOccName name),- RealSrcSpan span <- [GHC.modBreaks_locs modbreaks ! index] ]- enclosed (_,sp0) = any subspan ticks- where subspan (_,sp) = sp /= sp0 &&- realSrcSpanStart sp <= realSrcSpanStart sp0 &&- realSrcSpanEnd sp0 <= realSrcSpanEnd sp--findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray- -> Maybe (BreakIndex,RealSrcSpan)-findBreakByCoord mb_file (line, col) arr- | not (inRange (bounds arr) line) = Nothing- | otherwise =- listToMaybe (sortBy (flip compare `on` snd) contains ++- sortBy (compare `on` snd) after_here)- where- ticks = arr ! line-- -- the ticks that span this coordinate- contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan `spans` (line,col),- is_correct_file pan ]-- is_correct_file pan- | Just f <- mb_file = GHC.srcSpanFile pan == f- | otherwise = True-- after_here = [ tick | tick@(_,pan) <- ticks,- GHC.srcSpanStartLine pan == line,- GHC.srcSpanStartCol pan >= col ]---- For now, use ANSI bold on terminals that we know support it.--- Otherwise, we add a line of carets under the active expression instead.--- In particular, on Windows and when running the testsuite (which sets--- TERM to vt100 for other reasons) we get carets.--- We really ought to use a proper termcap/terminfo library.-do_bold :: Bool-do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]- where mTerm = System.Environment.getEnv "TERM"- `catchIO` \_ -> return "TERM not set"--start_bold :: String-start_bold = "\ESC[1m"-end_bold :: String-end_bold = "\ESC[0m"---------------------------------------------------------------------------------- :where--whereCmd :: GHC.GhcMonad m => String -> m ()-whereCmd = noArgs $ do- mstrs <- getCallStackAtCurrentBreakpoint- case mstrs of- Nothing -> return ()- Just strs -> liftIO $ putStrLn (renderStack strs)---------------------------------------------------------------------------------- :list--listCmd :: GhciMonad m => String -> m ()-listCmd "" = do- mb_span <- getCurrentBreakSpan- case mb_span of- Nothing ->- printForUser $ text "Not stopped at a breakpoint; nothing to list"- Just (RealSrcSpan pan) ->- listAround pan True- Just pan@(UnhelpfulSpan _) ->- do resumes <- GHC.getResumeContext- case resumes of- [] -> panic "No resumes"- (r:_) ->- do let traceIt = case GHC.resumeHistory r of- [] -> text "rerunning with :trace,"- _ -> empty- doWhat = traceIt <+> text ":back then :list"- printForUser (text "Unable to list source for" <+>- ppr pan- $$ text "Try" <+> doWhat)-listCmd str = list2 (words str)--list2 :: GhciMonad m => [String] -> m ()-list2 [arg] | all isDigit arg = do- imports <- GHC.getContext- case iiModules imports of- [] -> liftIO $ putStrLn "No module to list"- (mn : _) -> do- md <- lookupModuleName mn- listModuleLine md (read arg)-list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do- md <- wantInterpretedModule arg1- listModuleLine md (read arg2)-list2 [arg] = do- wantNameFromInterpretedModule noCanDo arg $ \name -> do- let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)- case loc of- RealSrcLoc l ->- do tickArray <- ASSERT( isExternalName name )- getTickArray (GHC.nameModule name)- let mb_span = findBreakByCoord (Just (GHC.srcLocFile l))- (GHC.srcLocLine l, GHC.srcLocCol l)- tickArray- case mb_span of- Nothing -> listAround (realSrcLocSpan l) False- Just (_, pan) -> listAround pan False- UnhelpfulLoc _ ->- noCanDo name $ text "can't find its location: " <>- ppr loc- where- noCanDo n why = printForUser $- text "cannot list source code for " <> ppr n <> text ": " <> why-list2 _other =- liftIO $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"--listModuleLine :: GHC.GhcMonad m => Module -> Int -> m ()-listModuleLine modl line = do- graph <- GHC.getModuleGraph- let this = GHC.mgLookupModule graph modl- case this of- Nothing -> panic "listModuleLine"- Just summ -> do- let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))- loc = mkRealSrcLoc (mkFastString (filename)) line 0- listAround (realSrcLocSpan loc) False---- | list a section of a source file around a particular SrcSpan.--- If the highlight flag is True, also highlight the span using--- start_bold\/end_bold.---- GHC files are UTF-8, so we can implement this by:--- 1) read the file in as a BS and syntax highlight it as before--- 2) convert the BS to String using utf-string, and write it out.--- It would be better if we could convert directly between UTF-8 and the--- console encoding, of course.-listAround :: MonadIO m => RealSrcSpan -> Bool -> m ()-listAround pan do_highlight = do- contents <- liftIO $ BS.readFile (unpackFS file)- -- Drop carriage returns to avoid duplicates, see #9367.- let ls = BS.split '\n' $ BS.filter (/= '\r') contents- ls' = take (line2 - line1 + 1 + pad_before + pad_after) $- drop (line1 - 1 - pad_before) $ ls- fst_line = max 1 (line1 - pad_before)- line_nos = [ fst_line .. ]-- highlighted | do_highlight = zipWith highlight line_nos ls'- | otherwise = [\p -> BS.concat[p,l] | l <- ls']-- bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]- prefixed = zipWith ($) highlighted bs_line_nos- output = BS.intercalate (BS.pack "\n") prefixed-- let utf8Decoded = utf8DecodeByteString output- liftIO $ putStrLn utf8Decoded- where- file = GHC.srcSpanFile pan- line1 = GHC.srcSpanStartLine pan- col1 = GHC.srcSpanStartCol pan - 1- line2 = GHC.srcSpanEndLine pan- col2 = GHC.srcSpanEndCol pan - 1-- pad_before | line1 == 1 = 0- | otherwise = 1- pad_after = 1-- highlight | do_bold = highlight_bold- | otherwise = highlight_carets-- highlight_bold no line prefix- | no == line1 && no == line2- = let (a,r) = BS.splitAt col1 line- (b,c) = BS.splitAt (col2-col1) r- in- BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]- | no == line1- = let (a,b) = BS.splitAt col1 line in- BS.concat [prefix, a, BS.pack start_bold, b]- | no == line2- = let (a,b) = BS.splitAt col2 line in- BS.concat [prefix, a, BS.pack end_bold, b]- | otherwise = BS.concat [prefix, line]-- highlight_carets no line prefix- | no == line1 && no == line2- = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',- BS.replicate (col2-col1) '^']- | no == line1- = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,- prefix, line]- | no == line2- = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',- BS.pack "^^"]- | otherwise = BS.concat [prefix, line]- where- indent = BS.pack (" " ++ replicate (length (show no)) ' ')- nl = BS.singleton '\n'----- ----------------------------------------------------------------------------- Tick arrays--getTickArray :: GhciMonad m => Module -> m TickArray-getTickArray modl = do- st <- getGHCiState- let arrmap = tickarrays st- case lookupModuleEnv arrmap modl of- Just arr -> return arr- Nothing -> do- (_breakArray, ticks) <- getModBreak modl- let arr = mkTickArray (assocs ticks)- setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}- return arr--discardTickArrays :: GhciMonad m => m ()-discardTickArrays = modifyGHCiState (\st -> st {tickarrays = emptyModuleEnv})--mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray-mkTickArray ticks- = accumArray (flip (:)) [] (1, max_line)- [ (line, (nm,pan)) | (nm,RealSrcSpan pan) <- ticks, line <- srcSpanLines pan ]- where- max_line = foldr max 0 [ GHC.srcSpanEndLine sp | (_, RealSrcSpan sp) <- ticks ]- srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ]---- don't reset the counter back to zero?-discardActiveBreakPoints :: GhciMonad m => m ()-discardActiveBreakPoints = do- st <- getGHCiState- mapM_ (turnBreakOnOff False) $ breaks st- setGHCiState $ st { breaks = IntMap.empty }--deleteBreak :: GhciMonad m => Int -> m ()-deleteBreak identity = do- st <- getGHCiState- let oldLocations = breaks st- case IntMap.lookup identity oldLocations of- Nothing -> printForUser (text "Breakpoint" <+> ppr identity <+>- text "does not exist")- Just loc -> do- _ <- (turnBreakOnOff False) loc- let rest = IntMap.delete identity oldLocations- setGHCiState $ st { breaks = rest }--turnBreakOnOff :: GHC.GhcMonad m => Bool -> BreakLocation -> m BreakLocation-turnBreakOnOff onOff loc- | onOff == breakEnabled loc = return loc- | otherwise = do- (arr, _) <- getModBreak (breakModule loc)- hsc_env <- GHC.getSession- liftIO $ enableBreakpoint hsc_env arr (breakTick loc) onOff- return loc { breakEnabled = onOff }--getModBreak :: GHC.GhcMonad m- => Module -> m (ForeignRef BreakArray, Array Int SrcSpan)-getModBreak m = do- mod_info <- fromMaybe (panic "getModBreak") <$> GHC.getModuleInfo m- let modBreaks = GHC.modInfoModBreaks mod_info- let arr = GHC.modBreaks_flags modBreaks- let ticks = GHC.modBreaks_locs modBreaks- return (arr, ticks)--setBreakFlag :: GHC.GhcMonad m => Bool -> ForeignRef BreakArray -> Int -> m ()-setBreakFlag toggle arr i = do- hsc_env <- GHC.getSession- liftIO $ enableBreakpoint hsc_env arr i toggle---- ------------------------------------------------------------------------------ User code exception handling---- This is the exception handler for exceptions generated by the--- user's code and exceptions coming from children sessions;--- it normally just prints out the exception. The--- handler must be recursive, in case showing the exception causes--- more exceptions to be raised.------ Bugfix: if the user closed stdout or stderr, the flushing will fail,--- raising another exception. We therefore don't put the recursive--- handler arond the flushing operation, so if stderr is closed--- GHCi will just die gracefully rather than going into an infinite loop.-handler :: GhciMonad m => SomeException -> m Bool-handler exception = do- flushInterpBuffers- withSignalHandlers $- ghciHandle handler (showException exception >> return False)--showException :: MonadIO m => SomeException -> m ()-showException se =- liftIO $ case fromException se of- -- omit the location for CmdLineError:- Just (CmdLineError s) -> putException s- -- ditto:- Just other_ghc_ex -> putException (show other_ghc_ex)- Nothing ->- case fromException se of- Just UserInterrupt -> putException "Interrupted."- _ -> putException ("*** Exception: " ++ show se)- where- putException = hPutStrLn stderr----------------------------------------------------------------------------------- recursive exception handlers---- Don't forget to unblock async exceptions in the handler, or if we're--- in an exception loop (eg. let a = error a in a) the ^C exception--- may never be delivered. Thanks to Marcin for pointing out the bug.--ghciHandle :: (HasDynFlags m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a-ghciHandle h m = gmask $ \restore -> do- -- Force dflags to avoid leaking the associated HscEnv- !dflags <- getDynFlags- gcatch (restore (GHC.prettyPrintGhcErrors dflags m)) $ \e -> restore (h e)--ghciTry :: ExceptionMonad m => m a -> m (Either SomeException a)-ghciTry m = fmap Right m `gcatch` \e -> return $ Left e--tryBool :: ExceptionMonad m => m a -> m Bool-tryBool m = do- r <- ghciTry m- case r of- Left _ -> return False- Right _ -> return True---- ------------------------------------------------------------------------------- Utils--lookupModule :: GHC.GhcMonad m => String -> m Module-lookupModule mName = lookupModuleName (GHC.mkModuleName mName)--lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module-lookupModuleName mName = GHC.lookupModule mName Nothing--isHomeModule :: Module -> Bool-isHomeModule m = GHC.moduleUnitId m == mainUnitId---- TODO: won't work if home dir is encoded.--- (changeDirectory may not work either in that case.)-expandPath :: MonadIO m => String -> m String-expandPath = liftIO . expandPathIO--expandPathIO :: String -> IO String-expandPathIO p =- case dropWhile isSpace p of- ('~':d) -> do- tilde <- getHomeDirectory -- will fail if HOME not defined- return (tilde ++ '/':d)- other ->- return other--wantInterpretedModule :: GHC.GhcMonad m => String -> m Module-wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str)--wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module-wantInterpretedModuleName modname = do- modl <- lookupModuleName modname- let str = moduleNameString modname- dflags <- getDynFlags- when (GHC.moduleUnitId modl /= thisPackage dflags) $- throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))- is_interpreted <- GHC.moduleIsInterpreted modl- when (not is_interpreted) $- throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))- return modl--wantNameFromInterpretedModule :: GHC.GhcMonad m- => (Name -> SDoc -> m ())- -> String- -> (Name -> m ())- -> m ()-wantNameFromInterpretedModule noCanDo str and_then =- handleSourceError GHC.printException $ do- names <- GHC.parseName str- case names of- [] -> return ()- (n:_) -> do- let modl = ASSERT( isExternalName n ) GHC.nameModule n- if not (GHC.isExternalName n)- then noCanDo n $ ppr n <>- text " is not defined in an interpreted module"- else do- is_interpreted <- GHC.moduleIsInterpreted modl- if not is_interpreted- then noCanDo n $ text "module " <> ppr modl <>- text " is not interpreted"- else and_then n--clearAllTargets :: GhciMonad m => m ()-clearAllTargets = discardActiveBreakPoints- >> GHC.setTargets []- >> GHC.load LoadAllTargets- >> pure ()
− ghc/GHCi/UI/Info.hs
@@ -1,382 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns #-}---- | Get information on modules, expressions, and identifiers-module GHCi.UI.Info- ( ModInfo(..)- , SpanInfo(..)- , spanInfoFromRealSrcSpan- , collectInfo- , findLoc- , findNameUses- , findType- , getModInfo- ) where--import Control.Exception-import Control.Monad-import Control.Monad.Trans.Class-import Control.Monad.Trans.Except-import Control.Monad.Trans.Maybe-import Data.Data-import Data.Function-import Data.List-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as M-import Data.Maybe-import Data.Time-import Prelude hiding (mod,(<>))-import System.Directory--import qualified CoreUtils-import Desugar-import DynFlags (HasDynFlags(..))-import FastString-import GHC-import GhcMonad-import Name-import NameSet-import Outputable-import SrcLoc-import TcHsSyn-import Var---- | Info about a module. This information is generated every time a--- module is loaded.-data ModInfo = ModInfo- { modinfoSummary :: !ModSummary- -- ^ Summary generated by GHC. Can be used to access more- -- information about the module.- , modinfoSpans :: [SpanInfo]- -- ^ Generated set of information about all spans in the- -- module that correspond to some kind of identifier for- -- which there will be type info and/or location info.- , modinfoInfo :: !ModuleInfo- -- ^ Again, useful from GHC for accessing information- -- (exports, instances, scope) from a module.- , modinfoLastUpdate :: !UTCTime- -- ^ The timestamp of the file used to generate this record.- }---- | Type of some span of source code. Most of these fields are--- unboxed but Haddock doesn't show that.-data SpanInfo = SpanInfo- { spaninfoSrcSpan :: {-# UNPACK #-} !RealSrcSpan- -- ^ The span we associate information with- , spaninfoType :: !(Maybe Type)- -- ^ The 'Type' associated with the span- , spaninfoVar :: !(Maybe Id)- -- ^ The actual 'Var' associated with the span, if- -- any. This can be useful for accessing a variety of- -- information about the identifier such as module,- -- locality, definition location, etc.- }--instance Outputable SpanInfo where- ppr (SpanInfo s t i) = ppr s <+> ppr t <+> ppr i---- | Test whether second span is contained in (or equal to) first span.--- This is basically 'containsSpan' for 'SpanInfo'-containsSpanInfo :: SpanInfo -> SpanInfo -> Bool-containsSpanInfo = containsSpan `on` spaninfoSrcSpan---- | Filter all 'SpanInfo' which are contained in 'SpanInfo'-spaninfosWithin :: [SpanInfo] -> SpanInfo -> [SpanInfo]-spaninfosWithin spans' si = filter (si `containsSpanInfo`) spans'---- | Construct a 'SpanInfo' from a 'RealSrcSpan' and optionally a--- 'Type' and an 'Id' (for 'spaninfoType' and 'spaninfoVar'--- respectively)-spanInfoFromRealSrcSpan :: RealSrcSpan -> Maybe Type -> Maybe Id -> SpanInfo-spanInfoFromRealSrcSpan spn mty mvar =- SpanInfo spn mty mvar---- | Convenience wrapper around 'spanInfoFromRealSrcSpan' which needs--- only a 'RealSrcSpan'-spanInfoFromRealSrcSpan' :: RealSrcSpan -> SpanInfo-spanInfoFromRealSrcSpan' s = spanInfoFromRealSrcSpan s Nothing Nothing---- | Convenience wrapper around 'srcSpanFile' which results in a 'FilePath'-srcSpanFilePath :: RealSrcSpan -> FilePath-srcSpanFilePath = unpackFS . srcSpanFile---- | Try to find the location of the given identifier at the given--- position in the module.-findLoc :: GhcMonad m- => Map ModuleName ModInfo- -> RealSrcSpan- -> String- -> ExceptT SDoc m (ModInfo,Name,SrcSpan)-findLoc infos span0 string = do- name <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $- guessModule infos (srcSpanFilePath span0)-- info <- maybeToExceptT "No module info for current file! Try loading it?" $- MaybeT $ pure $ M.lookup name infos-- name' <- findName infos span0 info string-- case getSrcSpan name' of- UnhelpfulSpan{} -> do- throwE ("Found a name, but no location information." <+>- "The module is:" <+>- maybe "<unknown>" (ppr . moduleName)- (nameModule_maybe name'))-- span' -> return (info,name',span')---- | Find any uses of the given identifier in the codebase.-findNameUses :: (GhcMonad m)- => Map ModuleName ModInfo- -> RealSrcSpan- -> String- -> ExceptT SDoc m [SrcSpan]-findNameUses infos span0 string =- locToSpans <$> findLoc infos span0 string- where- locToSpans (modinfo,name',span') =- stripSurrounding (span' : map toSrcSpan spans)- where- toSrcSpan = RealSrcSpan . spaninfoSrcSpan- spans = filter ((== Just name') . fmap getName . spaninfoVar)- (modinfoSpans modinfo)---- | Filter out redundant spans which surround/contain other spans.-stripSurrounding :: [SrcSpan] -> [SrcSpan]-stripSurrounding xs = filter (not . isRedundant) xs- where- isRedundant x = any (x `strictlyContains`) xs-- (RealSrcSpan s1) `strictlyContains` (RealSrcSpan s2)- = s1 /= s2 && s1 `containsSpan` s2- _ `strictlyContains` _ = False---- | Try to resolve the name located at the given position, or--- otherwise resolve based on the current module's scope.-findName :: GhcMonad m- => Map ModuleName ModInfo- -> RealSrcSpan- -> ModInfo- -> String- -> ExceptT SDoc m Name-findName infos span0 mi string =- case resolveName (modinfoSpans mi) (spanInfoFromRealSrcSpan' span0) of- Nothing -> tryExternalModuleResolution- Just name ->- case getSrcSpan name of- UnhelpfulSpan {} -> tryExternalModuleResolution- RealSrcSpan {} -> return (getName name)- where- tryExternalModuleResolution =- case find (matchName $ mkFastString string)- (fromMaybe [] (modInfoTopLevelScope (modinfoInfo mi))) of- Nothing -> throwE "Couldn't resolve to any modules."- Just imported -> resolveNameFromModule infos imported-- matchName :: FastString -> Name -> Bool- matchName str name =- str ==- occNameFS (getOccName name)---- | Try to resolve the name from another (loaded) module's exports.-resolveNameFromModule :: GhcMonad m- => Map ModuleName ModInfo- -> Name- -> ExceptT SDoc m Name-resolveNameFromModule infos name = do- modL <- maybe (throwE $ "No module for" <+> ppr name) return $- nameModule_maybe name-- info <- maybe (throwE (ppr (moduleUnitId modL) <> ":" <>- ppr modL)) return $- M.lookup (moduleName modL) infos-- maybe (throwE "No matching export in any local modules.") return $- find (matchName name) (modInfoExports (modinfoInfo info))- where- matchName :: Name -> Name -> Bool- matchName x y = occNameFS (getOccName x) ==- occNameFS (getOccName y)---- | Try to resolve the type display from the given span.-resolveName :: [SpanInfo] -> SpanInfo -> Maybe Var-resolveName spans' si = listToMaybe $ mapMaybe spaninfoVar $- reverse spans' `spaninfosWithin` si---- | Try to find the type of the given span.-findType :: GhcMonad m- => Map ModuleName ModInfo- -> RealSrcSpan- -> String- -> ExceptT SDoc m (ModInfo, Type)-findType infos span0 string = do- name <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $- guessModule infos (srcSpanFilePath span0)-- info <- maybeToExceptT "No module info for current file! Try loading it?" $- MaybeT $ pure $ M.lookup name infos-- case resolveType (modinfoSpans info) (spanInfoFromRealSrcSpan' span0) of- Nothing -> (,) info <$> lift (exprType TM_Inst string)- Just ty -> return (info, ty)- where- -- | Try to resolve the type display from the given span.- resolveType :: [SpanInfo] -> SpanInfo -> Maybe Type- resolveType spans' si = listToMaybe $ mapMaybe spaninfoType $- reverse spans' `spaninfosWithin` si---- | Guess a module name from a file path.-guessModule :: GhcMonad m- => Map ModuleName ModInfo -> FilePath -> MaybeT m ModuleName-guessModule infos fp = do- target <- lift $ guessTarget fp Nothing- case targetId target of- TargetModule mn -> return mn- TargetFile fp' _ -> guessModule' fp'- where- guessModule' :: GhcMonad m => FilePath -> MaybeT m ModuleName- guessModule' fp' = case findModByFp fp' of- Just mn -> return mn- Nothing -> do- fp'' <- liftIO (makeRelativeToCurrentDirectory fp')-- target' <- lift $ guessTarget fp'' Nothing- case targetId target' of- TargetModule mn -> return mn- _ -> MaybeT . pure $ findModByFp fp''-- findModByFp :: FilePath -> Maybe ModuleName- findModByFp fp' = fst <$> find ((Just fp' ==) . mifp) (M.toList infos)- where- mifp :: (ModuleName, ModInfo) -> Maybe FilePath- mifp = ml_hs_file . ms_location . modinfoSummary . snd----- | Collect type info data for the loaded modules.-collectInfo :: (GhcMonad m) => Map ModuleName ModInfo -> [ModuleName]- -> m (Map ModuleName ModInfo)-collectInfo ms loaded = do- df <- getDynFlags- liftIO (filterM cacheInvalid loaded) >>= \case- [] -> return ms- invalidated -> do- liftIO (putStrLn ("Collecting type info for " ++- show (length invalidated) ++- " module(s) ... "))-- foldM (go df) ms invalidated- where- go df m name = do { info <- getModInfo name; return (M.insert name info m) }- `gcatch`- (\(e :: SomeException) -> do- liftIO $ putStrLn- $ showSDocForUser df alwaysQualify- $ "Error while getting type info from" <+>- ppr name <> ":" <+> text (show e)- return m)-- cacheInvalid name = case M.lookup name ms of- Nothing -> return True- Just mi -> do- let fp = srcFilePath (modinfoSummary mi)- last' = modinfoLastUpdate mi- current <- getModificationTime fp- exists <- doesFileExist fp- if exists- then return $ current /= last'- else return True---- | Get the source file path from a ModSummary.--- If the .hs file is missing, and the .o file exists,--- we return the .o file path.-srcFilePath :: ModSummary -> FilePath-srcFilePath modSum = fromMaybe obj_fp src_fp- where- src_fp = ml_hs_file ms_loc- obj_fp = ml_obj_file ms_loc- ms_loc = ms_location modSum---- | Get info about the module: summary, types, etc.-getModInfo :: (GhcMonad m) => ModuleName -> m ModInfo-getModInfo name = do- m <- getModSummary name- p <- parseModule m- typechecked <- typecheckModule p- allTypes <- processAllTypeCheckedModule typechecked- let i = tm_checked_module_info typechecked- ts <- liftIO $ getModificationTime $ srcFilePath m- return (ModInfo m allTypes i ts)---- | Get ALL source spans in the module.-processAllTypeCheckedModule :: forall m . GhcMonad m => TypecheckedModule- -> m [SpanInfo]-processAllTypeCheckedModule tcm = do- bts <- mapM getTypeLHsBind $ listifyAllSpans tcs- ets <- mapM getTypeLHsExpr $ listifyAllSpans tcs- pts <- mapM getTypeLPat $ listifyAllSpans tcs- return $ mapMaybe toSpanInfo- $ sortBy cmpSpan- $ catMaybes (bts ++ ets ++ pts)- where- tcs = tm_typechecked_source tcm-- -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsBind's- getTypeLHsBind :: LHsBind GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))- getTypeLHsBind (dL->L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _})- = pure $ Just (Just (unLoc pid),getLoc pid,varType (unLoc pid))- getTypeLHsBind _ = pure Nothing-- -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsExpr's- getTypeLHsExpr :: LHsExpr GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))- getTypeLHsExpr e = do- hs_env <- getSession- (_,mbe) <- liftIO $ deSugarExpr hs_env e- return $ fmap (\expr -> (mid, getLoc e, CoreUtils.exprType expr)) mbe- where- mid :: Maybe Id- mid | HsVar _ (dL->L _ i) <- unwrapVar (unLoc e) = Just i- | otherwise = Nothing-- unwrapVar (HsWrap _ _ var) = var- unwrapVar e' = e'-- -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's- getTypeLPat :: LPat GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))- getTypeLPat (dL->L spn pat) =- pure (Just (getMaybeId pat,spn,hsPatType pat))- where- getMaybeId (VarPat _ (dL->L _ vid)) = Just vid- getMaybeId _ = Nothing-- -- | Get ALL source spans in the source.- listifyAllSpans :: (HasSrcSpan a , Typeable a) => TypecheckedSource -> [a]- listifyAllSpans = everythingAllSpans (++) [] ([] `mkQ` (\x -> [x | p x]))- where- p (dL->L spn _) = isGoodSrcSpan spn-- -- | Variant of @syb@'s @everything@ (which summarises all nodes- -- in top-down, left-to-right order) with a stop-condition on 'NameSet's- everythingAllSpans :: (r -> r -> r) -> r -> GenericQ r -> GenericQ r- everythingAllSpans k z f x- | (False `mkQ` (const True :: NameSet -> Bool)) x = z- | otherwise = foldl k (f x) (gmapQ (everythingAllSpans k z f) x)-- cmpSpan (_,a,_) (_,b,_)- | a `isSubspanOf` b = LT- | b `isSubspanOf` a = GT- | otherwise = EQ-- -- | Pretty print the types into a 'SpanInfo'.- toSpanInfo :: (Maybe Id,SrcSpan,Type) -> Maybe SpanInfo- toSpanInfo (n,RealSrcSpan spn,typ)- = Just $ spanInfoFromRealSrcSpan spn (Just typ) n- toSpanInfo _ = Nothing---- helper stolen from @syb@ package-type GenericQ r = forall a. Data a => a -> r--mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r-(r `mkQ` br) a = maybe r br (cast a)
− ghc/GHCi/UI/Monad.hs
@@ -1,553 +0,0 @@-{-# LANGUAGE CPP, FlexibleInstances, DeriveFunctor #-}-{-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-}--- -fno-cse is needed for GLOBAL_VAR's to behave properly------------------------------------------------------------------------------------- Monadery code used in InteractiveUI------ (c) The GHC Team 2005-2006-----------------------------------------------------------------------------------module GHCi.UI.Monad (- GHCi(..), startGHCi,- GHCiState(..), GhciMonad(..),- GHCiOption(..), isOptionSet, setOption, unsetOption,- Command(..), CommandResult(..), cmdSuccess,- LocalConfigBehaviour(..),- PromptFunction,- BreakLocation(..),- TickArray,- getDynFlags,-- runStmt, runDecls, runDecls', resume, recordBreak, revertCAFs,- ActionStats(..), runAndPrintStats, runWithStats, printStats,-- printForUserNeverQualify, printForUserModInfo,- printForUser, printForUserPartWay, prettyLocations,-- compileGHCiExpr,- initInterpBuffering,- turnOffBuffering, turnOffBuffering_,- flushInterpBuffers,- mkEvalWrapper- ) where--#include "HsVersions.h"--import GHCi.UI.Info (ModInfo)-import qualified GHC-import GhcMonad hiding (liftIO)-import Outputable hiding (printForUser, printForUserPartWay)-import qualified Outputable-import OccName-import DynFlags-import FastString-import HscTypes-import SrcLoc-import Module-import RdrName (mkOrig)-import PrelNames (gHC_GHCI_HELPERS)-import GHCi-import GHCi.RemoteTypes-import HsSyn (ImportDecl, GhcPs, GhciLStmt, LHsDecl)-import HsUtils-import Util--import Exception-import Numeric-import Data.Array-import Data.IORef-import Data.Time-import System.Environment-import System.IO-import Control.Monad-import Prelude hiding ((<>))--import System.Console.Haskeline (CompletionFunc, InputT)-import qualified System.Console.Haskeline as Haskeline-import Control.Monad.Trans.Class-import Control.Monad.IO.Class-import Data.Map.Strict (Map)-import qualified Data.IntMap.Strict as IntMap-import qualified GHC.LanguageExtensions as LangExt---------------------------------------------------------------------------------- GHCi monad--data GHCiState = GHCiState- {- progname :: String,- args :: [String],- evalWrapper :: ForeignHValue, -- ^ of type @IO a -> IO a@- prompt :: PromptFunction,- prompt_cont :: PromptFunction,- editor :: String,- stop :: String,- localConfig :: LocalConfigBehaviour,- options :: [GHCiOption],- line_number :: !Int, -- ^ input line- break_ctr :: !Int,- breaks :: !(IntMap.IntMap BreakLocation),- tickarrays :: ModuleEnv TickArray,- -- ^ 'tickarrays' caches the 'TickArray' for loaded modules,- -- so that we don't rebuild it each time the user sets- -- a breakpoint.- ghci_commands :: [Command],- -- ^ available ghci commands- ghci_macros :: [Command],- -- ^ user-defined macros- last_command :: Maybe Command,- -- ^ @:@ at the GHCi prompt repeats the last command, so we- -- remember it here- cmd_wrapper :: InputT GHCi CommandResult -> InputT GHCi (Maybe Bool),- -- ^ The command wrapper is run for each command or statement.- -- The 'Bool' value denotes whether the command is successful and- -- 'Nothing' means to exit GHCi.- cmdqueue :: [String],-- remembered_ctx :: [InteractiveImport],- -- ^ The imports that the user has asked for, via import- -- declarations and :module commands. This list is- -- persistent over :reloads (but any imports for modules- -- that are not loaded are temporarily ignored). After a- -- :load, all the home-package imports are stripped from- -- this list.- --- -- See bugs #2049, #1873, #1360-- transient_ctx :: [InteractiveImport],- -- ^ An import added automatically after a :load, usually of- -- the most recently compiled module. May be empty if- -- there are no modules loaded. This list is replaced by- -- :load, :reload, and :add. In between it may be modified- -- by :module.-- extra_imports :: [ImportDecl GhcPs],- -- ^ These are "always-on" imports, added to the- -- context regardless of what other imports we have.- -- This is useful for adding imports that are required- -- by setGHCiMonad. Be careful adding things here:- -- you can create ambiguities if these imports overlap- -- with other things in scope.- --- -- NB. although this is not currently used by GHCi itself,- -- it was added to support other front-ends that are based- -- on the GHCi code. Potentially we could also expose- -- this functionality via GHCi commands.-- prelude_imports :: [ImportDecl GhcPs],- -- ^ These imports are added to the context when- -- -XImplicitPrelude is on and we don't have a *-module- -- in the context. They can also be overridden by another- -- import for the same module, e.g.- -- "import Prelude hiding (map)"-- ghc_e :: Bool, -- ^ True if this is 'ghc -e' (or runghc)-- short_help :: String,- -- ^ help text to display to a user- long_help :: String,- lastErrorLocations :: IORef [(FastString, Int)],-- mod_infos :: !(Map ModuleName ModInfo),-- flushStdHandles :: ForeignHValue,- -- ^ @hFlush stdout; hFlush stderr@ in the interpreter- noBuffering :: ForeignHValue- -- ^ @hSetBuffering NoBuffering@ for stdin/stdout/stderr- }--type TickArray = Array Int [(GHC.BreakIndex,RealSrcSpan)]---- | A GHCi command-data Command- = Command- { cmdName :: String- -- ^ Name of GHCi command (e.g. "exit")- , cmdAction :: String -> InputT GHCi Bool- -- ^ The 'Bool' value denotes whether to exit GHCi- , cmdHidden :: Bool- -- ^ Commands which are excluded from default completion- -- and @:help@ summary. This is usually set for commands not- -- useful for interactive use but rather for IDEs.- , cmdCompletionFunc :: CompletionFunc GHCi- -- ^ 'CompletionFunc' for arguments- }--data CommandResult- = CommandComplete- { cmdInput :: String- , cmdResult :: Either SomeException (Maybe Bool)- , cmdStats :: ActionStats- }- | CommandIncomplete- -- ^ Unterminated multiline command- deriving Show--cmdSuccess :: Haskeline.MonadException m => CommandResult -> m (Maybe Bool)-cmdSuccess CommandComplete{ cmdResult = Left e } = liftIO $ throwIO e-cmdSuccess CommandComplete{ cmdResult = Right r } = return r-cmdSuccess CommandIncomplete = return $ Just True--type PromptFunction = [String]- -> Int- -> GHCi SDoc--data GHCiOption- = ShowTiming -- show time/allocs after evaluation- | ShowType -- show the type of expressions- | RevertCAFs -- revert CAFs after every evaluation- | Multiline -- use multiline commands- | CollectInfo -- collect and cache information about- -- modules after load- deriving Eq---- | Treatment of ./.ghci files. For now we either load or--- ignore. But later we could implement a "safe mode" where--- only safe operations are performed.----data LocalConfigBehaviour- = SourceLocalConfig- | IgnoreLocalConfig- deriving (Eq)--data BreakLocation- = BreakLocation- { breakModule :: !GHC.Module- , breakLoc :: !SrcSpan- , breakTick :: {-# UNPACK #-} !Int- , breakEnabled:: !Bool- , onBreakCmd :: String- }--instance Eq BreakLocation where- loc1 == loc2 = breakModule loc1 == breakModule loc2 &&- breakTick loc1 == breakTick loc2--prettyLocations :: IntMap.IntMap BreakLocation -> SDoc-prettyLocations locs =- case IntMap.null locs of- True -> text "No active breakpoints."- False -> vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ IntMap.toAscList locs--instance Outputable BreakLocation where- ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+> pprEnaDisa <+>- if null (onBreakCmd loc)- then Outputable.empty- else doubleQuotes (text (onBreakCmd loc))- where pprEnaDisa = case breakEnabled loc of- True -> text "enabled"- False -> text "disabled"--recordBreak- :: GhciMonad m => BreakLocation -> m (Bool{- was already present -}, Int)-recordBreak brkLoc = do- st <- getGHCiState- let oldmap = breaks st- oldActiveBreaks = IntMap.assocs oldmap- -- don't store the same break point twice- case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of- (nm:_) -> return (True, nm)- [] -> do- let oldCounter = break_ctr st- newCounter = oldCounter + 1- setGHCiState $ st { break_ctr = newCounter,- breaks = IntMap.insert oldCounter brkLoc oldmap- }- return (False, oldCounter)--newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }- deriving (Functor)--reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a-reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s--startGHCi :: GHCi a -> GHCiState -> Ghc a-startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref--instance Applicative GHCi where- pure a = GHCi $ \_ -> pure a- (<*>) = ap--instance Monad GHCi where- (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s--class GhcMonad m => GhciMonad m where- getGHCiState :: m GHCiState- setGHCiState :: GHCiState -> m ()- modifyGHCiState :: (GHCiState -> GHCiState) -> m ()- reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> m a--instance GhciMonad GHCi where- getGHCiState = GHCi $ \r -> liftIO $ readIORef r- setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s- modifyGHCiState f = GHCi $ \r -> liftIO $ modifyIORef r f- reifyGHCi f = GHCi $ \r -> reifyGhc $ \s -> f (s, r)--instance GhciMonad (InputT GHCi) where- getGHCiState = lift getGHCiState- setGHCiState = lift . setGHCiState- modifyGHCiState = lift . modifyGHCiState- reifyGHCi = lift . reifyGHCi--liftGhc :: Ghc a -> GHCi a-liftGhc m = GHCi $ \_ -> m--instance MonadIO GHCi where- liftIO = liftGhc . liftIO--instance HasDynFlags GHCi where- getDynFlags = getSessionDynFlags--instance GhcMonad GHCi where- setSession s' = liftGhc $ setSession s'- getSession = liftGhc $ getSession--instance HasDynFlags (InputT GHCi) where- getDynFlags = lift getDynFlags--instance GhcMonad (InputT GHCi) where- setSession = lift . setSession- getSession = lift getSession--instance ExceptionMonad GHCi where- gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)- gmask f =- GHCi $ \s -> gmask $ \io_restore ->- let- g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s')- in- unGHCi (f g_restore) s--instance Haskeline.MonadException Ghc where- controlIO f = Ghc $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let- run' = Haskeline.RunIO (fmap (Ghc . const) . run . flip unGhc s)- in fmap (flip unGhc s) $ f run'--instance Haskeline.MonadException GHCi where- controlIO f = GHCi $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let- run' = Haskeline.RunIO (fmap (GHCi . const) . run . flip unGHCi s)- in fmap (flip unGHCi s) $ f run'--instance ExceptionMonad (InputT GHCi) where- gcatch = Haskeline.catch- gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_)--isOptionSet :: GhciMonad m => GHCiOption -> m Bool-isOptionSet opt- = do st <- getGHCiState- return (opt `elem` options st)--setOption :: GhciMonad m => GHCiOption -> m ()-setOption opt- = do st <- getGHCiState- setGHCiState (st{ options = opt : filter (/= opt) (options st) })--unsetOption :: GhciMonad m => GHCiOption -> m ()-unsetOption opt- = do st <- getGHCiState- setGHCiState (st{ options = filter (/= opt) (options st) })--printForUserNeverQualify :: GhcMonad m => SDoc -> m ()-printForUserNeverQualify doc = do- dflags <- getDynFlags- liftIO $ Outputable.printForUser dflags stdout neverQualify doc--printForUserModInfo :: GhcMonad m => GHC.ModuleInfo -> SDoc -> m ()-printForUserModInfo info doc = do- dflags <- getDynFlags- mUnqual <- GHC.mkPrintUnqualifiedForModule info- unqual <- maybe GHC.getPrintUnqual return mUnqual- liftIO $ Outputable.printForUser dflags stdout unqual doc--printForUser :: GhcMonad m => SDoc -> m ()-printForUser doc = do- unqual <- GHC.getPrintUnqual- dflags <- getDynFlags- liftIO $ Outputable.printForUser dflags stdout unqual doc--printForUserPartWay :: GhcMonad m => SDoc -> m ()-printForUserPartWay doc = do- unqual <- GHC.getPrintUnqual- dflags <- getDynFlags- liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc---- | Run a single Haskell expression-runStmt- :: GhciMonad m- => GhciLStmt GhcPs -> String -> GHC.SingleStep -> m (Maybe GHC.ExecResult)-runStmt stmt stmt_text step = do- st <- getGHCiState- GHC.handleSourceError (\e -> do GHC.printException e; return Nothing) $ do- let opts = GHC.execOptions- { GHC.execSourceFile = progname st- , GHC.execLineNumber = line_number st- , GHC.execSingleStep = step- , GHC.execWrap = \fhv -> EvalApp (EvalThis (evalWrapper st))- (EvalThis fhv) }- Just <$> GHC.execStmt' stmt stmt_text opts--runDecls :: GhciMonad m => String -> m (Maybe [GHC.Name])-runDecls decls = do- st <- getGHCiState- reifyGHCi $ \x ->- withProgName (progname st) $- withArgs (args st) $- reflectGHCi x $ do- GHC.handleSourceError (\e -> do GHC.printException e;- return Nothing) $ do- r <- GHC.runDeclsWithLocation (progname st) (line_number st) decls- return (Just r)--runDecls' :: GhciMonad m => [LHsDecl GhcPs] -> m (Maybe [GHC.Name])-runDecls' decls = do- st <- getGHCiState- reifyGHCi $ \x ->- withProgName (progname st) $- withArgs (args st) $- reflectGHCi x $- GHC.handleSourceError- (\e -> do GHC.printException e;- return Nothing)- (Just <$> GHC.runParsedDecls decls)--resume :: GhciMonad m => (SrcSpan -> Bool) -> GHC.SingleStep -> m GHC.ExecResult-resume canLogSpan step = do- st <- getGHCiState- reifyGHCi $ \x ->- withProgName (progname st) $- withArgs (args st) $- reflectGHCi x $ do- GHC.resumeExec canLogSpan step---- ----------------------------------------------------------------------------- timing & statistics--data ActionStats = ActionStats- { actionAllocs :: Maybe Integer- , actionElapsedTime :: Double- } deriving Show--runAndPrintStats- :: GhciMonad m- => (a -> Maybe Integer)- -> m a- -> m (ActionStats, Either SomeException a)-runAndPrintStats getAllocs action = do- result <- runWithStats getAllocs action- case result of- (stats, Right{}) -> do- showTiming <- isOptionSet ShowTiming- when showTiming $ do- dflags <- getDynFlags- liftIO $ printStats dflags stats- _ -> return ()- return result--runWithStats- :: ExceptionMonad m- => (a -> Maybe Integer) -> m a -> m (ActionStats, Either SomeException a)-runWithStats getAllocs action = do- t0 <- liftIO getCurrentTime- result <- gtry action- let allocs = either (const Nothing) getAllocs result- t1 <- liftIO getCurrentTime- let elapsedTime = realToFrac $ t1 `diffUTCTime` t0- return (ActionStats allocs elapsedTime, result)--printStats :: DynFlags -> ActionStats -> IO ()-printStats dflags ActionStats{actionAllocs = mallocs, actionElapsedTime = secs}- = do let secs_str = showFFloat (Just 2) secs- putStrLn (showSDoc dflags (- parens (text (secs_str "") <+> text "secs" <> comma <+>- case mallocs of- Nothing -> empty- Just allocs ->- text (separateThousands allocs) <+> text "bytes")))- where- separateThousands n = reverse . sep . reverse . show $ n- where sep n'- | n' `lengthAtMost` 3 = n'- | otherwise = take 3 n' ++ "," ++ sep (drop 3 n')---------------------------------------------------------------------------------- reverting CAFs--revertCAFs :: GhciMonad m => m ()-revertCAFs = do- hsc_env <- GHC.getSession- liftIO $ iservCmd hsc_env RtsRevertCAFs- s <- getGHCiState- when (not (ghc_e s)) turnOffBuffering- -- Have to turn off buffering again, because we just- -- reverted stdout, stderr & stdin to their defaults.----------------------------------------------------------------------------------- To flush buffers for the *interpreted* computation we need--- to refer to *its* stdout/stderr handles---- | Compile "hFlush stdout; hFlush stderr" once, so we can use it repeatedly-initInterpBuffering :: Ghc (ForeignHValue, ForeignHValue)-initInterpBuffering = do- let mkHelperExpr :: OccName -> Ghc ForeignHValue- mkHelperExpr occ =- GHC.compileParsedExprRemote- $ GHC.nlHsVar $ RdrName.mkOrig gHC_GHCI_HELPERS occ- nobuf <- mkHelperExpr $ mkVarOcc "disableBuffering"- flush <- mkHelperExpr $ mkVarOcc "flushAll"- return (nobuf, flush)---- | Invoke "hFlush stdout; hFlush stderr" in the interpreter-flushInterpBuffers :: GhciMonad m => m ()-flushInterpBuffers = do- st <- getGHCiState- hsc_env <- GHC.getSession- liftIO $ evalIO hsc_env (flushStdHandles st)---- | Turn off buffering for stdin, stdout, and stderr in the interpreter-turnOffBuffering :: GhciMonad m => m ()-turnOffBuffering = do- st <- getGHCiState- turnOffBuffering_ (noBuffering st)--turnOffBuffering_ :: GhcMonad m => ForeignHValue -> m ()-turnOffBuffering_ fhv = do- hsc_env <- getSession- liftIO $ evalIO hsc_env fhv--mkEvalWrapper :: GhcMonad m => String -> [String] -> m ForeignHValue-mkEvalWrapper progname args =- runInternal $ GHC.compileParsedExprRemote- $ evalWrapper `GHC.mkHsApp` nlHsString progname- `GHC.mkHsApp` nlList (map nlHsString args)- where- nlHsString = nlHsLit . mkHsString- evalWrapper =- GHC.nlHsVar $ RdrName.mkOrig gHC_GHCI_HELPERS (mkVarOcc "evalWrapper")---- | Run a 'GhcMonad' action to compile an expression for internal usage.-runInternal :: GhcMonad m => m a -> m a-runInternal =- withTempSession mkTempSession- where- mkTempSession hsc_env = hsc_env- { hsc_dflags = (hsc_dflags hsc_env) {- -- Running GHCi's internal expression is incompatible with -XSafe.- -- We temporarily disable any Safe Haskell settings while running- -- GHCi internal expressions. (see #12509)- safeHaskell = Sf_None- }- -- RebindableSyntax can wreak havoc with GHCi in several ways- -- (see #13385 and #14342 for examples), so we temporarily- -- disable it too.- `xopt_unset` LangExt.RebindableSyntax- -- We heavily depend on -fimplicit-import-qualified to compile expr- -- with fully qualified names without imports.- `gopt_set` Opt_ImplicitImportQualified- }--compileGHCiExpr :: GhcMonad m => String -> m ForeignHValue-compileGHCiExpr expr = runInternal $ GHC.compileExprRemote expr
− ghc/GHCi/UI/Tags.hs
@@ -1,216 +0,0 @@------------------------------------------------------------------------------------ GHCi's :ctags and :etags commands------ (c) The GHC Team 2005-2007-----------------------------------------------------------------------------------{-# OPTIONS_GHC -fno-warn-name-shadowing #-}-module GHCi.UI.Tags (- createCTagsWithLineNumbersCmd,- createCTagsWithRegExesCmd,- createETagsFileCmd-) where--import Exception-import GHC-import GHCi.UI.Monad-import Outputable---- ToDo: figure out whether we need these, and put something appropriate--- into the GHC API instead-import Name (nameOccName)-import OccName (pprOccName)-import ConLike-import MonadUtils--import Control.Monad-import Data.Function-import Data.List-import Data.Maybe-import Data.Ord-import DriverPhases-import Panic-import Prelude-import System.Directory-import System.IO-import System.IO.Error---------------------------------------------------------------------------------- create tags file for currently loaded modules.--createCTagsWithLineNumbersCmd, createCTagsWithRegExesCmd,- createETagsFileCmd :: String -> GHCi ()--createCTagsWithLineNumbersCmd "" =- ghciCreateTagsFile CTagsWithLineNumbers "tags"-createCTagsWithLineNumbersCmd file =- ghciCreateTagsFile CTagsWithLineNumbers file--createCTagsWithRegExesCmd "" =- ghciCreateTagsFile CTagsWithRegExes "tags"-createCTagsWithRegExesCmd file =- ghciCreateTagsFile CTagsWithRegExes file--createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"-createETagsFileCmd file = ghciCreateTagsFile ETags file--data TagsKind = ETags | CTagsWithLineNumbers | CTagsWithRegExes--ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()-ghciCreateTagsFile kind file = do- createTagsFile kind file---- ToDo:--- - remove restriction that all modules must be interpreted--- (problem: we don't know source locations for entities unless--- we compiled the module.------ - extract createTagsFile so it can be used from the command-line--- (probably need to fix first problem before this is useful).----createTagsFile :: TagsKind -> FilePath -> GHCi ()-createTagsFile tagskind tagsFile = do- graph <- GHC.getModuleGraph- mtags <- mapM listModuleTags (map GHC.ms_mod $ GHC.mgModSummaries graph)- either_res <- liftIO $ collateAndWriteTags tagskind tagsFile $ concat mtags- case either_res of- Left e -> liftIO $ hPutStrLn stderr $ ioeGetErrorString e- Right _ -> return ()---listModuleTags :: GHC.Module -> GHCi [TagInfo]-listModuleTags m = do- is_interpreted <- GHC.moduleIsInterpreted m- -- should we just skip these?- when (not is_interpreted) $- let mName = GHC.moduleNameString (GHC.moduleName m) in- throwGhcException (CmdLineError ("module '" ++ mName ++ "' is not interpreted"))- mbModInfo <- GHC.getModuleInfo m- case mbModInfo of- Nothing -> return []- Just mInfo -> do- dflags <- getDynFlags- mb_print_unqual <- GHC.mkPrintUnqualifiedForModule mInfo- let unqual = fromMaybe GHC.alwaysQualify mb_print_unqual- let names = fromMaybe [] $GHC.modInfoTopLevelScope mInfo- let localNames = filter ((m==) . nameModule) names- mbTyThings <- mapM GHC.lookupName localNames- return $! [ tagInfo dflags unqual exported kind name realLoc- | tyThing <- catMaybes mbTyThings- , let name = getName tyThing- , let exported = GHC.modInfoIsExportedName mInfo name- , let kind = tyThing2TagKind tyThing- , let loc = srcSpanStart (nameSrcSpan name)- , RealSrcLoc realLoc <- [loc]- ]-- where- tyThing2TagKind (AnId _) = 'v'- tyThing2TagKind (AConLike RealDataCon{}) = 'd'- tyThing2TagKind (AConLike PatSynCon{}) = 'p'- tyThing2TagKind (ATyCon _) = 't'- tyThing2TagKind (ACoAxiom _) = 'x'---data TagInfo = TagInfo- { tagExported :: Bool -- is tag exported- , tagKind :: Char -- tag kind- , tagName :: String -- tag name- , tagFile :: String -- file name- , tagLine :: Int -- line number- , tagCol :: Int -- column number- , tagSrcInfo :: Maybe (String,Integer) -- source code line and char offset- }----- get tag info, for later translation into Vim or Emacs style-tagInfo :: DynFlags -> PrintUnqualified -> Bool -> Char -> Name -> RealSrcLoc- -> TagInfo-tagInfo dflags unqual exported kind name loc- = TagInfo exported kind- (showSDocForUser dflags unqual $ pprOccName (nameOccName name))- (showSDocForUser dflags unqual $ ftext (srcLocFile loc))- (srcLocLine loc) (srcLocCol loc) Nothing---- throw an exception when someone tries to overwrite existing source file (fix for #10989)-writeTagsSafely :: FilePath -> String -> IO ()-writeTagsSafely file str = do- dfe <- doesFileExist file- if dfe && isSourceFilename file- then throwGhcException (CmdLineError (file ++ " is existing source file. " ++- "Please specify another file name to store tags data"))- else writeFile file str--collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())--- ctags style with the Ex expression being just the line number, Vim et al-collateAndWriteTags CTagsWithLineNumbers file tagInfos = do- let tags = unlines $ sort $ map showCTag tagInfos- tryIO (writeTagsSafely file tags)---- ctags style with the Ex expression being a regex searching the line, Vim et al-collateAndWriteTags CTagsWithRegExes file tagInfos = do -- ctags style, Vim et al- tagInfoGroups <- makeTagGroupsWithSrcInfo tagInfos- let tags = unlines $ sort $ map showCTag $concat tagInfoGroups- tryIO (writeTagsSafely file tags)--collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs- tagInfoGroups <- makeTagGroupsWithSrcInfo $filter tagExported tagInfos- let tagGroups = map processGroup tagInfoGroups- tryIO (writeTagsSafely file $ concat tagGroups)-- where- processGroup [] = throwGhcException (CmdLineError "empty tag file group??")- processGroup group@(tagInfo:_) =- let tags = unlines $ map showETag group in- "\x0c\n" ++ tagFile tagInfo ++ "," ++ show (length tags) ++ "\n" ++ tags---makeTagGroupsWithSrcInfo :: [TagInfo] -> IO [[TagInfo]]-makeTagGroupsWithSrcInfo tagInfos = do- let groups = groupBy ((==) `on` tagFile) $ sortBy (comparing tagFile) tagInfos- mapM addTagSrcInfo groups-- where- addTagSrcInfo [] = throwGhcException (CmdLineError "empty tag file group??")- addTagSrcInfo group@(tagInfo:_) = do- file <- readFile $tagFile tagInfo- let sortedGroup = sortBy (comparing tagLine) group- return $ perFile sortedGroup 1 0 $ lines file-- perFile allTags@(tag:tags) cnt pos allLs@(l:ls)- | tagLine tag > cnt =- perFile allTags (cnt+1) (pos+fromIntegral(length l)) ls- | tagLine tag == cnt =- tag{ tagSrcInfo = Just(l,pos) } : perFile tags cnt pos allLs- perFile _ _ _ _ = []----- ctags format, for Vim et al-showCTag :: TagInfo -> String-showCTag ti =- tagName ti ++ "\t" ++ tagFile ti ++ "\t" ++ tagCmd ++ ";\"\t" ++- tagKind ti : ( if tagExported ti then "" else "\tfile:" )-- where- tagCmd =- case tagSrcInfo ti of- Nothing -> show $tagLine ti- Just (srcLine,_) -> "/^"++ foldr escapeSlashes [] srcLine ++"$/"-- where- escapeSlashes '/' r = '\\' : '/' : r- escapeSlashes '\\' r = '\\' : '\\' : r- escapeSlashes c r = c : r----- etags format, for Emacs/XEmacs-showETag :: TagInfo -> String-showETag TagInfo{ tagName = tag, tagLine = lineNo, tagCol = colNo,- tagSrcInfo = Just (srcLine,charPos) }- = take (colNo - 1) srcLine ++ tag- ++ "\x7f" ++ tag- ++ "\x01" ++ show lineNo- ++ "," ++ show charPos-showETag _ = throwGhcException (CmdLineError "missing source file info in showETag")
− ghc/GHCi/Util.hs
@@ -1,16 +0,0 @@-{-# LANGUAGE MagicHash, UnboxedTuples #-}---- | Utilities for GHCi.-module GHCi.Util where---- NOTE: Avoid importing GHC modules here, because the primary purpose--- of this module is to not use UnboxedTuples in a module that imports--- lots of other modules. See issue#13101 for more info.--import GHC.Exts-import GHC.Types--anyToPtr :: a -> IO (Ptr ())-anyToPtr x =- IO (\s -> case anyToAddr# x s of- (# s', addr #) -> (# s', Ptr addr #)) :: IO (Ptr ())
− ghc/Main.hs
@@ -1,966 +0,0 @@-{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections #-}-{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}------------------------------------------------------------------------------------- GHC Driver program------ (c) The University of Glasgow 2005-----------------------------------------------------------------------------------module Main (main) where---- The official GHC API-import qualified GHC-import GHC ( -- DynFlags(..), HscTarget(..),- -- GhcMode(..), GhcLink(..),- Ghc, GhcMonad(..),- LoadHowMuch(..) )-import CmdLineParser---- Implementations of the various modes (--show-iface, mkdependHS. etc.)-import LoadIface ( showIface )-import HscMain ( newHscEnv )-import DriverPipeline ( oneShot, compileFile )-import DriverMkDepend ( doMkDependHS )-import DriverBkp ( doBackpack )-#if defined(HAVE_INTERNAL_INTERPRETER)-import GHCi.UI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings )-#endif---- Frontend plugins-#if defined(HAVE_INTERPRETER)-import DynamicLoading ( loadFrontendPlugin )-import Plugins-#else-import DynamicLoading ( pluginError )-#endif-#if defined(HAVE_INTERNAL_INTERPRETER)-import DynamicLoading ( initializePlugins )-#endif-import Module ( ModuleName )----- Various other random stuff that we need-import GHC.HandleEncoding-import Config-import Constants-import HscTypes-import Packages ( pprPackages, pprPackagesSimple )-import DriverPhases-import BasicTypes ( failed )-import DynFlags hiding (WarnReason(..))-import ErrUtils-import FastString-import Outputable-import SrcLoc-import Util-import Panic-import UniqSupply-import MonadUtils ( liftIO )---- Imports for --abi-hash-import LoadIface ( loadUserInterface )-import Module ( mkModuleName )-import Finder ( findImportedModule, cannotFindModule )-import TcRnMonad ( initIfaceCheck )-import Binary ( openBinMem, put_ )-import BinFingerprint ( fingerprintBinMem )---- Standard Haskell libraries-import System.IO-import System.Environment-import System.Exit-import System.FilePath-import Control.Monad-import Data.Char-import Data.List-import Data.Maybe-import Prelude---------------------------------------------------------------------------------- ToDo:---- time commands when run with -v--- user ways--- Win32 support: proper signal handling--- reading the package configuration file is too slow--- -K<size>---------------------------------------------------------------------------------- GHC's command-line interface--main :: IO ()-main = do- initGCStatistics -- See Note [-Bsymbolic and hooks]- hSetBuffering stdout LineBuffering- hSetBuffering stderr LineBuffering-- configureHandleEncoding- GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do- -- 1. extract the -B flag from the args- argv0 <- getArgs-- let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0- mbMinusB | null minusB_args = Nothing- | otherwise = Just (drop 2 (last minusB_args))-- let argv2 = map (mkGeneralLocated "on the commandline") argv1-- -- 2. Parse the "mode" flags (--make, --interactive etc.)- (mode, argv3, flagWarnings) <- parseModeFlags argv2-- -- If all we want to do is something like showing the version number- -- then do it now, before we start a GHC session etc. This makes- -- getting basic information much more resilient.-- -- In particular, if we wait until later before giving the version- -- number then bootstrapping gets confused, as it tries to find out- -- what version of GHC it's using before package.conf exists, so- -- starting the session fails.- case mode of- Left preStartupMode ->- do case preStartupMode of- ShowSupportedExtensions -> showSupportedExtensions- ShowVersion -> showVersion- ShowNumVersion -> putStrLn cProjectVersion- ShowOptions isInteractive -> showOptions isInteractive- Right postStartupMode ->- -- start our GHC session- GHC.runGhc mbMinusB $ do-- dflags <- GHC.getSessionDynFlags-- case postStartupMode of- Left preLoadMode ->- liftIO $ do- case preLoadMode of- ShowInfo -> showInfo dflags- ShowGhcUsage -> showGhcUsage dflags- ShowGhciUsage -> showGhciUsage dflags- PrintWithDynFlags f -> putStrLn (f dflags)- Right postLoadMode ->- main' postLoadMode dflags argv3 flagWarnings--main' :: PostLoadMode -> DynFlags -> [Located String] -> [Warn]- -> Ghc ()-main' postLoadMode dflags0 args flagWarnings = do- -- set the default GhcMode, HscTarget and GhcLink. The HscTarget- -- can be further adjusted on a module by module basis, using only- -- the -fvia-C and -fasm flags. If the default HscTarget is not- -- HscC or HscAsm, -fvia-C and -fasm have no effect.- let dflt_target = hscTarget dflags0- (mode, lang, link)- = case postLoadMode of- DoInteractive -> (CompManager, HscInterpreted, LinkInMemory)- DoEval _ -> (CompManager, HscInterpreted, LinkInMemory)- DoMake -> (CompManager, dflt_target, LinkBinary)- DoBackpack -> (CompManager, dflt_target, LinkBinary)- DoMkDependHS -> (MkDepend, dflt_target, LinkBinary)- DoAbiHash -> (OneShot, dflt_target, LinkBinary)- _ -> (OneShot, dflt_target, LinkBinary)-- let dflags1 = dflags0{ ghcMode = mode,- hscTarget = lang,- ghcLink = link,- verbosity = case postLoadMode of- DoEval _ -> 0- _other -> 1- }-- -- turn on -fimplicit-import-qualified for GHCi now, so that it- -- can be overriden from the command-line- -- XXX: this should really be in the interactive DynFlags, but- -- we don't set that until later in interactiveUI- -- We also set -fignore-optim-changes and -fignore-hpc-changes,- -- which are program-level options. Again, this doesn't really- -- feel like the right place to handle this, but we don't have- -- a great story for the moment.- dflags2 | DoInteractive <- postLoadMode = def_ghci_flags- | DoEval _ <- postLoadMode = def_ghci_flags- | otherwise = dflags1- where def_ghci_flags = dflags1 `gopt_set` Opt_ImplicitImportQualified- `gopt_set` Opt_IgnoreOptimChanges- `gopt_set` Opt_IgnoreHpcChanges-- -- The rest of the arguments are "dynamic"- -- Leftover ones are presumably files- (dflags3, fileish_args, dynamicFlagWarnings) <-- GHC.parseDynamicFlags dflags2 args-- let dflags4 = case lang of- HscInterpreted | not (gopt Opt_ExternalInterpreter dflags3) ->- let platform = targetPlatform dflags3- dflags3a = updateWays $ dflags3 { ways = interpWays }- dflags3b = foldl gopt_set dflags3a- $ concatMap (wayGeneralFlags platform)- interpWays- dflags3c = foldl gopt_unset dflags3b- $ concatMap (wayUnsetGeneralFlags platform)- interpWays- in dflags3c- _ ->- dflags3-- GHC.prettyPrintGhcErrors dflags4 $ do-- let flagWarnings' = flagWarnings ++ dynamicFlagWarnings-- handleSourceError (\e -> do- GHC.printException e- liftIO $ exitWith (ExitFailure 1)) $ do- liftIO $ handleFlagWarnings dflags4 flagWarnings'-- liftIO $ showBanner postLoadMode dflags4-- let- -- To simplify the handling of filepaths, we normalise all filepaths right- -- away. Note the asymmetry of FilePath.normalise:- -- Linux: p/q -> p/q; p\q -> p\q- -- Windows: p/q -> p\q; p\q -> p\q- -- #12674: Filenames starting with a hypen get normalised from ./-foo.hs- -- to -foo.hs. We have to re-prepend the current directory.- normalise_hyp fp- | strt_dot_sl && "-" `isPrefixOf` nfp = cur_dir ++ nfp- | otherwise = nfp- where-#if defined(mingw32_HOST_OS)- strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp-#else- strt_dot_sl = "./" `isPrefixOf` fp-#endif- cur_dir = '.' : [pathSeparator]- nfp = normalise fp- normal_fileish_paths = map (normalise_hyp . unLoc) fileish_args- (srcs, objs) = partition_args normal_fileish_paths [] []-- dflags5 = dflags4 { ldInputs = map (FileOption "") objs- ++ ldInputs dflags4 }-- -- we've finished manipulating the DynFlags, update the session- _ <- GHC.setSessionDynFlags dflags5- dflags6 <- GHC.getSessionDynFlags- hsc_env <- GHC.getSession-- ---------------- Display configuration ------------ case verbosity dflags6 of- v | v == 4 -> liftIO $ dumpPackagesSimple dflags6- | v >= 5 -> liftIO $ dumpPackages dflags6- | otherwise -> return ()-- liftIO $ initUniqSupply (initialUnique dflags6) (uniqueIncrement dflags6)- ---------------- Final sanity checking ------------ liftIO $ checkOptions postLoadMode dflags6 srcs objs-- ---------------- Do the business ------------ handleSourceError (\e -> do- GHC.printException e- liftIO $ exitWith (ExitFailure 1)) $ do- case postLoadMode of- ShowInterface f -> liftIO $ doShowIface dflags6 f- DoMake -> doMake srcs- DoMkDependHS -> doMkDependHS (map fst srcs)- StopBefore p -> liftIO (oneShot hsc_env p srcs)- DoInteractive -> ghciUI hsc_env dflags6 srcs Nothing- DoEval exprs -> ghciUI hsc_env dflags6 srcs $ Just $- reverse exprs- DoAbiHash -> abiHash (map fst srcs)- ShowPackages -> liftIO $ showPackages dflags6- DoFrontend f -> doFrontend f srcs- DoBackpack -> doBackpack (map fst srcs)-- liftIO $ dumpFinalStats dflags6--ghciUI :: HscEnv -> DynFlags -> [(FilePath, Maybe Phase)] -> Maybe [String]- -> Ghc ()-#if !defined(HAVE_INTERNAL_INTERPRETER)-ghciUI _ _ _ _ =- throwGhcException (CmdLineError "not built for interactive use")-#else-ghciUI hsc_env dflags0 srcs maybe_expr = do- dflags1 <- liftIO (initializePlugins hsc_env dflags0)- _ <- GHC.setSessionDynFlags dflags1- interactiveUI defaultGhciSettings srcs maybe_expr-#endif---- -------------------------------------------------------------------------------- Splitting arguments into source files and object files. This is where we--- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source--- file indicating the phase specified by the -x option in force, if any.--partition_args :: [String] -> [(String, Maybe Phase)] -> [String]- -> ([(String, Maybe Phase)], [String])-partition_args [] srcs objs = (reverse srcs, reverse objs)-partition_args ("-x":suff:args) srcs objs- | "none" <- suff = partition_args args srcs objs- | StopLn <- phase = partition_args args srcs (slurp ++ objs)- | otherwise = partition_args rest (these_srcs ++ srcs) objs- where phase = startPhase suff- (slurp,rest) = break (== "-x") args- these_srcs = zip slurp (repeat (Just phase))-partition_args (arg:args) srcs objs- | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs- | otherwise = partition_args args srcs (arg:objs)-- {-- We split out the object files (.o, .dll) and add them- to ldInputs for use by the linker.-- The following things should be considered compilation manager inputs:-- - haskell source files (strings ending in .hs, .lhs or other- haskellish extension),-- - module names (not forgetting hierarchical module names),-- - things beginning with '-' are flags that were not recognised by- the flag parser, and we want them to generate errors later in- checkOptions, so we class them as source files (#5921)-- - and finally we consider everything without an extension to be- a comp manager input, as shorthand for a .hs or .lhs filename.-- Everything else is considered to be a linker object, and passed- straight through to the linker.- -}-looks_like_an_input :: String -> Bool-looks_like_an_input m = isSourceFilename m- || looksLikeModuleName m- || "-" `isPrefixOf` m- || not (hasExtension m)---- -------------------------------------------------------------------------------- Option sanity checks---- | Ensure sanity of options.------ Throws 'UsageError' or 'CmdLineError' if not.-checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO ()- -- Final sanity checking before kicking off a compilation (pipeline).-checkOptions mode dflags srcs objs = do- -- Complain about any unknown flags- let unknown_opts = [ f | (f@('-':_), _) <- srcs ]- when (notNull unknown_opts) (unknownFlagsErr unknown_opts)-- when (notNull (filter wayRTSOnly (ways dflags))- && isInterpretiveMode mode) $- hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")-- -- -prof and --interactive are not a good combination- when ((filter (not . wayRTSOnly) (ways dflags) /= interpWays)- && isInterpretiveMode mode- && not (gopt Opt_ExternalInterpreter dflags)) $- do throwGhcException (UsageError- "-fexternal-interpreter is required when using --interactive with a non-standard way (-prof, -static, or -dynamic).")- -- -ohi sanity check- if (isJust (outputHi dflags) &&- (isCompManagerMode mode || srcs `lengthExceeds` 1))- then throwGhcException (UsageError "-ohi can only be used when compiling a single source file")- else do-- -- -o sanity checking- if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)- && not (isLinkMode mode))- then throwGhcException (UsageError "can't apply -o to multiple source files")- else do-- let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags)-- when (not_linking && not (null objs)) $- hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs)-- -- Check that there are some input files- -- (except in the interactive case)- if null srcs && (null objs || not_linking) && needsInputsMode mode- then throwGhcException (UsageError "no input files")- else do-- case mode of- StopBefore HCc | hscTarget dflags /= HscC- -> throwGhcException $ UsageError $- "the option -C is only available with an unregisterised GHC"- _ -> return ()-- -- Verify that output files point somewhere sensible.- verifyOutputFiles dflags---- Compiler output options---- Called to verify that the output files point somewhere valid.------ The assumption is that the directory portion of these output--- options will have to exist by the time 'verifyOutputFiles'--- is invoked.------ We create the directories for -odir, -hidir, -outputdir etc. ourselves if--- they don't exist, so don't check for those here (#2278).-verifyOutputFiles :: DynFlags -> IO ()-verifyOutputFiles dflags = do- let ofile = outputFile dflags- when (isJust ofile) $ do- let fn = fromJust ofile- flg <- doesDirNameExist fn- when (not flg) (nonExistentDir "-o" fn)- let ohi = outputHi dflags- when (isJust ohi) $ do- let hi = fromJust ohi- flg <- doesDirNameExist hi- when (not flg) (nonExistentDir "-ohi" hi)- where- nonExistentDir flg dir =- throwGhcException (CmdLineError ("error: directory portion of " ++- show dir ++ " does not exist (used with " ++- show flg ++ " option.)"))---------------------------------------------------------------------------------- GHC modes of operation--type Mode = Either PreStartupMode PostStartupMode-type PostStartupMode = Either PreLoadMode PostLoadMode--data PreStartupMode- = ShowVersion -- ghc -V/--version- | ShowNumVersion -- ghc --numeric-version- | ShowSupportedExtensions -- ghc --supported-extensions- | ShowOptions Bool {- isInteractive -} -- ghc --show-options--showVersionMode, showNumVersionMode, showSupportedExtensionsMode, showOptionsMode :: Mode-showVersionMode = mkPreStartupMode ShowVersion-showNumVersionMode = mkPreStartupMode ShowNumVersion-showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions-showOptionsMode = mkPreStartupMode (ShowOptions False)--mkPreStartupMode :: PreStartupMode -> Mode-mkPreStartupMode = Left--isShowVersionMode :: Mode -> Bool-isShowVersionMode (Left ShowVersion) = True-isShowVersionMode _ = False--isShowNumVersionMode :: Mode -> Bool-isShowNumVersionMode (Left ShowNumVersion) = True-isShowNumVersionMode _ = False--data PreLoadMode- = ShowGhcUsage -- ghc -?- | ShowGhciUsage -- ghci -?- | ShowInfo -- ghc --info- | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo--showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode-showGhcUsageMode = mkPreLoadMode ShowGhcUsage-showGhciUsageMode = mkPreLoadMode ShowGhciUsage-showInfoMode = mkPreLoadMode ShowInfo--printSetting :: String -> Mode-printSetting k = mkPreLoadMode (PrintWithDynFlags f)- where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))- $ lookup k (compilerInfo dflags)--mkPreLoadMode :: PreLoadMode -> Mode-mkPreLoadMode = Right . Left--isShowGhcUsageMode :: Mode -> Bool-isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True-isShowGhcUsageMode _ = False--isShowGhciUsageMode :: Mode -> Bool-isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True-isShowGhciUsageMode _ = False--data PostLoadMode- = ShowInterface FilePath -- ghc --show-iface- | DoMkDependHS -- ghc -M- | StopBefore Phase -- ghc -E | -C | -S- -- StopBefore StopLn is the default- | DoMake -- ghc --make- | DoBackpack -- ghc --backpack foo.bkp- | DoInteractive -- ghc --interactive- | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"]- | DoAbiHash -- ghc --abi-hash- | ShowPackages -- ghc --show-packages- | DoFrontend ModuleName -- ghc --frontend Plugin.Module--doMkDependHSMode, doMakeMode, doInteractiveMode,- doAbiHashMode, showPackagesMode :: Mode-doMkDependHSMode = mkPostLoadMode DoMkDependHS-doMakeMode = mkPostLoadMode DoMake-doInteractiveMode = mkPostLoadMode DoInteractive-doAbiHashMode = mkPostLoadMode DoAbiHash-showPackagesMode = mkPostLoadMode ShowPackages--showInterfaceMode :: FilePath -> Mode-showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)--stopBeforeMode :: Phase -> Mode-stopBeforeMode phase = mkPostLoadMode (StopBefore phase)--doEvalMode :: String -> Mode-doEvalMode str = mkPostLoadMode (DoEval [str])--doFrontendMode :: String -> Mode-doFrontendMode str = mkPostLoadMode (DoFrontend (mkModuleName str))--doBackpackMode :: Mode-doBackpackMode = mkPostLoadMode DoBackpack--mkPostLoadMode :: PostLoadMode -> Mode-mkPostLoadMode = Right . Right--isDoInteractiveMode :: Mode -> Bool-isDoInteractiveMode (Right (Right DoInteractive)) = True-isDoInteractiveMode _ = False--isStopLnMode :: Mode -> Bool-isStopLnMode (Right (Right (StopBefore StopLn))) = True-isStopLnMode _ = False--isDoMakeMode :: Mode -> Bool-isDoMakeMode (Right (Right DoMake)) = True-isDoMakeMode _ = False--isDoEvalMode :: Mode -> Bool-isDoEvalMode (Right (Right (DoEval _))) = True-isDoEvalMode _ = False--#if defined(HAVE_INTERNAL_INTERPRETER)-isInteractiveMode :: PostLoadMode -> Bool-isInteractiveMode DoInteractive = True-isInteractiveMode _ = False-#endif---- isInterpretiveMode: byte-code compiler involved-isInterpretiveMode :: PostLoadMode -> Bool-isInterpretiveMode DoInteractive = True-isInterpretiveMode (DoEval _) = True-isInterpretiveMode _ = False--needsInputsMode :: PostLoadMode -> Bool-needsInputsMode DoMkDependHS = True-needsInputsMode (StopBefore _) = True-needsInputsMode DoMake = True-needsInputsMode _ = False---- True if we are going to attempt to link in this mode.--- (we might not actually link, depending on the GhcLink flag)-isLinkMode :: PostLoadMode -> Bool-isLinkMode (StopBefore StopLn) = True-isLinkMode DoMake = True-isLinkMode DoInteractive = True-isLinkMode (DoEval _) = True-isLinkMode _ = False--isCompManagerMode :: PostLoadMode -> Bool-isCompManagerMode DoMake = True-isCompManagerMode DoInteractive = True-isCompManagerMode (DoEval _) = True-isCompManagerMode _ = False---- -------------------------------------------------------------------------------- Parsing the mode flag--parseModeFlags :: [Located String]- -> IO (Mode,- [Located String],- [Warn])-parseModeFlags args = do- let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =- runCmdLine (processArgs mode_flags args)- (Nothing, [], [])- mode = case mModeFlag of- Nothing -> doMakeMode- Just (m, _) -> m-- -- See Note [Handling errors when parsing commandline flags]- unless (null errs1 && null errs2) $ throwGhcException $ errorsToGhcException $- map (("on the commandline", )) $ map (unLoc . errMsg) errs1 ++ errs2-- return (mode, flags' ++ leftover, warns)--type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])- -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)- -- so we collect the new ones and return them.--mode_flags :: [Flag ModeM]-mode_flags =- [ ------- help / version ----------------------------------------------- defFlag "?" (PassFlag (setMode showGhcUsageMode))- , defFlag "-help" (PassFlag (setMode showGhcUsageMode))- , defFlag "V" (PassFlag (setMode showVersionMode))- , defFlag "-version" (PassFlag (setMode showVersionMode))- , defFlag "-numeric-version" (PassFlag (setMode showNumVersionMode))- , defFlag "-info" (PassFlag (setMode showInfoMode))- , defFlag "-show-options" (PassFlag (setMode showOptionsMode))- , defFlag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode))- , defFlag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))- , defFlag "-show-packages" (PassFlag (setMode showPackagesMode))- ] ++- [ defFlag k' (PassFlag (setMode (printSetting k)))- | k <- ["Project version",- "Project Git commit id",- "Booter version",- "Stage",- "Build platform",- "Host platform",- "Target platform",- "Have interpreter",- "Object splitting supported",- "Have native code generator",- "Support SMP",- "Unregisterised",- "Tables next to code",- "RTS ways",- "Leading underscore",- "Debug on",- "LibDir",- "Global Package DB",- "C compiler flags",- "C compiler link flags",- "ld flags"],- let k' = "-print-" ++ map (replaceSpace . toLower) k- replaceSpace ' ' = '-'- replaceSpace c = c- ] ++- ------- interfaces ----------------------------------------------------- [ defFlag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f)- "--show-iface"))-- ------- primary modes ------------------------------------------------- , defFlag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f- addFlag "-no-link" f))- , defFlag "M" (PassFlag (setMode doMkDependHSMode))- , defFlag "E" (PassFlag (setMode (stopBeforeMode anyHsc)))- , defFlag "C" (PassFlag (setMode (stopBeforeMode HCc)))- , defFlag "S" (PassFlag (setMode (stopBeforeMode (As False))))- , defFlag "-make" (PassFlag (setMode doMakeMode))- , defFlag "-backpack" (PassFlag (setMode doBackpackMode))- , defFlag "-interactive" (PassFlag (setMode doInteractiveMode))- , defFlag "-abi-hash" (PassFlag (setMode doAbiHashMode))- , defFlag "e" (SepArg (\s -> setMode (doEvalMode s) "-e"))- , defFlag "-frontend" (SepArg (\s -> setMode (doFrontendMode s) "-frontend"))- ]--setMode :: Mode -> String -> EwM ModeM ()-setMode newMode newFlag = liftEwM $ do- (mModeFlag, errs, flags') <- getCmdLineState- let (modeFlag', errs') =- case mModeFlag of- Nothing -> ((newMode, newFlag), errs)- Just (oldMode, oldFlag) ->- case (oldMode, newMode) of- -- -c/--make are allowed together, and mean --make -no-link- _ | isStopLnMode oldMode && isDoMakeMode newMode- || isStopLnMode newMode && isDoMakeMode oldMode ->- ((doMakeMode, "--make"), [])-- -- If we have both --help and --interactive then we- -- want showGhciUsage- _ | isShowGhcUsageMode oldMode &&- isDoInteractiveMode newMode ->- ((showGhciUsageMode, oldFlag), [])- | isShowGhcUsageMode newMode &&- isDoInteractiveMode oldMode ->- ((showGhciUsageMode, newFlag), [])-- -- If we have both -e and --interactive then -e always wins- _ | isDoEvalMode oldMode &&- isDoInteractiveMode newMode ->- ((oldMode, oldFlag), [])- | isDoEvalMode newMode &&- isDoInteractiveMode oldMode ->- ((newMode, newFlag), [])-- -- Otherwise, --help/--version/--numeric-version always win- | isDominantFlag oldMode -> ((oldMode, oldFlag), [])- | isDominantFlag newMode -> ((newMode, newFlag), [])- -- We need to accumulate eval flags like "-e foo -e bar"- (Right (Right (DoEval esOld)),- Right (Right (DoEval [eNew]))) ->- ((Right (Right (DoEval (eNew : esOld))), oldFlag),- errs)- -- Saying e.g. --interactive --interactive is OK- _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs)-- -- --interactive and --show-options are used together- (Right (Right DoInteractive), Left (ShowOptions _)) ->- ((Left (ShowOptions True),- "--interactive --show-options"), errs)- (Left (ShowOptions _), (Right (Right DoInteractive))) ->- ((Left (ShowOptions True),- "--show-options --interactive"), errs)- -- Otherwise, complain- _ -> let err = flagMismatchErr oldFlag newFlag- in ((oldMode, oldFlag), err : errs)- putCmdLineState (Just modeFlag', errs', flags')- where isDominantFlag f = isShowGhcUsageMode f ||- isShowGhciUsageMode f ||- isShowVersionMode f ||- isShowNumVersionMode f--flagMismatchErr :: String -> String -> String-flagMismatchErr oldFlag newFlag- = "cannot use `" ++ oldFlag ++ "' with `" ++ newFlag ++ "'"--addFlag :: String -> String -> EwM ModeM ()-addFlag s flag = liftEwM $ do- (m, e, flags') <- getCmdLineState- putCmdLineState (m, e, mkGeneralLocated loc s : flags')- where loc = "addFlag by " ++ flag ++ " on the commandline"---- ------------------------------------------------------------------------------- Run --make mode--doMake :: [(String,Maybe Phase)] -> Ghc ()-doMake srcs = do- let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs-- hsc_env <- GHC.getSession-- -- if we have no haskell sources from which to do a dependency- -- analysis, then just do one-shot compilation and/or linking.- -- This means that "ghc Foo.o Bar.o -o baz" links the program as- -- we expect.- if (null hs_srcs)- then liftIO (oneShot hsc_env StopLn srcs)- else do-- o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)- non_hs_srcs- dflags <- GHC.getSessionDynFlags- let dflags' = dflags { ldInputs = map (FileOption "") o_files- ++ ldInputs dflags }- _ <- GHC.setSessionDynFlags dflags'-- targets <- mapM (uncurry GHC.guessTarget) hs_srcs- GHC.setTargets targets- ok_flag <- GHC.load LoadAllTargets-- when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))- return ()----- ------------------------------------------------------------------------------ --show-iface mode--doShowIface :: DynFlags -> FilePath -> IO ()-doShowIface dflags file = do- hsc_env <- newHscEnv dflags- showIface hsc_env file---- ------------------------------------------------------------------------------ Various banners and verbosity output.--showBanner :: PostLoadMode -> DynFlags -> IO ()-showBanner _postLoadMode dflags = do- let verb = verbosity dflags--#if defined(HAVE_INTERNAL_INTERPRETER)- -- Show the GHCi banner- when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg-#endif-- -- Display details of the configuration in verbose mode- when (verb >= 2) $- do hPutStr stderr "Glasgow Haskell Compiler, Version "- hPutStr stderr cProjectVersion- hPutStr stderr ", stage "- hPutStr stderr cStage- hPutStr stderr " booted by GHC version "- hPutStrLn stderr cBooterVersion---- We print out a Read-friendly string, but a prettier one than the--- Show instance gives us-showInfo :: DynFlags -> IO ()-showInfo dflags = do- let sq x = " [" ++ x ++ "\n ]"- putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags--showSupportedExtensions :: IO ()-showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions--showVersion :: IO ()-showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion)--showOptions :: Bool -> IO ()-showOptions isInteractive = putStr (unlines availableOptions)- where- availableOptions = concat [- flagsForCompletion isInteractive,- map ('-':) (getFlagNames mode_flags)- ]- getFlagNames opts = map flagName opts--showGhcUsage :: DynFlags -> IO ()-showGhcUsage = showUsage False--showGhciUsage :: DynFlags -> IO ()-showGhciUsage = showUsage True--showUsage :: Bool -> DynFlags -> IO ()-showUsage ghci dflags = do- let usage_path = if ghci then ghciUsagePath dflags- else ghcUsagePath dflags- usage <- readFile usage_path- dump usage- where- dump "" = return ()- dump ('$':'$':s) = putStr progName >> dump s- dump (c:s) = putChar c >> dump s--dumpFinalStats :: DynFlags -> IO ()-dumpFinalStats dflags =- when (gopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags--dumpFastStringStats :: DynFlags -> IO ()-dumpFastStringStats dflags = do- segments <- getFastStringTable- let buckets = concat segments- bucketsPerSegment = map length segments- entriesPerBucket = map length buckets- entries = sum entriesPerBucket- hasZ = sum $ map (length . filter hasZEncoding) buckets- msg = text "FastString stats:" $$ nest 4 (vcat- [ text "segments: " <+> int (length segments)- , text "buckets: " <+> int (sum bucketsPerSegment)- , text "entries: " <+> int entries- , text "largest segment: " <+> int (maximum bucketsPerSegment)- , text "smallest segment: " <+> int (minimum bucketsPerSegment)- , text "longest bucket: " <+> int (maximum entriesPerBucket)- , text "has z-encoding: " <+> (hasZ `pcntOf` entries)- ])- -- we usually get more "has z-encoding" than "z-encoded", because- -- when we z-encode a string it might hash to the exact same string,- -- which is not counted as "z-encoded". Only strings whose- -- Z-encoding is different from the original string are counted in- -- the "z-encoded" total.- putMsg dflags msg- where- x `pcntOf` y = int ((x * 100) `quot` y) Outputable.<> char '%'--showPackages, dumpPackages, dumpPackagesSimple :: DynFlags -> IO ()-showPackages dflags = putStrLn (showSDoc dflags (pprPackages dflags))-dumpPackages dflags = putMsg dflags (pprPackages dflags)-dumpPackagesSimple dflags = putMsg dflags (pprPackagesSimple dflags)---- -------------------------------------------------------------------------------- Frontend plugin support--doFrontend :: ModuleName -> [(String, Maybe Phase)] -> Ghc ()-#if !defined(HAVE_INTERPRETER)-doFrontend modname _ = pluginError [modname]-#else-doFrontend modname srcs = do- hsc_env <- getSession- frontend_plugin <- liftIO $ loadFrontendPlugin hsc_env modname- frontend frontend_plugin- (reverse $ frontendPluginOpts (hsc_dflags hsc_env)) srcs-#endif---- -------------------------------------------------------------------------------- ABI hash support--{-- ghc --abi-hash Data.Foo System.Bar--Generates a combined hash of the ABI for modules Data.Foo and-System.Bar. The modules must already be compiled, and appropriate -i-options may be necessary in order to find the .hi files.--This is used by Cabal for generating the ComponentId for a-package. The ComponentId must change when the visible ABI of-the package chagnes, so during registration Cabal calls ghc --abi-hash-to get a hash of the package's ABI.--}---- | Print ABI hash of input modules.------ The resulting hash is the MD5 of the GHC version used (#5328,--- see 'hiVersion') and of the existing ABI hash from each module (see--- 'mi_mod_hash').-abiHash :: [String] -- ^ List of module names- -> Ghc ()-abiHash strs = do- hsc_env <- getSession- let dflags = hsc_dflags hsc_env-- liftIO $ do-- let find_it str = do- let modname = mkModuleName str- r <- findImportedModule hsc_env modname Nothing- case r of- Found _ m -> return m- _error -> throwGhcException $ CmdLineError $ showSDoc dflags $- cannotFindModule dflags modname r-- mods <- mapM find_it strs-- let get_iface modl = loadUserInterface False (text "abiHash") modl- ifaces <- initIfaceCheck (text "abiHash") hsc_env $ mapM get_iface mods-- bh <- openBinMem (3*1024) -- just less than a block- put_ bh hiVersion- -- package hashes change when the compiler version changes (for now)- -- see #5328- mapM_ (put_ bh . mi_mod_hash) ifaces- f <- fingerprintBinMem bh-- putStrLn (showPpr dflags f)---- -------------------------------------------------------------------------------- Util--unknownFlagsErr :: [String] -> a-unknownFlagsErr fs = throwGhcException $ UsageError $ concatMap oneError fs- where- oneError f =- "unrecognised flag: " ++ f ++ "\n" ++- (case match f (nubSort allNonDeprecatedFlags) of- [] -> ""- suggs -> "did you mean one of:\n" ++ unlines (map (" " ++) suggs))- -- fixes #11789- -- If the flag contains '=',- -- this uses both the whole and the left side of '=' for comparing.- match f allFlags- | elem '=' f =- let (flagsWithEq, flagsWithoutEq) = partition (elem '=') allFlags- fName = takeWhile (/= '=') f- in (fuzzyMatch f flagsWithEq) ++ (fuzzyMatch fName flagsWithoutEq)- | otherwise = fuzzyMatch f allFlags--{- Note [-Bsymbolic and hooks]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Bsymbolic is a flag that prevents the binding of references to global-symbols to symbols outside the shared library being compiled (see `man-ld`). When dynamically linking, we don't use -Bsymbolic on the RTS-package: that is because we want hooks to be overridden by the user,-we don't want to constrain them to the RTS package.--Unfortunately this seems to have broken somehow on OS X: as a result,-defaultHooks (in hschooks.c) is not called, which does not initialize-the GC stats. As a result, this breaks things like `:set +s` in GHCi-(#8754). As a hacky workaround, we instead call 'defaultHooks'-directly to initalize the flags in the RTS.--A byproduct of this, I believe, is that hooks are likely broken on OS-X when dynamically linking. But this probably doesn't affect most-people since we're linking GHC dynamically, but most things themselves-link statically.--}---- If GHC_LOADED_INTO_GHCI is not set when GHC is loaded into GHCi, then--- running it causes an error like this:------ Loading temp shared object failed:--- /tmp/ghc13836_0/libghc_1872.so: undefined symbol: initGCStatistics------ Skipping the foreign call fixes this problem, and the outer GHCi--- should have already made this call anyway.-#if defined(GHC_LOADED_INTO_GHCI)-initGCStatistics :: IO ()-initGCStatistics = return ()-#else-foreign import ccall safe "initGCStatistics"- initGCStatistics :: IO ()-#endif
− includes/Cmm.h
@@ -1,946 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The University of Glasgow 2004-2013- *- * This file is included at the top of all .cmm source files (and- * *only* .cmm files). It defines a collection of useful macros for- * making .cmm code a bit less error-prone to write, and a bit easier- * on the eye for the reader.- *- * For the syntax of .cmm files, see the parser in ghc/compiler/cmm/CmmParse.y.- *- * Accessing fields of structures defined in the RTS header files is- * done via automatically-generated macros in DerivedConstants.h. For- * example, where previously we used- *- * CurrentTSO->what_next = x- *- * in C-- we now use- *- * StgTSO_what_next(CurrentTSO) = x- *- * where the StgTSO_what_next() macro is automatically generated by- * mkDerivedConstants.c. If you need to access a field that doesn't- * already have a macro, edit that file (it's pretty self-explanatory).- *- * -------------------------------------------------------------------------- */--#pragma once--/*- * In files that are included into both C and C-- (and perhaps- * Haskell) sources, we sometimes need to conditionally compile bits- * depending on the language. CMINUSMINUS==1 in .cmm sources:- */-#define CMINUSMINUS 1--#include "ghcconfig.h"--/* ------------------------------------------------------------------------------ Types-- The following synonyms for C-- types are declared here:-- I8, I16, I32, I64 MachRep-style names for convenience-- W_ is shorthand for the word type (== StgWord)- F_ shorthand for float (F_ == StgFloat == C's float)- D_ shorthand for double (D_ == StgDouble == C's double)-- CInt has the same size as an int in C on this platform- CLong has the same size as a long in C on this platform- CBool has the same size as a bool in C on this platform-- --------------------------------------------------------------------------- */--#define I8 bits8-#define I16 bits16-#define I32 bits32-#define I64 bits64-#define P_ gcptr--#if SIZEOF_VOID_P == 4-#define W_ bits32-/* Maybe it's better to include MachDeps.h */-#define TAG_BITS 2-#elif SIZEOF_VOID_P == 8-#define W_ bits64-/* Maybe it's better to include MachDeps.h */-#define TAG_BITS 3-#else-#error Unknown word size-#endif--/*- * The RTS must sometimes UNTAG a pointer before dereferencing it.- * See the wiki page commentary/rts/haskell-execution/pointer-tagging- */-#define TAG_MASK ((1 << TAG_BITS) - 1)-#define UNTAG(p) (p & ~TAG_MASK)-#define GETTAG(p) (p & TAG_MASK)--#if SIZEOF_INT == 4-#define CInt bits32-#elif SIZEOF_INT == 8-#define CInt bits64-#else-#error Unknown int size-#endif--#if SIZEOF_LONG == 4-#define CLong bits32-#elif SIZEOF_LONG == 8-#define CLong bits64-#else-#error Unknown long size-#endif--#define CBool bits8--#define F_ float32-#define D_ float64-#define L_ bits64-#define V16_ bits128-#define V32_ bits256-#define V64_ bits512--#define SIZEOF_StgDouble 8-#define SIZEOF_StgWord64 8--/* ------------------------------------------------------------------------------ Misc useful stuff- -------------------------------------------------------------------------- */--#define ccall foreign "C"--#define NULL (0::W_)--#define STRING(name,str) \- section "rodata" { \- name : bits8[] str; \- } \--#if defined(TABLES_NEXT_TO_CODE)-#define RET_LBL(f) f##_info-#else-#define RET_LBL(f) f##_ret-#endif--#if defined(TABLES_NEXT_TO_CODE)-#define ENTRY_LBL(f) f##_info-#else-#define ENTRY_LBL(f) f##_entry-#endif--/* ------------------------------------------------------------------------------ Byte/word macros-- Everything in C-- is in byte offsets (well, most things). We use- some macros to allow us to express offsets in words and to try to- avoid byte/word confusion.- -------------------------------------------------------------------------- */--#define SIZEOF_W SIZEOF_VOID_P-#define W_MASK (SIZEOF_W-1)--#if SIZEOF_W == 4-#define W_SHIFT 2-#elif SIZEOF_W == 8-#define W_SHIFT 3-#endif--/* Converting quantities of words to bytes */-#define WDS(n) ((n)*SIZEOF_W)--/*- * Converting quantities of bytes to words- * NB. these work on *unsigned* values only- */-#define BYTES_TO_WDS(n) ((n) / SIZEOF_W)-#define ROUNDUP_BYTES_TO_WDS(n) (((n) + SIZEOF_W - 1) / SIZEOF_W)--/*- * TO_W_(n) and TO_ZXW_(n) convert n to W_ type from a smaller type,- * with and without sign extension respectively- */-#if SIZEOF_W == 4-#define TO_I64(x) %sx64(x)-#define TO_W_(x) %sx32(x)-#define TO_ZXW_(x) %zx32(x)-#define HALF_W_(x) %lobits16(x)-#elif SIZEOF_W == 8-#define TO_I64(x) (x)-#define TO_W_(x) %sx64(x)-#define TO_ZXW_(x) %zx64(x)-#define HALF_W_(x) %lobits32(x)-#endif--#if SIZEOF_INT == 4 && SIZEOF_W == 8-#define W_TO_INT(x) %lobits32(x)-#elif SIZEOF_INT == SIZEOF_W-#define W_TO_INT(x) (x)-#endif--#if SIZEOF_LONG == 4 && SIZEOF_W == 8-#define W_TO_LONG(x) %lobits32(x)-#elif SIZEOF_LONG == SIZEOF_W-#define W_TO_LONG(x) (x)-#endif--/* ------------------------------------------------------------------------------ Atomic memory operations.- -------------------------------------------------------------------------- */--#if SIZEOF_W == 4-#define cmpxchgW cmpxchg32-#elif SIZEOF_W == 8-#define cmpxchgW cmpxchg64-#endif--/* ------------------------------------------------------------------------------ Heap/stack access, and adjusting the heap/stack pointers.- -------------------------------------------------------------------------- */--#define Sp(n) W_[Sp + WDS(n)]-#define Hp(n) W_[Hp + WDS(n)]--#define Sp_adj(n) Sp = Sp + WDS(n) /* pronounced "spadge" */-#define Hp_adj(n) Hp = Hp + WDS(n)--/* ------------------------------------------------------------------------------ Assertions and Debuggery- -------------------------------------------------------------------------- */--#if defined(DEBUG)-#define ASSERT(predicate) \- if (predicate) { \- /*null*/; \- } else { \- foreign "C" _assertFail(__FILE__, __LINE__) never returns; \- }-#else-#define ASSERT(p) /* nothing */-#endif--#if defined(DEBUG)-#define DEBUG_ONLY(s) s-#else-#define DEBUG_ONLY(s) /* nothing */-#endif--/*- * The IF_DEBUG macro is useful for debug messages that depend on one- * of the RTS debug options. For example:- *- * IF_DEBUG(RtsFlags_DebugFlags_apply,- * foreign "C" fprintf(stderr, stg_ap_0_ret_str));- *- * Note the syntax is slightly different to the C version of this macro.- */-#if defined(DEBUG)-#define IF_DEBUG(c,s) if (RtsFlags_DebugFlags_##c(RtsFlags) != 0::CBool) { s; }-#else-#define IF_DEBUG(c,s) /* nothing */-#endif--/* ------------------------------------------------------------------------------ Entering-- It isn't safe to "enter" every closure. Functions in particular- have no entry code as such; their entry point contains the code to- apply the function.-- ToDo: range should end in N_CLOSURE_TYPES-1, not N_CLOSURE_TYPES,- but switch doesn't allow us to use exprs there yet.-- If R1 points to a tagged object it points either to- * A constructor.- * A function with arity <= TAG_MASK.- In both cases the right thing to do is to return.- Note: it is rather lucky that we can use the tag bits to do this- for both objects. Maybe it points to a brittle design?-- Indirections can contain tagged pointers, so their tag is checked.- -------------------------------------------------------------------------- */--#if defined(PROFILING)--// When profiling, we cannot shortcut ENTER() by checking the tag,-// because LDV profiling relies on entering closures to mark them as-// "used".--#define LOAD_INFO(ret,x) \- info = %INFO_PTR(UNTAG(x));--#define UNTAG_IF_PROF(x) UNTAG(x)--#else--#define LOAD_INFO(ret,x) \- if (GETTAG(x) != 0) { \- ret(x); \- } \- info = %INFO_PTR(x);--#define UNTAG_IF_PROF(x) (x) /* already untagged */--#endif--// We need two versions of ENTER():-// - ENTER(x) takes the closure as an argument and uses return(),-// for use in civilized code where the stack is handled by GHC-//-// - ENTER_NOSTACK() where the closure is in R1, and returns are-// explicit jumps, for use when we are doing the stack management-// ourselves.--#if defined(PROFILING)-// See Note [Evaluating functions with profiling] in rts/Apply.cmm-#define ENTER(x) jump stg_ap_0_fast(x);-#else-#define ENTER(x) ENTER_(return,x)-#endif--#define ENTER_R1() ENTER_(RET_R1,R1)--#define RET_R1(x) jump %ENTRY_CODE(Sp(0)) [R1]--#define ENTER_(ret,x) \- again: \- W_ info; \- LOAD_INFO(ret,x) \- /* See Note [Heap memory barriers] in SMP.h */ \- prim_read_barrier; \- switch [INVALID_OBJECT .. N_CLOSURE_TYPES] \- (TO_W_( %INFO_TYPE(%STD_INFO(info)) )) { \- case \- IND, \- IND_STATIC: \- { \- x = StgInd_indirectee(x); \- goto again; \- } \- case \- FUN, \- FUN_1_0, \- FUN_0_1, \- FUN_2_0, \- FUN_1_1, \- FUN_0_2, \- FUN_STATIC, \- BCO, \- PAP: \- { \- ret(x); \- } \- default: \- { \- x = UNTAG_IF_PROF(x); \- jump %ENTRY_CODE(info) (x); \- } \- }--// The FUN cases almost never happen: a pointer to a non-static FUN-// should always be tagged. This unfortunately isn't true for the-// interpreter right now, which leaves untagged FUNs on the stack.--/* ------------------------------------------------------------------------------ Constants.- -------------------------------------------------------------------------- */--#include "rts/Constants.h"-#include "DerivedConstants.h"-#include "rts/storage/ClosureTypes.h"-#include "rts/storage/FunTypes.h"-#include "rts/OSThreads.h"--/*- * Need MachRegs, because some of the RTS code is conditionally- * compiled based on REG_R1, REG_R2, etc.- */-#include "stg/RtsMachRegs.h"--#include "rts/prof/LDV.h"--#undef BLOCK_SIZE-#undef MBLOCK_SIZE-#include "rts/storage/Block.h" /* For Bdescr() */---#define MyCapability() (BaseReg - OFFSET_Capability_r)--/* -------------------------------------------------------------------------- Info tables- ------------------------------------------------------------------------- */--#if defined(PROFILING)-#define PROF_HDR_FIELDS(w_,hdr1,hdr2) \- w_ hdr1, \- w_ hdr2,-#else-#define PROF_HDR_FIELDS(w_,hdr1,hdr2) /* nothing */-#endif--/* -------------------------------------------------------------------------- Allocation and garbage collection- ------------------------------------------------------------------------- */--/*- * ALLOC_PRIM is for allocating memory on the heap for a primitive- * object. It is used all over PrimOps.cmm.- *- * We make the simplifying assumption that the "admin" part of a- * primitive closure is just the header when calculating sizes for- * ticky-ticky. It's not clear whether eg. the size field of an array- * should be counted as "admin", or the various fields of a BCO.- */-#define ALLOC_PRIM(bytes) \- HP_CHK_GEN_TICKY(bytes); \- TICK_ALLOC_PRIM(SIZEOF_StgHeader,bytes-SIZEOF_StgHeader,0); \- CCCS_ALLOC(bytes);--#define HEAP_CHECK(bytes,failure) \- TICK_BUMP(HEAP_CHK_ctr); \- Hp = Hp + (bytes); \- if (Hp > HpLim) { HpAlloc = (bytes); failure; } \- TICK_ALLOC_HEAP_NOCTR(bytes);--#define ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,failure) \- HEAP_CHECK(bytes,failure) \- TICK_ALLOC_PRIM(SIZEOF_StgHeader,bytes-SIZEOF_StgHeader,0); \- CCCS_ALLOC(bytes);--#define ALLOC_PRIM_(bytes,fun) \- ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,GC_PRIM(fun));--#define ALLOC_PRIM_P(bytes,fun,arg) \- ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,GC_PRIM_P(fun,arg));--#define ALLOC_PRIM_N(bytes,fun,arg) \- ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,GC_PRIM_N(fun,arg));--/* CCS_ALLOC wants the size in words, because ccs->mem_alloc is in words */-#define CCCS_ALLOC(__alloc) CCS_ALLOC(BYTES_TO_WDS(__alloc), CCCS)--#define HP_CHK_GEN_TICKY(bytes) \- HP_CHK_GEN(bytes); \- TICK_ALLOC_HEAP_NOCTR(bytes);--#define HP_CHK_P(bytes, fun, arg) \- HEAP_CHECK(bytes, GC_PRIM_P(fun,arg))--// TODO I'm not seeing where ALLOC_P_TICKY is used; can it be removed?-// -NSF March 2013-#define ALLOC_P_TICKY(bytes, fun, arg) \- HP_CHK_P(bytes); \- TICK_ALLOC_HEAP_NOCTR(bytes);--#define CHECK_GC() \- (bdescr_link(CurrentNursery) == NULL || \- generation_n_new_large_words(W_[g0]) >= TO_W_(CLong[large_alloc_lim]))--// allocate() allocates from the nursery, so we check to see-// whether the nursery is nearly empty in any function that uses-// allocate() - this includes many of the primops.-//-// HACK alert: the __L__ stuff is here to coax the common-block-// eliminator into commoning up the call stg_gc_noregs() with the same-// code that gets generated by a STK_CHK_GEN() in the same proc. We-// also need an if (0) { goto __L__; } so that the __L__ label isn't-// optimised away by the control-flow optimiser prior to common-block-// elimination (it will be optimised away later).-//-// This saves some code in gmp-wrappers.cmm where we have lots of-// MAYBE_GC() in the same proc as STK_CHK_GEN().-//-#define MAYBE_GC(retry) \- if (CHECK_GC()) { \- HpAlloc = 0; \- goto __L__; \- __L__: \- call stg_gc_noregs(); \- goto retry; \- } \- if (0) { goto __L__; }--#define GC_PRIM(fun) \- jump stg_gc_prim(fun);--// Version of GC_PRIM for use in low-level Cmm. We can call-// stg_gc_prim, because it takes one argument and therefore has a-// platform-independent calling convention (Note [Syntax of .cmm-// files] in CmmParse.y).-#define GC_PRIM_LL(fun) \- R1 = fun; \- jump stg_gc_prim [R1];--// We pass the fun as the second argument, because the arg is-// usually already in the first argument position (R1), so this-// avoids moving it to a different register / stack slot.-#define GC_PRIM_N(fun,arg) \- jump stg_gc_prim_n(arg,fun);--#define GC_PRIM_P(fun,arg) \- jump stg_gc_prim_p(arg,fun);--#define GC_PRIM_P_LL(fun,arg) \- R1 = arg; \- R2 = fun; \- jump stg_gc_prim_p_ll [R1,R2];--#define GC_PRIM_PP(fun,arg1,arg2) \- jump stg_gc_prim_pp(arg1,arg2,fun);--#define MAYBE_GC_(fun) \- if (CHECK_GC()) { \- HpAlloc = 0; \- GC_PRIM(fun) \- }--#define MAYBE_GC_N(fun,arg) \- if (CHECK_GC()) { \- HpAlloc = 0; \- GC_PRIM_N(fun,arg) \- }--#define MAYBE_GC_P(fun,arg) \- if (CHECK_GC()) { \- HpAlloc = 0; \- GC_PRIM_P(fun,arg) \- }--#define MAYBE_GC_PP(fun,arg1,arg2) \- if (CHECK_GC()) { \- HpAlloc = 0; \- GC_PRIM_PP(fun,arg1,arg2) \- }--#define STK_CHK_LL(n, fun) \- TICK_BUMP(STK_CHK_ctr); \- if (Sp - (n) < SpLim) { \- GC_PRIM_LL(fun) \- }--#define STK_CHK_P_LL(n, fun, arg) \- TICK_BUMP(STK_CHK_ctr); \- if (Sp - (n) < SpLim) { \- GC_PRIM_P_LL(fun,arg) \- }--#define STK_CHK_PP(n, fun, arg1, arg2) \- TICK_BUMP(STK_CHK_ctr); \- if (Sp - (n) < SpLim) { \- GC_PRIM_PP(fun,arg1,arg2) \- }--#define STK_CHK_ENTER(n, closure) \- TICK_BUMP(STK_CHK_ctr); \- if (Sp - (n) < SpLim) { \- jump __stg_gc_enter_1(closure); \- }--// A funky heap check used by AutoApply.cmm--#define HP_CHK_NP_ASSIGN_SP0(size,f) \- HEAP_CHECK(size, Sp(0) = f; jump __stg_gc_enter_1 [R1];)--/* ------------------------------------------------------------------------------ Closure headers- -------------------------------------------------------------------------- */--/*- * This is really ugly, since we don't do the rest of StgHeader this- * way. The problem is that values from DerivedConstants.h cannot be- * dependent on the way (SMP, PROF etc.). For SIZEOF_StgHeader we get- * the value from GHC, but it seems like too much trouble to do that- * for StgThunkHeader.- */-#define SIZEOF_StgThunkHeader SIZEOF_StgHeader+SIZEOF_StgSMPThunkHeader--#define StgThunk_payload(__ptr__,__ix__) \- W_[__ptr__+SIZEOF_StgThunkHeader+ WDS(__ix__)]--/* ------------------------------------------------------------------------------ Closures- -------------------------------------------------------------------------- */--/* The offset of the payload of an array */-#define BYTE_ARR_CTS(arr) ((arr) + SIZEOF_StgArrBytes)--/* The number of words allocated in an array payload */-#define BYTE_ARR_WDS(arr) ROUNDUP_BYTES_TO_WDS(StgArrBytes_bytes(arr))--/* Getting/setting the info pointer of a closure */-#define SET_INFO(p,info) StgHeader_info(p) = info-#define GET_INFO(p) StgHeader_info(p)--/* Determine the size of an ordinary closure from its info table */-#define sizeW_fromITBL(itbl) \- SIZEOF_StgHeader + WDS(%INFO_PTRS(itbl)) + WDS(%INFO_NPTRS(itbl))--/* NB. duplicated from InfoTables.h! */-#define BITMAP_SIZE(bitmap) ((bitmap) & BITMAP_SIZE_MASK)-#define BITMAP_BITS(bitmap) ((bitmap) >> BITMAP_BITS_SHIFT)--/* Debugging macros */-#define LOOKS_LIKE_INFO_PTR(p) \- ((p) != NULL && \- LOOKS_LIKE_INFO_PTR_NOT_NULL(p))--#define LOOKS_LIKE_INFO_PTR_NOT_NULL(p) \- ( (TO_W_(%INFO_TYPE(%STD_INFO(p))) != INVALID_OBJECT) && \- (TO_W_(%INFO_TYPE(%STD_INFO(p))) < N_CLOSURE_TYPES))--#define LOOKS_LIKE_CLOSURE_PTR(p) (LOOKS_LIKE_INFO_PTR(GET_INFO(UNTAG(p))))--/*- * The layout of the StgFunInfoExtra part of an info table changes- * depending on TABLES_NEXT_TO_CODE. So we define field access- * macros which use the appropriate version here:- */-#if defined(TABLES_NEXT_TO_CODE)-/*- * when TABLES_NEXT_TO_CODE, slow_apply is stored as an offset- * instead of the normal pointer.- */--#define StgFunInfoExtra_slow_apply(fun_info) \- (TO_W_(StgFunInfoExtraRev_slow_apply_offset(fun_info)) \- + (fun_info) + SIZEOF_StgFunInfoExtraRev + SIZEOF_StgInfoTable)--#define StgFunInfoExtra_fun_type(i) StgFunInfoExtraRev_fun_type(i)-#define StgFunInfoExtra_arity(i) StgFunInfoExtraRev_arity(i)-#define StgFunInfoExtra_bitmap(i) StgFunInfoExtraRev_bitmap(i)-#else-#define StgFunInfoExtra_slow_apply(i) StgFunInfoExtraFwd_slow_apply(i)-#define StgFunInfoExtra_fun_type(i) StgFunInfoExtraFwd_fun_type(i)-#define StgFunInfoExtra_arity(i) StgFunInfoExtraFwd_arity(i)-#define StgFunInfoExtra_bitmap(i) StgFunInfoExtraFwd_bitmap(i)-#endif--#define mutArrCardMask ((1 << MUT_ARR_PTRS_CARD_BITS) - 1)-#define mutArrPtrCardDown(i) ((i) >> MUT_ARR_PTRS_CARD_BITS)-#define mutArrPtrCardUp(i) (((i) + mutArrCardMask) >> MUT_ARR_PTRS_CARD_BITS)-#define mutArrPtrsCardWords(n) ROUNDUP_BYTES_TO_WDS(mutArrPtrCardUp(n))--#if defined(PROFILING) || (!defined(THREADED_RTS) && defined(DEBUG))-#define OVERWRITING_CLOSURE_SIZE(c, size) foreign "C" overwritingClosureSize(c "ptr", size)-#define OVERWRITING_CLOSURE(c) foreign "C" overwritingClosure(c "ptr")-#define OVERWRITING_CLOSURE_OFS(c,n) foreign "C" overwritingClosureOfs(c "ptr", n)-#else-#define OVERWRITING_CLOSURE_SIZE(c, size) /* nothing */-#define OVERWRITING_CLOSURE(c) /* nothing */-#define OVERWRITING_CLOSURE_OFS(c,n) /* nothing */-#endif--// Memory barriers.-// For discussion of how these are used to fence heap object-// accesses see Note [Heap memory barriers] in SMP.h.-#if defined(THREADED_RTS)-#define prim_read_barrier prim %read_barrier()-#else-#define prim_read_barrier /* nothing */-#endif-#if defined(THREADED_RTS)-#define prim_write_barrier prim %write_barrier()-#else-#define prim_write_barrier /* nothing */-#endif--/* ------------------------------------------------------------------------------ Ticky macros- -------------------------------------------------------------------------- */--#if defined(TICKY_TICKY)-#define TICK_BUMP_BY(ctr,n) CLong[ctr] = CLong[ctr] + n-#else-#define TICK_BUMP_BY(ctr,n) /* nothing */-#endif--#define TICK_BUMP(ctr) TICK_BUMP_BY(ctr,1)--#define TICK_ENT_DYN_IND() TICK_BUMP(ENT_DYN_IND_ctr)-#define TICK_ENT_DYN_THK() TICK_BUMP(ENT_DYN_THK_ctr)-#define TICK_ENT_VIA_NODE() TICK_BUMP(ENT_VIA_NODE_ctr)-#define TICK_ENT_STATIC_IND() TICK_BUMP(ENT_STATIC_IND_ctr)-#define TICK_ENT_PERM_IND() TICK_BUMP(ENT_PERM_IND_ctr)-#define TICK_ENT_PAP() TICK_BUMP(ENT_PAP_ctr)-#define TICK_ENT_AP() TICK_BUMP(ENT_AP_ctr)-#define TICK_ENT_AP_STACK() TICK_BUMP(ENT_AP_STACK_ctr)-#define TICK_ENT_BH() TICK_BUMP(ENT_BH_ctr)-#define TICK_ENT_LNE() TICK_BUMP(ENT_LNE_ctr)-#define TICK_UNKNOWN_CALL() TICK_BUMP(UNKNOWN_CALL_ctr)-#define TICK_UPDF_PUSHED() TICK_BUMP(UPDF_PUSHED_ctr)-#define TICK_CATCHF_PUSHED() TICK_BUMP(CATCHF_PUSHED_ctr)-#define TICK_UPDF_OMITTED() TICK_BUMP(UPDF_OMITTED_ctr)-#define TICK_UPD_NEW_IND() TICK_BUMP(UPD_NEW_IND_ctr)-#define TICK_UPD_NEW_PERM_IND() TICK_BUMP(UPD_NEW_PERM_IND_ctr)-#define TICK_UPD_OLD_IND() TICK_BUMP(UPD_OLD_IND_ctr)-#define TICK_UPD_OLD_PERM_IND() TICK_BUMP(UPD_OLD_PERM_IND_ctr)--#define TICK_SLOW_CALL_FUN_TOO_FEW() TICK_BUMP(SLOW_CALL_FUN_TOO_FEW_ctr)-#define TICK_SLOW_CALL_FUN_CORRECT() TICK_BUMP(SLOW_CALL_FUN_CORRECT_ctr)-#define TICK_SLOW_CALL_FUN_TOO_MANY() TICK_BUMP(SLOW_CALL_FUN_TOO_MANY_ctr)-#define TICK_SLOW_CALL_PAP_TOO_FEW() TICK_BUMP(SLOW_CALL_PAP_TOO_FEW_ctr)-#define TICK_SLOW_CALL_PAP_CORRECT() TICK_BUMP(SLOW_CALL_PAP_CORRECT_ctr)-#define TICK_SLOW_CALL_PAP_TOO_MANY() TICK_BUMP(SLOW_CALL_PAP_TOO_MANY_ctr)--#define TICK_SLOW_CALL_fast_v16() TICK_BUMP(SLOW_CALL_fast_v16_ctr)-#define TICK_SLOW_CALL_fast_v() TICK_BUMP(SLOW_CALL_fast_v_ctr)-#define TICK_SLOW_CALL_fast_p() TICK_BUMP(SLOW_CALL_fast_p_ctr)-#define TICK_SLOW_CALL_fast_pv() TICK_BUMP(SLOW_CALL_fast_pv_ctr)-#define TICK_SLOW_CALL_fast_pp() TICK_BUMP(SLOW_CALL_fast_pp_ctr)-#define TICK_SLOW_CALL_fast_ppv() TICK_BUMP(SLOW_CALL_fast_ppv_ctr)-#define TICK_SLOW_CALL_fast_ppp() TICK_BUMP(SLOW_CALL_fast_ppp_ctr)-#define TICK_SLOW_CALL_fast_pppv() TICK_BUMP(SLOW_CALL_fast_pppv_ctr)-#define TICK_SLOW_CALL_fast_pppp() TICK_BUMP(SLOW_CALL_fast_pppp_ctr)-#define TICK_SLOW_CALL_fast_ppppp() TICK_BUMP(SLOW_CALL_fast_ppppp_ctr)-#define TICK_SLOW_CALL_fast_pppppp() TICK_BUMP(SLOW_CALL_fast_pppppp_ctr)-#define TICK_VERY_SLOW_CALL() TICK_BUMP(VERY_SLOW_CALL_ctr)--/* NOTE: TICK_HISTO_BY and TICK_HISTO- currently have no effect.- The old code for it didn't typecheck and I- just commented it out to get ticky to work.- - krc 1/2007 */--#define TICK_HISTO_BY(histo,n,i) /* nothing */--#define TICK_HISTO(histo,n) TICK_HISTO_BY(histo,n,1)--/* An unboxed tuple with n components. */-#define TICK_RET_UNBOXED_TUP(n) \- TICK_BUMP(RET_UNBOXED_TUP_ctr++); \- TICK_HISTO(RET_UNBOXED_TUP,n)--/*- * A slow call with n arguments. In the unevald case, this call has- * already been counted once, so don't count it again.- */-#define TICK_SLOW_CALL(n) \- TICK_BUMP(SLOW_CALL_ctr); \- TICK_HISTO(SLOW_CALL,n)--/*- * This slow call was found to be to an unevaluated function; undo the- * ticks we did in TICK_SLOW_CALL.- */-#define TICK_SLOW_CALL_UNEVALD(n) \- TICK_BUMP(SLOW_CALL_UNEVALD_ctr); \- TICK_BUMP_BY(SLOW_CALL_ctr,-1); \- TICK_HISTO_BY(SLOW_CALL,n,-1);--/* Updating a closure with a new CON */-#define TICK_UPD_CON_IN_NEW(n) \- TICK_BUMP(UPD_CON_IN_NEW_ctr); \- TICK_HISTO(UPD_CON_IN_NEW,n)--#define TICK_ALLOC_HEAP_NOCTR(bytes) \- TICK_BUMP(ALLOC_RTS_ctr); \- TICK_BUMP_BY(ALLOC_RTS_tot,bytes)--/* ------------------------------------------------------------------------------ Saving and restoring STG registers-- STG registers must be saved around a C call, just in case the STG- register is mapped to a caller-saves machine register. Normally we- don't need to worry about this the code generator has already- loaded any live STG registers into variables for us, but in- hand-written low-level Cmm code where we don't know which registers- are live, we might have to save them all.- -------------------------------------------------------------------------- */--#define SAVE_STGREGS \- W_ r1, r2, r3, r4, r5, r6, r7, r8; \- F_ f1, f2, f3, f4, f5, f6; \- D_ d1, d2, d3, d4, d5, d6; \- L_ l1; \- \- r1 = R1; \- r2 = R2; \- r3 = R3; \- r4 = R4; \- r5 = R5; \- r6 = R6; \- r7 = R7; \- r8 = R8; \- \- f1 = F1; \- f2 = F2; \- f3 = F3; \- f4 = F4; \- f5 = F5; \- f6 = F6; \- \- d1 = D1; \- d2 = D2; \- d3 = D3; \- d4 = D4; \- d5 = D5; \- d6 = D6; \- \- l1 = L1;---#define RESTORE_STGREGS \- R1 = r1; \- R2 = r2; \- R3 = r3; \- R4 = r4; \- R5 = r5; \- R6 = r6; \- R7 = r7; \- R8 = r8; \- \- F1 = f1; \- F2 = f2; \- F3 = f3; \- F4 = f4; \- F5 = f5; \- F6 = f6; \- \- D1 = d1; \- D2 = d2; \- D3 = d3; \- D4 = d4; \- D5 = d5; \- D6 = d6; \- \- L1 = l1;--/* ------------------------------------------------------------------------------ Misc junk- -------------------------------------------------------------------------- */--#define NO_TREC stg_NO_TREC_closure-#define END_TSO_QUEUE stg_END_TSO_QUEUE_closure-#define STM_AWOKEN stg_STM_AWOKEN_closure--#define recordMutableCap(p, gen) \- W_ __bd; \- W_ mut_list; \- mut_list = Capability_mut_lists(MyCapability()) + WDS(gen); \- __bd = W_[mut_list]; \- if (bdescr_free(__bd) >= bdescr_start(__bd) + BLOCK_SIZE) { \- W_ __new_bd; \- ("ptr" __new_bd) = foreign "C" allocBlock_lock(); \- bdescr_link(__new_bd) = __bd; \- __bd = __new_bd; \- W_[mut_list] = __bd; \- } \- W_ free; \- free = bdescr_free(__bd); \- W_[free] = p; \- bdescr_free(__bd) = free + WDS(1);--#define recordMutable(p) \- P_ __p; \- W_ __bd; \- W_ __gen; \- __p = p; \- __bd = Bdescr(__p); \- __gen = TO_W_(bdescr_gen_no(__bd)); \- if (__gen > 0) { recordMutableCap(__p, __gen); }--/* ------------------------------------------------------------------------------ Arrays- -------------------------------------------------------------------------- */--/* Complete function body for the clone family of (mutable) array ops.- Defined as a macro to avoid function call overhead or code- duplication. */-#define cloneArray(info, src, offset, n) \- W_ words, size; \- gcptr dst, dst_p, src_p; \- \- again: MAYBE_GC(again); \- \- size = n + mutArrPtrsCardWords(n); \- words = BYTES_TO_WDS(SIZEOF_StgMutArrPtrs) + size; \- ("ptr" dst) = ccall allocate(MyCapability() "ptr", words); \- TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(size), 0); \- \- SET_HDR(dst, info, CCCS); \- StgMutArrPtrs_ptrs(dst) = n; \- StgMutArrPtrs_size(dst) = size; \- \- dst_p = dst + SIZEOF_StgMutArrPtrs; \- src_p = src + SIZEOF_StgMutArrPtrs + WDS(offset); \- prim %memcpy(dst_p, src_p, n * SIZEOF_W, SIZEOF_W); \- \- return (dst);--#define copyArray(src, src_off, dst, dst_off, n) \- W_ dst_elems_p, dst_p, src_p, dst_cards_p, bytes; \- \- if ((n) != 0) { \- SET_HDR(dst, stg_MUT_ARR_PTRS_DIRTY_info, CCCS); \- \- dst_elems_p = (dst) + SIZEOF_StgMutArrPtrs; \- dst_p = dst_elems_p + WDS(dst_off); \- src_p = (src) + SIZEOF_StgMutArrPtrs + WDS(src_off); \- bytes = WDS(n); \- \- prim %memcpy(dst_p, src_p, bytes, SIZEOF_W); \- \- dst_cards_p = dst_elems_p + WDS(StgMutArrPtrs_ptrs(dst)); \- setCards(dst_cards_p, dst_off, n); \- } \- \- return ();--#define copyMutableArray(src, src_off, dst, dst_off, n) \- W_ dst_elems_p, dst_p, src_p, dst_cards_p, bytes; \- \- if ((n) != 0) { \- SET_HDR(dst, stg_MUT_ARR_PTRS_DIRTY_info, CCCS); \- \- dst_elems_p = (dst) + SIZEOF_StgMutArrPtrs; \- dst_p = dst_elems_p + WDS(dst_off); \- src_p = (src) + SIZEOF_StgMutArrPtrs + WDS(src_off); \- bytes = WDS(n); \- \- if ((src) == (dst)) { \- prim %memmove(dst_p, src_p, bytes, SIZEOF_W); \- } else { \- prim %memcpy(dst_p, src_p, bytes, SIZEOF_W); \- } \- \- dst_cards_p = dst_elems_p + WDS(StgMutArrPtrs_ptrs(dst)); \- setCards(dst_cards_p, dst_off, n); \- } \- \- return ();--/*- * Set the cards in the cards table pointed to by dst_cards_p for an- * update to n elements, starting at element dst_off.- */-#define setCards(dst_cards_p, dst_off, n) \- W_ __start_card, __end_card, __cards; \- __start_card = mutArrPtrCardDown(dst_off); \- __end_card = mutArrPtrCardDown((dst_off) + (n) - 1); \- __cards = __end_card - __start_card + 1; \- prim %memset((dst_cards_p) + __start_card, 1, __cards, 1);--/* Complete function body for the clone family of small (mutable)- array ops. Defined as a macro to avoid function call overhead or- code duplication. */-#define cloneSmallArray(info, src, offset, n) \- W_ words, size; \- gcptr dst, dst_p, src_p; \- \- again: MAYBE_GC(again); \- \- words = BYTES_TO_WDS(SIZEOF_StgSmallMutArrPtrs) + n; \- ("ptr" dst) = ccall allocate(MyCapability() "ptr", words); \- TICK_ALLOC_PRIM(SIZEOF_StgSmallMutArrPtrs, WDS(n), 0); \- \- SET_HDR(dst, info, CCCS); \- StgSmallMutArrPtrs_ptrs(dst) = n; \- \- dst_p = dst + SIZEOF_StgSmallMutArrPtrs; \- src_p = src + SIZEOF_StgSmallMutArrPtrs + WDS(offset); \- prim %memcpy(dst_p, src_p, n * SIZEOF_W, SIZEOF_W); \- \- return (dst);
includes/CodeGen.Platform.hs view
@@ -495,13 +495,13 @@ ,DoubleReg 1 #endif #if defined(REG_XMM1)- ,XmmReg 1 2 W64 Integer+ ,XmmReg 1 #endif #if defined(REG_YMM1)- ,YmmReg 1 4 W64 Integer+ ,YmmReg 1 #endif #if defined(REG_ZMM1)- ,ZmmReg 1 8 W64 Integer+ ,ZmmReg 1 #endif #if defined(REG_F2) ,FloatReg 2@@ -510,13 +510,13 @@ ,DoubleReg 2 #endif #if defined(REG_XMM2)- ,XmmReg 2 2 W64 Integer+ ,XmmReg 2 #endif #if defined(REG_YMM2)- ,YmmReg 2 4 W64 Integer+ ,YmmReg 2 #endif #if defined(REG_ZMM2)- ,ZmmReg 2 8 W64 Integer+ ,ZmmReg 2 #endif #if defined(REG_F3) ,FloatReg 3@@ -525,13 +525,13 @@ ,DoubleReg 3 #endif #if defined(REG_XMM3)- ,XmmReg 3 2 W64 Integer+ ,XmmReg 3 #endif #if defined(REG_YMM3)- ,YmmReg 3 4 W64 Integer+ ,YmmReg 3 #endif #if defined(REG_ZMM3)- ,ZmmReg 3 8 W64 Integer+ ,ZmmReg 3 #endif #if defined(REG_F4) ,FloatReg 4@@ -540,13 +540,13 @@ ,DoubleReg 4 #endif #if defined(REG_XMM4)- ,XmmReg 4 2 W64 Integer+ ,XmmReg 4 #endif #if defined(REG_YMM4)- ,YmmReg 4 4 W64 Integer+ ,YmmReg 4 #endif #if defined(REG_ZMM4)- ,ZmmReg 4 8 W64 Integer+ ,ZmmReg 4 #endif #if defined(REG_F5) ,FloatReg 5@@ -555,13 +555,13 @@ ,DoubleReg 5 #endif #if defined(REG_XMM5)- ,XmmReg 5 2 W64 Integer+ ,XmmReg 5 #endif #if defined(REG_YMM5)- ,YmmReg 5 4 W64 Integer+ ,YmmReg 5 #endif #if defined(REG_ZMM5)- ,ZmmReg 5 8 W64 Integer+ ,ZmmReg 5 #endif #if defined(REG_F6) ,FloatReg 6@@ -570,13 +570,13 @@ ,DoubleReg 6 #endif #if defined(REG_XMM6)- ,XmmReg 6 2 W64 Integer+ ,XmmReg 6 #endif #if defined(REG_YMM6)- ,YmmReg 6 4 W64 Integer+ ,YmmReg 6 #endif #if defined(REG_ZMM6)- ,ZmmReg 6 8 W64 Integer+ ,ZmmReg 6 #endif #else /* MAX_REAL_XMM_REG == 0 */ #if defined(REG_F1)@@ -733,62 +733,62 @@ # endif # if MAX_REAL_XMM_REG != 0 # if defined(REG_XMM1)-globalRegMaybe (XmmReg 1 _ _ _) = Just (RealRegSingle REG_XMM1)+globalRegMaybe (XmmReg 1) = Just (RealRegSingle REG_XMM1) # endif # if defined(REG_XMM2)-globalRegMaybe (XmmReg 2 _ _ _) = Just (RealRegSingle REG_XMM2)+globalRegMaybe (XmmReg 2) = Just (RealRegSingle REG_XMM2) # endif # if defined(REG_XMM3)-globalRegMaybe (XmmReg 3 _ _ _) = Just (RealRegSingle REG_XMM3)+globalRegMaybe (XmmReg 3) = Just (RealRegSingle REG_XMM3) # endif # if defined(REG_XMM4)-globalRegMaybe (XmmReg 4 _ _ _) = Just (RealRegSingle REG_XMM4)+globalRegMaybe (XmmReg 4) = Just (RealRegSingle REG_XMM4) # endif # if defined(REG_XMM5)-globalRegMaybe (XmmReg 5 _ _ _) = Just (RealRegSingle REG_XMM5)+globalRegMaybe (XmmReg 5) = Just (RealRegSingle REG_XMM5) # endif # if defined(REG_XMM6)-globalRegMaybe (XmmReg 6 _ _ _) = Just (RealRegSingle REG_XMM6)+globalRegMaybe (XmmReg 6) = Just (RealRegSingle REG_XMM6) # endif # endif # if defined(MAX_REAL_YMM_REG) && MAX_REAL_YMM_REG != 0 # if defined(REG_YMM1)-globalRegMaybe (YmmReg 1 _ _ _) = Just (RealRegSingle REG_YMM1)+globalRegMaybe (YmmReg 1) = Just (RealRegSingle REG_YMM1) # endif # if defined(REG_YMM2)-globalRegMaybe (YmmReg 2 _ _ _) = Just (RealRegSingle REG_YMM2)+globalRegMaybe (YmmReg 2) = Just (RealRegSingle REG_YMM2) # endif # if defined(REG_YMM3)-globalRegMaybe (YmmReg 3 _ _ _) = Just (RealRegSingle REG_YMM3)+globalRegMaybe (YmmReg 3) = Just (RealRegSingle REG_YMM3) # endif # if defined(REG_YMM4)-globalRegMaybe (YmmReg 4 _ _ _) = Just (RealRegSingle REG_YMM4)+globalRegMaybe (YmmReg 4) = Just (RealRegSingle REG_YMM4) # endif # if defined(REG_YMM5)-globalRegMaybe (YmmReg 5 _ _ _) = Just (RealRegSingle REG_YMM5)+globalRegMaybe (YmmReg 5) = Just (RealRegSingle REG_YMM5) # endif # if defined(REG_YMM6)-globalRegMaybe (YmmReg 6 _ _ _) = Just (RealRegSingle REG_YMM6)+globalRegMaybe (YmmReg 6) = Just (RealRegSingle REG_YMM6) # endif # endif # if defined(MAX_REAL_ZMM_REG) && MAX_REAL_ZMM_REG != 0 # if defined(REG_ZMM1)-globalRegMaybe (ZmmReg 1 _ _ _) = Just (RealRegSingle REG_ZMM1)+globalRegMaybe (ZmmReg 1) = Just (RealRegSingle REG_ZMM1) # endif # if defined(REG_ZMM2)-globalRegMaybe (ZmmReg 2 _ _ _) = Just (RealRegSingle REG_ZMM2)+globalRegMaybe (ZmmReg 2) = Just (RealRegSingle REG_ZMM2) # endif # if defined(REG_ZMM3)-globalRegMaybe (ZmmReg 3 _ _ _) = Just (RealRegSingle REG_ZMM3)+globalRegMaybe (ZmmReg 3) = Just (RealRegSingle REG_ZMM3) # endif # if defined(REG_ZMM4)-globalRegMaybe (ZmmReg 4 _ _ _) = Just (RealRegSingle REG_ZMM4)+globalRegMaybe (ZmmReg 4) = Just (RealRegSingle REG_ZMM4) # endif # if defined(REG_ZMM5)-globalRegMaybe (ZmmReg 5 _ _ _) = Just (RealRegSingle REG_ZMM5)+globalRegMaybe (ZmmReg 5) = Just (RealRegSingle REG_ZMM5) # endif # if defined(REG_ZMM6)-globalRegMaybe (ZmmReg 6 _ _ _) = Just (RealRegSingle REG_ZMM6)+globalRegMaybe (ZmmReg 6) = Just (RealRegSingle REG_ZMM6) # endif # endif # if defined(REG_Sp)
− includes/HsFFI.h
@@ -1,141 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 2000- *- * A mapping for Haskell types to C types, including the corresponding bounds.- * Intended to be used in conjuction with the FFI.- *- * WARNING: Keep this file and StgTypes.h in synch!- *- * ---------------------------------------------------------------------------*/--#pragma once--#if defined(__cplusplus)-extern "C" {-#endif--/* get types from GHC's runtime system */-#include "ghcconfig.h"-#include "stg/Types.h"--/* get limits for floating point types */-#include <float.h>--typedef StgChar HsChar;-typedef StgInt HsInt;-typedef StgInt8 HsInt8;-typedef StgInt16 HsInt16;-typedef StgInt32 HsInt32;-typedef StgInt64 HsInt64;-typedef StgWord HsWord;-typedef StgWord8 HsWord8;-typedef StgWord16 HsWord16;-typedef StgWord32 HsWord32;-typedef StgWord64 HsWord64;-typedef StgFloat HsFloat;-typedef StgDouble HsDouble;-typedef StgInt HsBool;-typedef void* HsPtr; /* this should better match StgAddr */-typedef void (*HsFunPtr)(void); /* this should better match StgAddr */-typedef void* HsStablePtr;--/* this should correspond to the type of StgChar in StgTypes.h */-#define HS_CHAR_MIN 0-#define HS_CHAR_MAX 0x10FFFF--/* is it true or not? */-#define HS_BOOL_FALSE 0-#define HS_BOOL_TRUE 1--#define HS_BOOL_MIN HS_BOOL_FALSE-#define HS_BOOL_MAX HS_BOOL_TRUE---#define HS_INT_MIN STG_INT_MIN-#define HS_INT_MAX STG_INT_MAX-#define HS_WORD_MAX STG_WORD_MAX--#define HS_INT8_MIN STG_INT8_MIN-#define HS_INT8_MAX STG_INT8_MAX-#define HS_INT16_MIN STG_INT16_MIN-#define HS_INT16_MAX STG_INT16_MAX-#define HS_INT32_MIN STG_INT32_MIN-#define HS_INT32_MAX STG_INT32_MAX-#define HS_INT64_MIN STG_INT64_MIN-#define HS_INT64_MAX STG_INT64_MAX-#define HS_WORD8_MAX STG_WORD8_MAX-#define HS_WORD16_MAX STG_WORD16_MAX-#define HS_WORD32_MAX STG_WORD32_MAX-#define HS_WORD64_MAX STG_WORD64_MAX--#define HS_FLOAT_RADIX FLT_RADIX-#define HS_FLOAT_ROUNDS FLT_ROUNDS-#define HS_FLOAT_EPSILON FLT_EPSILON-#define HS_FLOAT_DIG FLT_DIG-#define HS_FLOAT_MANT_DIG FLT_MANT_DIG-#define HS_FLOAT_MIN FLT_MIN-#define HS_FLOAT_MIN_EXP FLT_MIN_EXP-#define HS_FLOAT_MIN_10_EXP FLT_MIN_10_EXP-#define HS_FLOAT_MAX FLT_MAX-#define HS_FLOAT_MAX_EXP FLT_MAX_EXP-#define HS_FLOAT_MAX_10_EXP FLT_MAX_10_EXP--#define HS_DOUBLE_RADIX DBL_RADIX-#define HS_DOUBLE_ROUNDS DBL_ROUNDS-#define HS_DOUBLE_EPSILON DBL_EPSILON-#define HS_DOUBLE_DIG DBL_DIG-#define HS_DOUBLE_MANT_DIG DBL_MANT_DIG-#define HS_DOUBLE_MIN DBL_MIN-#define HS_DOUBLE_MIN_EXP DBL_MIN_EXP-#define HS_DOUBLE_MIN_10_EXP DBL_MIN_10_EXP-#define HS_DOUBLE_MAX DBL_MAX-#define HS_DOUBLE_MAX_EXP DBL_MAX_EXP-#define HS_DOUBLE_MAX_10_EXP DBL_MAX_10_EXP--extern void hs_init (int *argc, char **argv[]);-extern void hs_exit (void);-extern void hs_exit_nowait(void);-extern void hs_set_argv (int argc, char *argv[]);-extern void hs_thread_done (void);--extern void hs_perform_gc (void);--// Lock the stable pointer table. The table must be unlocked-// again before calling any Haskell functions, even if those-// functions do not manipulate stable pointers. The Haskell-// garbage collector will not be able to run until this lock-// is released! It is also forbidden to call hs_free_fun_ptr-// or any stable pointer-related FFI functions other than-// hs_free_stable_ptr_unsafe while the table is locked.-extern void hs_lock_stable_ptr_table (void);--// A deprecated synonym.-extern void hs_lock_stable_tables (void);--// Unlock the stable pointer table.-extern void hs_unlock_stable_ptr_table (void);--// A deprecated synonym.-extern void hs_unlock_stable_tables (void);--// Free a stable pointer assuming that the stable pointer-// table is already locked.-extern void hs_free_stable_ptr_unsafe (HsStablePtr sp);--extern void hs_free_stable_ptr (HsStablePtr sp);-extern void hs_free_fun_ptr (HsFunPtr fp);--extern StgPtr hs_spt_lookup(StgWord64 key1, StgWord64 key2);-extern int hs_spt_keys(StgPtr keys[], int szKeys);-extern int hs_spt_key_count (void);--extern void hs_try_putmvar (int capability, HsStablePtr sp);--/* -------------------------------------------------------------------------- */----#if defined(__cplusplus)-}-#endif
− includes/Rts.h
@@ -1,325 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 1998-2009- *- * RTS external APIs. This file declares everything that the GHC RTS- * exposes externally.- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * ---------------------------------------------------------------------------*/--#pragma once--#if defined(__cplusplus)-extern "C" {-#endif--/* We include windows.h very early, as on Win64 the CONTEXT type has- fields "R8", "R9" and "R10", which goes bad if we've already- #define'd those names for our own purposes (in stg/Regs.h) */-#if defined(HAVE_WINDOWS_H)-#include <windows.h>-#endif--#if !defined(IN_STG_CODE)-#define IN_STG_CODE 0-#endif-#include "Stg.h"--#include "HsFFI.h"-#include "RtsAPI.h"--// Turn off inlining when debugging - it obfuscates things-#if defined(DEBUG)-# undef STATIC_INLINE-# define STATIC_INLINE static-#endif--#include "rts/Types.h"-#include "rts/Time.h"--#if __GNUC__ >= 3-#define ATTRIBUTE_ALIGNED(n) __attribute__((aligned(n)))-#else-#define ATTRIBUTE_ALIGNED(n) /*nothing*/-#endif--// Symbols that are extern, but private to the RTS, are declared-// with visibility "hidden" to hide them outside the RTS shared-// library.-#if defined(HAS_VISIBILITY_HIDDEN)-#define RTS_PRIVATE GNUC3_ATTRIBUTE(visibility("hidden"))-#else-#define RTS_PRIVATE /* disabled: RTS_PRIVATE */-#endif--#if __GNUC__ >= 4-#define RTS_UNLIKELY(p) __builtin_expect((p),0)-#else-#define RTS_UNLIKELY(p) (p)-#endif--#if __GNUC__ >= 4-#define RTS_LIKELY(p) __builtin_expect(!!(p), 1)-#else-#define RTS_LIKELY(p) (p)-#endif--/* __builtin_unreachable is supported since GNU C 4.5 */-#if __GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 5)-#define RTS_UNREACHABLE __builtin_unreachable()-#else-#define RTS_UNREACHABLE abort()-#endif--/* Fix for mingw stat problem (done here so it's early enough) */-#if defined(mingw32_HOST_OS)-#define __MSVCRT__ 1-#endif--/* Needed to get the macro version of errno on some OSs, and also to- get prototypes for the _r versions of C library functions. */-#if !defined(_REENTRANT)-#define _REENTRANT 1-#endif--/*- * We often want to know the size of something in units of an- * StgWord... (rounded up, of course!)- */-#define ROUNDUP_BYTES_TO_WDS(n) (((n) + sizeof(W_) - 1) / sizeof(W_))--#define sizeofW(t) ROUNDUP_BYTES_TO_WDS(sizeof(t))--/* ------------------------------------------------------------------------------ Assertions and Debuggery-- CHECK(p) evaluates p and terminates with an error if p is false- ASSERT(p) like CHECK(p) if DEBUG is on, otherwise a no-op- -------------------------------------------------------------------------- */--void _assertFail(const char *filename, unsigned int linenum)- GNUC3_ATTRIBUTE(__noreturn__);--#define CHECK(predicate) \- if (predicate) \- /*null*/; \- else \- _assertFail(__FILE__, __LINE__)--#define CHECKM(predicate, msg, ...) \- if (predicate) \- /*null*/; \- else \- barf(msg, ##__VA_ARGS__)--#if !defined(DEBUG)-#define ASSERT(predicate) /* nothing */-#define ASSERTM(predicate,msg,...) /* nothing */-#else-#define ASSERT(predicate) CHECK(predicate)-#define ASSERTM(predicate,msg,...) CHECKM(predicate,msg,##__VA_ARGS__)-#endif /* DEBUG */--/*- * Use this on the RHS of macros which expand to nothing- * to make sure that the macro can be used in a context which- * demands a non-empty statement.- */--#define doNothing() do { } while (0)--#if defined(DEBUG)-#define USED_IF_DEBUG-#define USED_IF_NOT_DEBUG STG_UNUSED-#else-#define USED_IF_DEBUG STG_UNUSED-#define USED_IF_NOT_DEBUG-#endif--#if defined(THREADED_RTS)-#define USED_IF_THREADS-#define USED_IF_NOT_THREADS STG_UNUSED-#else-#define USED_IF_THREADS STG_UNUSED-#define USED_IF_NOT_THREADS-#endif--#if defined(PROFILING)-#define USED_IF_PROFILING-#define USED_IF_NOT_PROFILING STG_UNUSED-#else-#define USED_IF_PROFILING STG_UNUSED-#define USED_IF_NOT_PROFILING-#endif--#define FMT_SizeT "zu"-#define FMT_HexSizeT "zx"--/* ------------------------------------------------------------------------------ Include everything STG-ish- -------------------------------------------------------------------------- */--/* System headers: stdlib.h is needed so that we can use NULL. It must- * come after MachRegs.h, because stdlib.h might define some inline- * functions which may only be defined after register variables have- * been declared.- */-#include <stdlib.h>--#include "rts/Config.h"--/* Global constraints */-#include "rts/Constants.h"--/* Profiling information */-#include "rts/prof/CCS.h"-#include "rts/prof/LDV.h"--/* Parallel information */-#include "rts/OSThreads.h"-#include "rts/SpinLock.h"--#include "rts/Messages.h"-#include "rts/Threads.h"--/* Storage format definitions */-#include "rts/storage/FunTypes.h"-#include "rts/storage/InfoTables.h"-#include "rts/storage/Closures.h"-#include "rts/storage/Heap.h"-#include "rts/storage/ClosureTypes.h"-#include "rts/storage/TSO.h"-#include "stg/MiscClosures.h" /* InfoTables, closures etc. defined in the RTS */-#include "rts/storage/Block.h"-#include "rts/storage/ClosureMacros.h"-#include "rts/storage/MBlock.h"-#include "rts/storage/GC.h"--/* Other RTS external APIs */-#include "rts/Parallel.h"-#include "rts/Signals.h"-#include "rts/BlockSignals.h"-#include "rts/Hpc.h"-#include "rts/Flags.h"-#include "rts/Adjustor.h"-#include "rts/FileLock.h"-#include "rts/GetTime.h"-#include "rts/Globals.h"-#include "rts/IOManager.h"-#include "rts/Linker.h"-#include "rts/Ticky.h"-#include "rts/Timer.h"-#include "rts/StablePtr.h"-#include "rts/StableName.h"-#include "rts/TTY.h"-#include "rts/Utils.h"-#include "rts/PrimFloat.h"-#include "rts/Main.h"-#include "rts/Profiling.h"-#include "rts/StaticPtrTable.h"-#include "rts/Libdw.h"-#include "rts/LibdwPool.h"--/* Misc stuff without a home */-DLL_IMPORT_RTS extern char **prog_argv; /* so we can get at these from Haskell */-DLL_IMPORT_RTS extern int prog_argc;-DLL_IMPORT_RTS extern char *prog_name;--void reportStackOverflow(StgTSO* tso);-void reportHeapOverflow(void);--void stg_exit(int n) GNU_ATTRIBUTE(__noreturn__);--#if !defined(mingw32_HOST_OS)-int stg_sig_install (int, int, void *);-#endif--/* ------------------------------------------------------------------------------ Ways- -------------------------------------------------------------------------- */--// Returns non-zero if the RTS is a profiling version-int rts_isProfiled(void);--// Returns non-zero if the RTS is a dynamically-linked version-int rts_isDynamic(void);--/* ------------------------------------------------------------------------------ RTS Exit codes- -------------------------------------------------------------------------- */--/* 255 is allegedly used by dynamic linkers to report linking failure */-#define EXIT_INTERNAL_ERROR 254-#define EXIT_DEADLOCK 253-#define EXIT_INTERRUPTED 252-#define EXIT_HEAPOVERFLOW 251-#define EXIT_KILLED 250--/* ------------------------------------------------------------------------------ Miscellaneous garbage- -------------------------------------------------------------------------- */--#if defined(DEBUG)-#define TICK_VAR(arity) \- extern StgInt SLOW_CALLS_##arity; \- extern StgInt RIGHT_ARITY_##arity; \- extern StgInt TAGGED_PTR_##arity;--extern StgInt TOTAL_CALLS;--TICK_VAR(1)-TICK_VAR(2)-#endif--/* ------------------------------------------------------------------------------ Assertions and Debuggery- -------------------------------------------------------------------------- */--#define IF_RTSFLAGS(c,s) if (RtsFlags.c) { s; } doNothing()--#if defined(DEBUG)-#if IN_STG_CODE-#define IF_DEBUG(c,s) if (RtsFlags[0].DebugFlags.c) { s; } doNothing()-#else-#define IF_DEBUG(c,s) if (RtsFlags.DebugFlags.c) { s; } doNothing()-#endif-#else-#define IF_DEBUG(c,s) doNothing()-#endif--#if defined(DEBUG)-#define DEBUG_ONLY(s) s-#else-#define DEBUG_ONLY(s) doNothing()-#endif--#if defined(DEBUG)-#define DEBUG_IS_ON 1-#else-#define DEBUG_IS_ON 0-#endif--/* ------------------------------------------------------------------------------ Useful macros and inline functions- -------------------------------------------------------------------------- */--#if defined(__GNUC__)-#define SUPPORTS_TYPEOF-#endif--#if defined(SUPPORTS_TYPEOF)-#define stg_min(a,b) ({typeof(a) _a = (a), _b = (b); _a <= _b ? _a : _b; })-#define stg_max(a,b) ({typeof(a) _a = (a), _b = (b); _a <= _b ? _b : _a; })-#else-#define stg_min(a,b) ((a) <= (b) ? (a) : (b))-#define stg_max(a,b) ((a) <= (b) ? (b) : (a))-#endif--/* -------------------------------------------------------------------------- */--#if defined(__cplusplus)-}-#endif
− includes/RtsAPI.h
@@ -1,487 +0,0 @@-/* ----------------------------------------------------------------------------- *- * (c) The GHC Team, 1998-2004- *- * API for invoking Haskell functions via the RTS- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * --------------------------------------------------------------------------*/--#pragma once--#if defined(__cplusplus)-extern "C" {-#endif--#include "HsFFI.h"-#include "rts/Time.h"-#include "rts/EventLogWriter.h"--/*- * Running the scheduler- */-typedef enum {- NoStatus, /* not finished yet */- Success, /* completed successfully */- Killed, /* uncaught exception */- Interrupted, /* stopped in response to a call to interruptStgRts */- HeapExhausted /* out of memory */-} SchedulerStatus;--typedef struct StgClosure_ *HaskellObj;--/*- * An abstract type representing the token returned by rts_lock() and- * used when allocating objects and threads in the RTS.- */-typedef struct Capability_ Capability;--/*- * The public view of a Capability: we can be sure it starts with- * these two components (but it may have more private fields).- */-typedef struct CapabilityPublic_ {- StgFunTable f;- StgRegTable r;-} CapabilityPublic;--/* ----------------------------------------------------------------------------- RTS configuration settings, for passing to hs_init_ghc()- ------------------------------------------------------------------------- */--typedef enum {- RtsOptsNone, // +RTS causes an error- RtsOptsIgnore, // Ignore command line arguments- RtsOptsIgnoreAll, // Ignore command line and Environment arguments- RtsOptsSafeOnly, // safe RTS options allowed; others cause an error- RtsOptsAll // all RTS options allowed- } RtsOptsEnabledEnum;--struct GCDetails_;--// The RtsConfig struct is passed (by value) to hs_init_ghc(). The-// reason for using a struct is extensibility: we can add more-// fields to this later without breaking existing client code.-typedef struct {-- // Whether to interpret +RTS options on the command line- RtsOptsEnabledEnum rts_opts_enabled;-- // Whether to give RTS flag suggestions- HsBool rts_opts_suggestions;-- // additional RTS options- const char *rts_opts;-- // True if GHC was not passed -no-hs-main- HsBool rts_hs_main;-- // Whether to retain CAFs (default: false)- HsBool keep_cafs;-- // Writer a for eventlog.- const EventLogWriter *eventlog_writer;-- // Called before processing command-line flags, so that default- // settings for RtsFlags can be provided.- void (* defaultsHook) (void);-- // Called just before exiting- void (* onExitHook) (void);-- // Called on a stack overflow, before exiting- void (* stackOverflowHook) (W_ stack_size);-- // Called on heap overflow, before exiting- void (* outOfHeapHook) (W_ request_size, W_ heap_size);-- // Called when malloc() fails, before exiting- void (* mallocFailHook) (W_ request_size /* in bytes */, const char *msg);-- // Called for every GC- void (* gcDoneHook) (const struct GCDetails_ *stats);-- // Called when GC sync takes too long (+RTS --long-gc-sync=<time>)- void (* longGCSync) (uint32_t this_cap, Time time_ns);- void (* longGCSyncEnd) (Time time_ns);-} RtsConfig;--// Clients should start with defaultRtsConfig and then customise it.-// Bah, I really wanted this to be a const struct value, but it seems-// you can't do that in C (it generates code).-extern const RtsConfig defaultRtsConfig;--/* ------------------------------------------------------------------------------ Statistics- -------------------------------------------------------------------------- */--//-// Stats about a single GC-//-typedef struct GCDetails_ {- // The generation number of this GC- uint32_t gen;- // Number of threads used in this GC- uint32_t threads;- // Number of bytes allocated since the previous GC- uint64_t allocated_bytes;- // Total amount of live data in the heap (incliudes large + compact data).- // Updated after every GC. Data in uncollected generations (in minor GCs)- // are considered live.- uint64_t live_bytes;- // Total amount of live data in large objects- uint64_t large_objects_bytes;- // Total amount of live data in compact regions- uint64_t compact_bytes;- // Total amount of slop (wasted memory)- uint64_t slop_bytes;- // Total amount of memory in use by the RTS- uint64_t mem_in_use_bytes;- // Total amount of data copied during this GC- uint64_t copied_bytes;- // In parallel GC, the max amount of data copied by any one thread- uint64_t par_max_copied_bytes;- // In parallel GC, the amount of balanced data copied by all threads- uint64_t par_balanced_copied_bytes;- // The time elapsed during synchronisation before GC- Time sync_elapsed_ns;- // The CPU time used during GC itself- Time cpu_ns;- // The time elapsed during GC itself- Time elapsed_ns;-} GCDetails;--//-// Stats about the RTS currently, and since the start of execution-//-typedef struct _RTSStats {-- // ------------------------------------ // Cumulative stats about memory use-- // Total number of GCs- uint32_t gcs;- // Total number of major (oldest generation) GCs- uint32_t major_gcs;- // Total bytes allocated- uint64_t allocated_bytes;- // Maximum live data (including large objects + compact regions) in the- // heap. Updated after a major GC.- uint64_t max_live_bytes;- // Maximum live data in large objects- uint64_t max_large_objects_bytes;- // Maximum live data in compact regions- uint64_t max_compact_bytes;- // Maximum slop- uint64_t max_slop_bytes;- // Maximum memory in use by the RTS- uint64_t max_mem_in_use_bytes;- // Sum of live bytes across all major GCs. Divided by major_gcs- // gives the average live data over the lifetime of the program.- uint64_t cumulative_live_bytes;- // Sum of copied_bytes across all GCs- uint64_t copied_bytes;- // Sum of copied_bytes across all parallel GCs- uint64_t par_copied_bytes;- // Sum of par_max_copied_bytes across all parallel GCs- uint64_t cumulative_par_max_copied_bytes;- // Sum of par_balanced_copied_byes across all parallel GCs.- uint64_t cumulative_par_balanced_copied_bytes;-- // ------------------------------------ // Cumulative stats about time use- // (we use signed values here because due to inaccuracies in timers- // the values can occasionally go slightly negative)-- // Total CPU time used by the init phase- Time init_cpu_ns;- // Total elapsed time used by the init phase- Time init_elapsed_ns;- // Total CPU time used by the mutator- Time mutator_cpu_ns;- // Total elapsed time used by the mutator- Time mutator_elapsed_ns;- // Total CPU time used by the GC- Time gc_cpu_ns;- // Total elapsed time used by the GC- Time gc_elapsed_ns;- // Total CPU time (at the previous GC)- Time cpu_ns;- // Total elapsed time (at the previous GC)- Time elapsed_ns;-- // ------------------------------------ // Stats about the most recent GC-- GCDetails gc;-- // ------------------------------------ // Internal Counters-- // The number of times a GC thread spun on its 'gc_spin' lock.- // Will be zero if the rts was not built with PROF_SPIN- uint64_t gc_spin_spin;- // The number of times a GC thread yielded on its 'gc_spin' lock.- // Will be zero if the rts was not built with PROF_SPIN- uint64_t gc_spin_yield;- // The number of times a GC thread spun on its 'mut_spin' lock.- // Will be zero if the rts was not built with PROF_SPIN- uint64_t mut_spin_spin;- // The number of times a GC thread yielded on its 'mut_spin' lock.- // Will be zero if the rts was not built with PROF_SPIN- uint64_t mut_spin_yield;- // The number of times a GC thread has checked for work across all parallel- // GCs- uint64_t any_work;- // The number of times a GC thread has checked for work and found none- // across all parallel GCs- uint64_t no_work;- // The number of times a GC thread has iterated it's outer loop across all- // parallel GCs- uint64_t scav_find_work;-} RTSStats;--void getRTSStats (RTSStats *s);-int getRTSStatsEnabled (void);--// Returns the total number of bytes allocated since the start of the program.-// TODO: can we remove this?-uint64_t getAllocations (void);--/* ----------------------------------------------------------------------------- Starting up and shutting down the Haskell RTS.- ------------------------------------------------------------------------- */--/* DEPRECATED, use hs_init() or hs_init_ghc() instead */-extern void startupHaskell ( int argc, char *argv[],- void (*init_root)(void) );--/* DEPRECATED, use hs_exit() instead */-extern void shutdownHaskell ( void );--/* Like hs_init(), but allows rtsopts. For more complicated usage,- * use hs_init_ghc. */-extern void hs_init_with_rtsopts (int *argc, char **argv[]);--/*- * GHC-specific version of hs_init() that allows specifying whether- * +RTS ... -RTS options are allowed or not (default: only "safe"- * options are allowed), and allows passing an option string that is- * to be interpreted by the RTS only, not passed to the program.- */-extern void hs_init_ghc (int *argc, char **argv[], // program arguments- RtsConfig rts_config); // RTS configuration--extern void shutdownHaskellAndExit (int exitCode, int fastExit)- GNUC3_ATTRIBUTE(__noreturn__);--#if !defined(mingw32_HOST_OS)-extern void shutdownHaskellAndSignal (int sig, int fastExit)- GNUC3_ATTRIBUTE(__noreturn__);-#endif--extern void getProgArgv ( int *argc, char **argv[] );-extern void setProgArgv ( int argc, char *argv[] );-extern void getFullProgArgv ( int *argc, char **argv[] );-extern void setFullProgArgv ( int argc, char *argv[] );-extern void freeFullProgArgv ( void ) ;--/* exit() override */-extern void (*exitFn)(int);--/* ----------------------------------------------------------------------------- Locking.-- You have to surround all access to the RtsAPI with these calls.- ------------------------------------------------------------------------- */--// acquires a token which may be used to create new objects and-// evaluate them.-Capability *rts_lock (void);--// releases the token acquired with rts_lock().-void rts_unlock (Capability *token);--// If you are in a context where you know you have a current capability but-// do not know what it is, then use this to get it. Basically this only-// applies to "unsafe" foreign calls (as unsafe foreign calls are made with-// the capability held).-//-// WARNING: There is *no* guarantee this returns anything sensible (eg NULL)-// when there is no current capability.-Capability *rts_unsafeGetMyCapability (void);--/* ----------------------------------------------------------------------------- Which cpu should the OS thread and Haskell thread run on?-- 1. Run the current thread on the given capability:- rts_setInCallCapability(cap, 0);-- 2. Run the current thread on the given capability and set the cpu affinity- for this thread:- rts_setInCallCapability(cap, 1);-- 3. Run the current thread on the given numa node:- rts_pinThreadToNumaNode(node);-- 4. Run the current thread on the given capability and on the given numa node:- rts_setInCallCapability(cap, 0);- rts_pinThreadToNumaNode(cap);- ------------------------------------------------------------------------- */--// Specify the Capability that the current OS thread should run on when it calls-// into Haskell. The actual capability will be calculated as the supplied-// value modulo the number of enabled Capabilities.-//-// Note that the thread may still be migrated by the RTS scheduler, but that-// will only happen if there are multiple threads running on one Capability and-// another Capability is free.-//-// If affinity is non-zero, the current thread will be bound to-// specific CPUs according to the prevailing affinity policy for the-// specified capability, set by either +RTS -qa or +RTS --numa.-void rts_setInCallCapability (int preferred_capability, int affinity);--// Specify the CPU Node that the current OS thread should run on when it calls-// into Haskell. The argument can be either a node number or capability number.-// The actual node will be calculated as the supplied value modulo the number-// of numa nodes.-void rts_pinThreadToNumaNode (int node);--/* ----------------------------------------------------------------------------- Building Haskell objects from C datatypes.- ------------------------------------------------------------------------- */-HaskellObj rts_mkChar ( Capability *, HsChar c );-HaskellObj rts_mkInt ( Capability *, HsInt i );-HaskellObj rts_mkInt8 ( Capability *, HsInt8 i );-HaskellObj rts_mkInt16 ( Capability *, HsInt16 i );-HaskellObj rts_mkInt32 ( Capability *, HsInt32 i );-HaskellObj rts_mkInt64 ( Capability *, HsInt64 i );-HaskellObj rts_mkWord ( Capability *, HsWord w );-HaskellObj rts_mkWord8 ( Capability *, HsWord8 w );-HaskellObj rts_mkWord16 ( Capability *, HsWord16 w );-HaskellObj rts_mkWord32 ( Capability *, HsWord32 w );-HaskellObj rts_mkWord64 ( Capability *, HsWord64 w );-HaskellObj rts_mkPtr ( Capability *, HsPtr a );-HaskellObj rts_mkFunPtr ( Capability *, HsFunPtr a );-HaskellObj rts_mkFloat ( Capability *, HsFloat f );-HaskellObj rts_mkDouble ( Capability *, HsDouble f );-HaskellObj rts_mkStablePtr ( Capability *, HsStablePtr s );-HaskellObj rts_mkBool ( Capability *, HsBool b );-HaskellObj rts_mkString ( Capability *, char *s );--HaskellObj rts_apply ( Capability *, HaskellObj, HaskellObj );--/* ----------------------------------------------------------------------------- Deconstructing Haskell objects- ------------------------------------------------------------------------- */-HsChar rts_getChar ( HaskellObj );-HsInt rts_getInt ( HaskellObj );-HsInt8 rts_getInt8 ( HaskellObj );-HsInt16 rts_getInt16 ( HaskellObj );-HsInt32 rts_getInt32 ( HaskellObj );-HsInt64 rts_getInt64 ( HaskellObj );-HsWord rts_getWord ( HaskellObj );-HsWord8 rts_getWord8 ( HaskellObj );-HsWord16 rts_getWord16 ( HaskellObj );-HsWord32 rts_getWord32 ( HaskellObj );-HsWord64 rts_getWord64 ( HaskellObj );-HsPtr rts_getPtr ( HaskellObj );-HsFunPtr rts_getFunPtr ( HaskellObj );-HsFloat rts_getFloat ( HaskellObj );-HsDouble rts_getDouble ( HaskellObj );-HsStablePtr rts_getStablePtr ( HaskellObj );-HsBool rts_getBool ( HaskellObj );--/* ----------------------------------------------------------------------------- Evaluating Haskell expressions-- The versions ending in '_' allow you to specify an initial stack size.- Note that these calls may cause Garbage Collection, so all HaskellObj- references are rendered invalid by these calls.-- All of these functions take a (Capability **) - there is a- Capability pointer both input and output. We use an inout- parameter because this is less error-prone for the client than a- return value - the client could easily forget to use the return- value, whereas incorrectly using an inout parameter will usually- result in a type error.- ------------------------------------------------------------------------- */--void rts_eval (/* inout */ Capability **,- /* in */ HaskellObj p,- /* out */ HaskellObj *ret);--void rts_eval_ (/* inout */ Capability **,- /* in */ HaskellObj p,- /* in */ unsigned int stack_size,- /* out */ HaskellObj *ret);--void rts_evalIO (/* inout */ Capability **,- /* in */ HaskellObj p,- /* out */ HaskellObj *ret);--void rts_evalStableIOMain (/* inout */ Capability **,- /* in */ HsStablePtr s,- /* out */ HsStablePtr *ret);--void rts_evalStableIO (/* inout */ Capability **,- /* in */ HsStablePtr s,- /* out */ HsStablePtr *ret);--void rts_evalLazyIO (/* inout */ Capability **,- /* in */ HaskellObj p,- /* out */ HaskellObj *ret);--void rts_evalLazyIO_ (/* inout */ Capability **,- /* in */ HaskellObj p,- /* in */ unsigned int stack_size,- /* out */ HaskellObj *ret);--void rts_checkSchedStatus (char* site, Capability *);--SchedulerStatus rts_getSchedStatus (Capability *cap);--/*- * The RTS allocates some thread-local data when you make a call into- * Haskell using one of the rts_eval() functions. This data is not- * normally freed until hs_exit(). If you want to free it earlier- * than this, perhaps because the thread is about to exit, then call- * rts_done() from the thread.- *- * It is safe to make more rts_eval() calls after calling rts_done(),- * but the next one will cause allocation of the thread-local memory- * again.- */-void rts_done (void);--/* --------------------------------------------------------------------------- Wrapper closures-- These are used by foreign export and foreign import "wrapper" stubs.- ----------------------------------------------------------------------- */--// When producing Windows DLLs the we need to know which symbols are in the-// local package/DLL vs external ones.-//-// Note that RtsAPI.h is also included by foreign export stubs in-// the base package itself.-//-#if defined(COMPILING_WINDOWS_DLL) && !defined(COMPILING_BASE_PACKAGE)-__declspec(dllimport) extern StgWord base_GHCziTopHandler_runIO_closure[];-__declspec(dllimport) extern StgWord base_GHCziTopHandler_runNonIO_closure[];-#else-extern StgWord base_GHCziTopHandler_runIO_closure[];-extern StgWord base_GHCziTopHandler_runNonIO_closure[];-#endif--#define runIO_closure base_GHCziTopHandler_runIO_closure-#define runNonIO_closure base_GHCziTopHandler_runNonIO_closure--/* ------------------------------------------------------------------------ */--#if defined(__cplusplus)-}-#endif
− includes/Stg.h
@@ -1,599 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 1998-2009- *- * Top-level include file for everything required when compiling .hc- * code. NOTE: in .hc files, Stg.h must be included *before* any- * other headers, because we define some register variables which must- * be done before any inline functions are defined (some system- * headers have been known to define the odd inline function).- *- * We generally try to keep as little visible as possible when- * compiling .hc files. So for example the definitions of the- * InfoTable structs, closure structs and other RTS types are not- * visible here. The compiler knows enough about the representations- * of these types to generate code which manipulates them directly- * with pointer arithmetic.- *- * In ordinary C code, do not #include this file directly: #include- * "Rts.h" instead.- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * ---------------------------------------------------------------------------*/--#pragma once--#if !(__STDC_VERSION__ >= 199901L) && !(__cplusplus >= 201103L)-# error __STDC_VERSION__ does not advertise C99, C++11 or later-#endif--/*- * If we are compiling a .hc file, then we want all the register- * variables. This is the what happens if you #include "Stg.h" first:- * we assume this is a .hc file, and set IN_STG_CODE==1, which later- * causes the register variables to be enabled in stg/Regs.h.- *- * If instead "Rts.h" is included first, then we are compiling a- * vanilla C file. Everything from Stg.h is provided, except that- * IN_STG_CODE is not defined, and the register variables will not be- * active.- */-#if !defined(IN_STG_CODE)-# define IN_STG_CODE 1--// Turn on C99 for .hc code. This gives us the INFINITY and NAN-// constants from math.h, which we occasionally need to use in .hc (#1861)-# define _ISOC99_SOURCE--// We need _BSD_SOURCE so that math.h defines things like gamma-// on Linux-# define _BSD_SOURCE--// On AIX we need _BSD defined, otherwise <math.h> includes <stdlib.h>-# if defined(_AIX)-# define _BSD 1-# endif--// '_BSD_SOURCE' is deprecated since glibc-2.20-// in favour of '_DEFAULT_SOURCE'-# define _DEFAULT_SOURCE-#endif--#if IN_STG_CODE == 0 || defined(llvm_CC_FLAVOR)-// C compilers that use an LLVM back end (clang or llvm-gcc) do not-// correctly support global register variables so we make sure that-// we do not declare them for these compilers.-# define NO_GLOBAL_REG_DECLS /* don't define fixed registers */-#endif--/* Configuration */-#include "ghcconfig.h"--/* The code generator calls the math functions directly in .hc code.- NB. after configuration stuff above, because this sets #defines- that depend on config info, such as __USE_FILE_OFFSET64 */-#include <math.h>--// On Solaris, we don't get the INFINITY and NAN constants unless we-// #define _STDC_C99, and we can't do that unless we also use -std=c99,-// because _STDC_C99 causes the headers to use C99 syntax (e.g. restrict).-// We aren't ready for -std=c99 yet, so define INFINITY/NAN by hand using-// the gcc builtins.-#if !defined(INFINITY)-#if defined(__GNUC__)-#define INFINITY __builtin_inf()-#else-#error No definition for INFINITY-#endif-#endif--#if !defined(NAN)-#if defined(__GNUC__)-#define NAN __builtin_nan("")-#else-#error No definition for NAN-#endif-#endif--/* ------------------------------------------------------------------------------ Useful definitions- -------------------------------------------------------------------------- */--/*- * The C backend likes to refer to labels by just mentioning their- * names. However, when a symbol is declared as a variable in C, the- * C compiler will implicitly dereference it when it occurs in source.- * So we must subvert this behaviour for .hc files by declaring- * variables as arrays, which eliminates the implicit dereference.- */-#if IN_STG_CODE-#define RTS_VAR(x) (x)[]-#define RTS_DEREF(x) (*(x))-#else-#define RTS_VAR(x) x-#define RTS_DEREF(x) x-#endif--/* bit macros- */-#define BITS_PER_BYTE 8-#define BITS_IN(x) (BITS_PER_BYTE * sizeof(x))--/* Compute offsets of struct fields- */-#define STG_FIELD_OFFSET(s_type, field) ((StgWord)&(((s_type*)0)->field))--/*- * 'Portable' inlining:- * INLINE_HEADER is for inline functions in header files (macros)- * STATIC_INLINE is for inline functions in source files- * EXTERN_INLINE is for functions that we want to inline sometimes- * (we also compile a static version of the function; see Inlines.c)- */--// We generally assume C99 semantics albeit these two definitions work fine even-// when gnu90 semantics are active (i.e. when __GNUC_GNU_INLINE__ is defined or-// when a GCC older than 4.2 is used)-//-// The problem, however, is with 'extern inline' whose semantics significantly-// differs between gnu90 and C99-#define INLINE_HEADER static inline-#define STATIC_INLINE static inline--// Figure out whether `__attributes__((gnu_inline))` is needed-// to force gnu90-style 'external inline' semantics.-#if defined(FORCE_GNU_INLINE)-// disable auto-detection since HAVE_GNU_INLINE has been defined externally-#elif defined(__GNUC_GNU_INLINE__) && __GNUC__ == 4 && __GNUC_MINOR__ == 2-// GCC 4.2.x didn't properly support C99 inline semantics (GCC 4.3 was the first-// release to properly support C99 inline semantics), and therefore warned when-// using 'extern inline' while in C99 mode unless `__attributes__((gnu_inline))`-// was explicitly set.-# define FORCE_GNU_INLINE 1-#endif--#if defined(FORCE_GNU_INLINE)-// Force compiler into gnu90 semantics-# if defined(KEEP_INLINES)-# define EXTERN_INLINE inline __attribute__((gnu_inline))-# else-# define EXTERN_INLINE extern inline __attribute__((gnu_inline))-# endif-#elif defined(__GNUC_GNU_INLINE__)-// we're currently in gnu90 inline mode by default and-// __attribute__((gnu_inline)) may not be supported, so better leave it off-# if defined(KEEP_INLINES)-# define EXTERN_INLINE inline-# else-# define EXTERN_INLINE extern inline-# endif-#else-// Assume C99 semantics (yes, this curiously results in swapped definitions!)-// This is the preferred branch, and at some point we may drop support for-// compilers not supporting C99 semantics altogether.-# if defined(KEEP_INLINES)-# define EXTERN_INLINE extern inline-# else-# define EXTERN_INLINE inline-# endif-#endif---/*- * GCC attributes- */-#if defined(__GNUC__)-#define GNU_ATTRIBUTE(at) __attribute__((at))-#else-#define GNU_ATTRIBUTE(at)-#endif--#if __GNUC__ >= 3-#define GNUC3_ATTRIBUTE(at) __attribute__((at))-#else-#define GNUC3_ATTRIBUTE(at)-#endif--/* Used to mark a switch case that falls-through */-#if (defined(__GNUC__) && __GNUC__ >= 7)-// N.B. Don't enable fallthrough annotations when compiling with Clang.-// Apparently clang doesn't enable implicitly fallthrough warnings by default-// http://llvm.org/viewvc/llvm-project?revision=167655&view=revision-// when compiling C and the attribute cause warnings of their own (#16019).-#define FALLTHROUGH GNU_ATTRIBUTE(fallthrough)-#else-#define FALLTHROUGH ((void)0)-#endif /* __GNUC__ >= 7 */--#if !defined(DEBUG) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 3))-#define GNUC_ATTR_HOT __attribute__((hot))-#else-#define GNUC_ATTR_HOT /* nothing */-#endif--#define STG_UNUSED GNUC3_ATTRIBUTE(__unused__)--/* Prevent functions from being optimized.- See Note [Windows Stack allocations] */-#if defined(__clang__)-#define STG_NO_OPTIMIZE __attribute__((optnone))-#elif defined(__GNUC__) || defined(__GNUG__)-#define STG_NO_OPTIMIZE __attribute__((optimize("O0")))-#else-#define STG_NO_OPTIMIZE /* nothing */-#endif--/* ------------------------------------------------------------------------------ Global type definitions- -------------------------------------------------------------------------- */--#include "MachDeps.h"-#include "stg/Types.h"--/* ------------------------------------------------------------------------------ Shorthand forms- -------------------------------------------------------------------------- */--typedef StgChar C_;-typedef StgWord W_;-typedef StgWord* P_;-typedef StgInt I_;-typedef StgWord StgWordArray[];-typedef StgFunPtr F_;--/* byte arrays (and strings): */-#define EB_(X) extern const char X[]-#define IB_(X) static const char X[]-/* static (non-heap) closures (requires alignment for pointer tagging): */-#define EC_(X) extern StgWordArray (X) GNU_ATTRIBUTE(aligned (8))-#define IC_(X) static StgWordArray (X) GNU_ATTRIBUTE(aligned (8))-/* writable data (does not require alignment): */-#define ERW_(X) extern StgWordArray (X)-#define IRW_(X) static StgWordArray (X)-/* read-only data (does not require alignment): */-#define ERO_(X) extern const StgWordArray (X)-#define IRO_(X) static const StgWordArray (X)-/* stg-native functions: */-#define IF_(f) static StgFunPtr GNUC3_ATTRIBUTE(used) f(void)-#define FN_(f) StgFunPtr f(void)-#define EF_(f) StgFunPtr f(void) /* External Cmm functions */-/* foreign functions: */-#define EFF_(f) void f() /* See Note [External function prototypes] */--/* Note [External function prototypes] See #8965, #11395- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In generated C code we need to distinct between two types-of external symbols:-1. Cmm functions declared by 'EF_' macro (External Functions)-2. C functions declared by 'EFF_' macro (External Foreign Functions)--Cmm functions are simple as they are internal to GHC.--C functions are trickier:--The external-function macro EFF_(F) used to be defined as- extern StgFunPtr f(void)-i.e a function of zero arguments. On most platforms this doesn't-matter very much: calls to these functions put the parameters in the-usual places anyway, and (with the exception of varargs) things just-work.--However, the ELFv2 ABI on ppc64 optimises stack allocation-(http://gcc.gnu.org/ml/gcc-patches/2013-11/msg01149.html): a call to a-function that has a prototype, is not varargs, and receives all parameters-in registers rather than on the stack does not require the caller to-allocate an argument save area. The incorrect prototypes cause GCC to-believe that all functions declared this way can be called without an-argument save area, but if the callee has sufficiently many arguments then-it will expect that area to be present, and will thus corrupt the caller's-stack. This happens in particular with calls to runInteractiveProcess in-libraries/process/cbits/runProcess.c, and led to #8965.--The simplest fix appears to be to declare these external functions with an-unspecified argument list rather than a void argument list. This is no-worse for platforms that don't care either way, and allows a successful-bootstrap of GHC 7.8 on little-endian Linux ppc64 (which uses the ELFv2-ABI).--Another case is m68k ABI where 'void*' return type is returned by 'a0'-register while 'long' return type is returned by 'd0'. Thus we trick-external prototype return neither of these types to workaround #11395.-*/---/* ------------------------------------------------------------------------------ Tail calls- -------------------------------------------------------------------------- */--#define JMP_(cont) return((StgFunPtr)(cont))--/* ------------------------------------------------------------------------------ Other Stg stuff...- -------------------------------------------------------------------------- */--#include "stg/DLL.h"-#include "stg/RtsMachRegs.h"-#include "stg/Regs.h"-#include "stg/Ticky.h"--#if IN_STG_CODE-/*- * This is included later for RTS sources, after definitions of- * StgInfoTable, StgClosure and so on.- */-#include "stg/MiscClosures.h"-#endif--#include "stg/Prim.h" /* ghc-prim fallbacks */-#include "stg/SMP.h" // write_barrier() inline is required--/* ------------------------------------------------------------------------------ Moving Floats and Doubles-- ASSIGN_FLT is for assigning a float to memory (usually the- stack/heap). The memory address is guaranteed to be- StgWord aligned (currently == sizeof(void *)).-- PK_FLT is for pulling a float out of memory. The memory is- guaranteed to be StgWord aligned.- -------------------------------------------------------------------------- */--INLINE_HEADER void ASSIGN_FLT (W_ [], StgFloat);-INLINE_HEADER StgFloat PK_FLT (W_ []);--#if ALIGNMENT_FLOAT <= ALIGNMENT_VOID_P--INLINE_HEADER void ASSIGN_FLT(W_ p_dest[], StgFloat src) { *(StgFloat *)p_dest = src; }-INLINE_HEADER StgFloat PK_FLT (W_ p_src[]) { return *(StgFloat *)p_src; }--#else /* ALIGNMENT_FLOAT > ALIGNMENT_UNSIGNED_INT */--INLINE_HEADER void ASSIGN_FLT(W_ p_dest[], StgFloat src)-{- float_thing y;- y.f = src;- *p_dest = y.fu;-}--INLINE_HEADER StgFloat PK_FLT(W_ p_src[])-{- float_thing y;- y.fu = *p_src;- return(y.f);-}--#endif /* ALIGNMENT_FLOAT > ALIGNMENT_VOID_P */--#if ALIGNMENT_DOUBLE <= ALIGNMENT_VOID_P--INLINE_HEADER void ASSIGN_DBL (W_ [], StgDouble);-INLINE_HEADER StgDouble PK_DBL (W_ []);--INLINE_HEADER void ASSIGN_DBL(W_ p_dest[], StgDouble src) { *(StgDouble *)p_dest = src; }-INLINE_HEADER StgDouble PK_DBL (W_ p_src[]) { return *(StgDouble *)p_src; }--#else /* ALIGNMENT_DOUBLE > ALIGNMENT_VOID_P */--/* Sparc uses two floating point registers to hold a double. We can- * write ASSIGN_DBL and PK_DBL by directly accessing the registers- * independently - unfortunately this code isn't writable in C, we- * have to use inline assembler.- */-#if defined(sparc_HOST_ARCH)--#define ASSIGN_DBL(dst0,src) \- { StgPtr dst = (StgPtr)(dst0); \- __asm__("st %2,%0\n\tst %R2,%1" : "=m" (((P_)(dst))[0]), \- "=m" (((P_)(dst))[1]) : "f" (src)); \- }--#define PK_DBL(src0) \- ( { StgPtr src = (StgPtr)(src0); \- register double d; \- __asm__("ld %1,%0\n\tld %2,%R0" : "=f" (d) : \- "m" (((P_)(src))[0]), "m" (((P_)(src))[1])); d; \- } )--#else /* ! sparc_HOST_ARCH */--INLINE_HEADER void ASSIGN_DBL (W_ [], StgDouble);-INLINE_HEADER StgDouble PK_DBL (W_ []);--typedef struct- { StgWord dhi;- StgWord dlo;- } unpacked_double;--typedef union- { StgDouble d;- unpacked_double du;- } double_thing;--INLINE_HEADER void ASSIGN_DBL(W_ p_dest[], StgDouble src)-{- double_thing y;- y.d = src;- p_dest[0] = y.du.dhi;- p_dest[1] = y.du.dlo;-}--/* GCC also works with this version, but it generates- the same code as the previous one, and is not ANSI--#define ASSIGN_DBL( p_dest, src ) \- *p_dest = ((double_thing) src).du.dhi; \- *(p_dest+1) = ((double_thing) src).du.dlo \-*/--INLINE_HEADER StgDouble PK_DBL(W_ p_src[])-{- double_thing y;- y.du.dhi = p_src[0];- y.du.dlo = p_src[1];- return(y.d);-}--#endif /* ! sparc_HOST_ARCH */--#endif /* ALIGNMENT_DOUBLE > ALIGNMENT_UNSIGNED_INT */---/* ------------------------------------------------------------------------------ Moving 64-bit quantities around-- ASSIGN_Word64 assign an StgWord64/StgInt64 to a memory location- PK_Word64 load an StgWord64/StgInt64 from a amemory location-- In both cases the memory location might not be 64-bit aligned.- -------------------------------------------------------------------------- */--#if SIZEOF_HSWORD == 4--typedef struct- { StgWord dhi;- StgWord dlo;- } unpacked_double_word;--typedef union- { StgInt64 i;- unpacked_double_word iu;- } int64_thing;--typedef union- { StgWord64 w;- unpacked_double_word wu;- } word64_thing;--INLINE_HEADER void ASSIGN_Word64(W_ p_dest[], StgWord64 src)-{- word64_thing y;- y.w = src;- p_dest[0] = y.wu.dhi;- p_dest[1] = y.wu.dlo;-}--INLINE_HEADER StgWord64 PK_Word64(W_ p_src[])-{- word64_thing y;- y.wu.dhi = p_src[0];- y.wu.dlo = p_src[1];- return(y.w);-}--INLINE_HEADER void ASSIGN_Int64(W_ p_dest[], StgInt64 src)-{- int64_thing y;- y.i = src;- p_dest[0] = y.iu.dhi;- p_dest[1] = y.iu.dlo;-}--INLINE_HEADER StgInt64 PK_Int64(W_ p_src[])-{- int64_thing y;- y.iu.dhi = p_src[0];- y.iu.dlo = p_src[1];- return(y.i);-}--#elif SIZEOF_VOID_P == 8--INLINE_HEADER void ASSIGN_Word64(W_ p_dest[], StgWord64 src)-{- p_dest[0] = src;-}--INLINE_HEADER StgWord64 PK_Word64(W_ p_src[])-{- return p_src[0];-}--INLINE_HEADER void ASSIGN_Int64(W_ p_dest[], StgInt64 src)-{- p_dest[0] = src;-}--INLINE_HEADER StgInt64 PK_Int64(W_ p_src[])-{- return p_src[0];-}--#endif /* SIZEOF_HSWORD == 4 */--/* ------------------------------------------------------------------------------ Integer multiply with overflow- -------------------------------------------------------------------------- */--/* Multiply with overflow checking.- *- * This is tricky - the usual sign rules for add/subtract don't apply.- *- * On 32-bit machines we use gcc's 'long long' types, finding- * overflow with some careful bit-twiddling.- *- * On 64-bit machines where gcc's 'long long' type is also 64-bits,- * we use a crude approximation, testing whether either operand is- * larger than 32-bits; if neither is, then we go ahead with the- * multiplication.- *- * Return non-zero if there is any possibility that the signed multiply- * of a and b might overflow. Return zero only if you are absolutely sure- * that it won't overflow. If in doubt, return non-zero.- */--#if SIZEOF_VOID_P == 4--#if defined(WORDS_BIGENDIAN)-#define RTS_CARRY_IDX__ 0-#define RTS_REM_IDX__ 1-#else-#define RTS_CARRY_IDX__ 1-#define RTS_REM_IDX__ 0-#endif--typedef union {- StgInt64 l;- StgInt32 i[2];-} long_long_u ;--#define mulIntMayOflo(a,b) \-({ \- StgInt32 r, c; \- long_long_u z; \- z.l = (StgInt64)a * (StgInt64)b; \- r = z.i[RTS_REM_IDX__]; \- c = z.i[RTS_CARRY_IDX__]; \- if (c == 0 || c == -1) { \- c = ((StgWord)((a^b) ^ r)) \- >> (BITS_IN (I_) - 1); \- } \- c; \-})--/* Careful: the carry calculation above is extremely delicate. Make sure- * you test it thoroughly after changing it.- */--#else--/* Approximate version when we don't have long arithmetic (on 64-bit archs) */--/* If we have n-bit words then we have n-1 bits after accounting for the- * sign bit, so we can fit the result of multiplying 2 (n-1)/2-bit numbers */-#define HALF_POS_INT (((I_)1) << ((BITS_IN (I_) - 1) / 2))-#define HALF_NEG_INT (-HALF_POS_INT)--#define mulIntMayOflo(a,b) \-({ \- I_ c; \- if ((I_)a <= HALF_NEG_INT || a >= HALF_POS_INT \- || (I_)b <= HALF_NEG_INT || b >= HALF_POS_INT) {\- c = 1; \- } else { \- c = 0; \- } \- c; \-})-#endif
− includes/rts/Adjustor.h
@@ -1,22 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 1998-2009- *- * Adjustor API- *- * Do not #include this file directly: #include "Rts.h" instead.- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * -------------------------------------------------------------------------- */--#pragma once--/* Creating and destroying an adjustor thunk */-void* createAdjustor (int cconv, - StgStablePtr hptr,- StgFunPtr wptr,- char *typeString);--void freeHaskellFunctionPtr (void* ptr);
− includes/rts/BlockSignals.h
@@ -1,34 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 1998-2009- *- * RTS signal handling - *- * Do not #include this file directly: #include "Rts.h" instead.- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * ---------------------------------------------------------------------------*/--#pragma once--/* Used by runProcess() in the process package- */--/*- * Function: blockUserSignals()- *- * Temporarily block the delivery of further console events. Needed to- * avoid race conditions when GCing the queue of outstanding handlers or- * when emptying the queue by running the handlers.- * - */-void blockUserSignals(void);--/*- * Function: unblockUserSignals()- *- * The inverse of blockUserSignals(); re-enable the deliver of console events.- */-void unblockUserSignals(void);
− includes/rts/Bytecodes.h
@@ -1,106 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 1998-2009- *- * Bytecode definitions.- *- * ---------------------------------------------------------------------------*/--/* --------------------------------------------------------------------------- * Instructions- *- * Notes:- * o CASEFAIL is generated by the compiler whenever it tests an "irrefutable"- * pattern which fails. If we don't see too many of these, we could- * optimise out the redundant test.- * ------------------------------------------------------------------------*/--/* NOTE:-- THIS FILE IS INCLUDED IN HASKELL SOURCES (ghc/compiler/ghci/ByteCodeAsm.hs).- DO NOT PUT C-SPECIFIC STUFF IN HERE!-- I hope that's clear :-)-*/--#define bci_STKCHECK 1-#define bci_PUSH_L 2-#define bci_PUSH_LL 3-#define bci_PUSH_LLL 4-#define bci_PUSH8 5-#define bci_PUSH16 6-#define bci_PUSH32 7-#define bci_PUSH8_W 8-#define bci_PUSH16_W 9-#define bci_PUSH32_W 10-#define bci_PUSH_G 11-#define bci_PUSH_ALTS 12-#define bci_PUSH_ALTS_P 13-#define bci_PUSH_ALTS_N 14-#define bci_PUSH_ALTS_F 15-#define bci_PUSH_ALTS_D 16-#define bci_PUSH_ALTS_L 17-#define bci_PUSH_ALTS_V 18-#define bci_PUSH_PAD8 19-#define bci_PUSH_PAD16 20-#define bci_PUSH_PAD32 21-#define bci_PUSH_UBX8 22-#define bci_PUSH_UBX16 23-#define bci_PUSH_UBX32 24-#define bci_PUSH_UBX 25-#define bci_PUSH_APPLY_N 26-#define bci_PUSH_APPLY_F 27-#define bci_PUSH_APPLY_D 28-#define bci_PUSH_APPLY_L 29-#define bci_PUSH_APPLY_V 30-#define bci_PUSH_APPLY_P 31-#define bci_PUSH_APPLY_PP 32-#define bci_PUSH_APPLY_PPP 33-#define bci_PUSH_APPLY_PPPP 34-#define bci_PUSH_APPLY_PPPPP 35-#define bci_PUSH_APPLY_PPPPPP 36-/* #define bci_PUSH_APPLY_PPPPPPP 37 */-#define bci_SLIDE 38-#define bci_ALLOC_AP 39-#define bci_ALLOC_AP_NOUPD 40-#define bci_ALLOC_PAP 41-#define bci_MKAP 42-#define bci_MKPAP 43-#define bci_UNPACK 44-#define bci_PACK 45-#define bci_TESTLT_I 46-#define bci_TESTEQ_I 47-#define bci_TESTLT_F 48-#define bci_TESTEQ_F 49-#define bci_TESTLT_D 50-#define bci_TESTEQ_D 51-#define bci_TESTLT_P 52-#define bci_TESTEQ_P 53-#define bci_CASEFAIL 54-#define bci_JMP 55-#define bci_CCALL 56-#define bci_SWIZZLE 57-#define bci_ENTER 58-#define bci_RETURN 59-#define bci_RETURN_P 60-#define bci_RETURN_N 61-#define bci_RETURN_F 62-#define bci_RETURN_D 63-#define bci_RETURN_L 64-#define bci_RETURN_V 65-#define bci_BRK_FUN 66-#define bci_TESTLT_W 67-#define bci_TESTEQ_W 68-/* If you need to go past 255 then you will run into the flags */--/* If you need to go below 0x0100 then you will run into the instructions */-#define bci_FLAG_LARGE_ARGS 0x8000--/* If a BCO definitely requires less than this many words of stack,- don't include an explicit STKCHECK insn in it. The interpreter- will check for this many words of stack before running each BCO,- rendering an explicit check unnecessary in the majority of- cases. */-#define INTERP_STACK_CHECK_THRESH 50--/*-------------------------------------------------------------------------*/
− includes/rts/Config.h
@@ -1,52 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 1998-2009- *- * Rts settings.- *- * NOTE: assumes #include "ghcconfig.h"- * - * NB: THIS FILE IS INCLUDED IN NON-C CODE AND DATA! #defines only please.- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * ---------------------------------------------------------------------------*/--#pragma once--#if defined(TICKY_TICKY) && defined(THREADED_RTS)-#error TICKY_TICKY is incompatible with THREADED_RTS-#endif--/*- * Whether the runtime system will use libbfd for debugging purposes.- */-#if defined(DEBUG) && defined(HAVE_BFD_H) && defined(HAVE_LIBBFD) && !defined(_WIN32)-#define USING_LIBBFD 1-#endif--/* DEBUG and PROFILING both imply TRACING */-#if defined(DEBUG) || defined(PROFILING)-#if !defined(TRACING)-#define TRACING-#endif-#endif--/* DEBUG implies TICKY_TICKY */-#if defined(DEBUG)-#if !defined(TICKY_TICKY)-#define TICKY_TICKY-#endif-#endif---/* ------------------------------------------------------------------------------ Signals - supported on non-PAR versions of the runtime. See RtsSignals.h.- -------------------------------------------------------------------------- */--#define RTS_USER_SIGNALS 1--/* Profile spin locks */--#define PROF_SPIN
− includes/rts/Constants.h
@@ -1,332 +0,0 @@-/* ----------------------------------------------------------------------------- *- * (c) The GHC Team, 1998-2009- *- * Constants- *- * NOTE: this information is used by both the compiler and the RTS.- * Some of it is tweakable, and some of it must be kept up to date- * with various other parts of the system.- *- * Constants which are derived automatically from other definitions in- * the system (eg. structure sizes) are generated into the file- * DerivedConstants.h by a C program (mkDerivedConstantsHdr).- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * -------------------------------------------------------------------------- */--#pragma once--/* ------------------------------------------------------------------------------ Minimum closure sizes-- This is the minimum number of words in the payload of a- heap-allocated closure, so that the closure has enough room to be- overwritten with a forwarding pointer during garbage collection.- -------------------------------------------------------------------------- */--#define MIN_PAYLOAD_SIZE 1--/* ------------------------------------------------------------------------------ Constants to do with specialised closure types.- -------------------------------------------------------------------------- */--/* We have some pre-compiled selector thunks defined in rts/StgStdThunks.hc.- * This constant defines the highest selectee index that we can replace with a- * reference to the pre-compiled code.- */--#define MAX_SPEC_SELECTEE_SIZE 15--/* Vector-apply thunks. These thunks just push their free variables- * on the stack and enter the first one. They're a bit like PAPs, but- * don't have a dynamic size. We've pre-compiled a few to save- * space.- */--#define MAX_SPEC_AP_SIZE 7--/* Specialised FUN/THUNK/CONSTR closure types */--#define MAX_SPEC_THUNK_SIZE 2-#define MAX_SPEC_FUN_SIZE 2-#define MAX_SPEC_CONSTR_SIZE 2--/* Range of built-in table of static small int-like and char-like closures.- *- * NB. This corresponds with the number of actual INTLIKE/CHARLIKE- * closures defined in rts/StgMiscClosures.cmm.- */-#define MAX_INTLIKE 16-#define MIN_INTLIKE (-16)--#define MAX_CHARLIKE 255-#define MIN_CHARLIKE 0--/* Each byte in the card table for an StgMutaArrPtrs covers- * (1<<MUT_ARR_PTRS_CARD_BITS) elements in the array. To find a good- * value for this, I used the benchmarks nofib/gc/hash,- * nofib/gc/graph, and nofib/gc/gc_bench.- */-#define MUT_ARR_PTRS_CARD_BITS 7--/* ------------------------------------------------------------------------------ STG Registers.-- Note that in MachRegs.h we define how many of these registers are- *real* machine registers, and not just offsets in the Register Table.- -------------------------------------------------------------------------- */--#define MAX_VANILLA_REG 10-#define MAX_FLOAT_REG 6-#define MAX_DOUBLE_REG 6-#define MAX_LONG_REG 1-#define MAX_XMM_REG 6--/* ------------------------------------------------------------------------------ Semi-Tagging constants-- Old Comments about this stuff:-- Tags for indirection nodes and ``other'' (probably unevaluated) nodes;- normal-form values of algebraic data types will have tags 0, 1, ...-- @INFO_IND_TAG@ is different from @INFO_OTHER_TAG@ just so we can count- how often we bang into indirection nodes; that's all. (WDP 95/11)-- ToDo: find out if we need any of this.- -------------------------------------------------------------------------- */--#define INFO_OTHER_TAG (-1)-#define INFO_IND_TAG (-2)-#define INFO_FIRST_TAG 0--/* ------------------------------------------------------------------------------ How much C stack to reserve for local temporaries when in the STG- world. Used in StgCRun.c.- -------------------------------------------------------------------------- */--#define RESERVED_C_STACK_BYTES (2048 * SIZEOF_LONG)--/* ------------------------------------------------------------------------------ How large is the stack frame saved by StgRun?- world. Used in StgCRun.c.-- The size has to be enough to save the registers (see StgCRun)- plus padding if the result is not 16 byte aligned.- See the Note [Stack Alignment on X86] in StgCRun.c for details.-- -------------------------------------------------------------------------- */-#if defined(x86_64_HOST_ARCH)-# if defined(mingw32_HOST_OS)-# define STG_RUN_STACK_FRAME_SIZE 144-# else-# define STG_RUN_STACK_FRAME_SIZE 48-# endif-#endif--/* ------------------------------------------------------------------------------ StgRun related labels shared between StgCRun.c and StgStartup.cmm.- -------------------------------------------------------------------------- */--#if defined(LEADING_UNDERSCORE)-#define STG_RUN "_StgRun"-#define STG_RUN_JMP _StgRunJmp-#define STG_RETURN "_StgReturn"-#else-#define STG_RUN "StgRun"-#define STG_RUN_JMP StgRunJmp-#define STG_RETURN "StgReturn"-#endif--/* ------------------------------------------------------------------------------ How much Haskell stack space to reserve for the saving of registers- etc. in the case of a stack/heap overflow.-- This must be large enough to accommodate the largest stack frame- pushed in one of the heap check fragments in HeapStackCheck.hc- (ie. currently the generic heap checks - 3 words for StgRetDyn,- 18 words for the saved registers, see StgMacros.h).- -------------------------------------------------------------------------- */--#define RESERVED_STACK_WORDS 21--/* ------------------------------------------------------------------------------ The limit on the size of the stack check performed when we enter an- AP_STACK, in words. See raiseAsync() and bug #1466.- -------------------------------------------------------------------------- */--#define AP_STACK_SPLIM 1024--/* ------------------------------------------------------------------------------ Storage manager constants- -------------------------------------------------------------------------- */--/* The size of a block (2^BLOCK_SHIFT bytes) */-#define BLOCK_SHIFT 12--/* The size of a megablock (2^MBLOCK_SHIFT bytes) */-#define MBLOCK_SHIFT 20--/* ------------------------------------------------------------------------------ Bitmap/size fields (used in info tables)- -------------------------------------------------------------------------- */--/* In a 32-bit bitmap field, we use 5 bits for the size, and 27 bits- * for the bitmap. If the bitmap requires more than 27 bits, then we- * store it in a separate array, and leave a pointer in the bitmap- * field. On a 64-bit machine, the sizes are extended accordingly.- */-#if SIZEOF_VOID_P == 4-#define BITMAP_SIZE_MASK 0x1f-#define BITMAP_BITS_SHIFT 5-#elif SIZEOF_VOID_P == 8-#define BITMAP_SIZE_MASK 0x3f-#define BITMAP_BITS_SHIFT 6-#else-#error unknown SIZEOF_VOID_P-#endif--/* ------------------------------------------------------------------------------ Lag/Drag/Void constants- -------------------------------------------------------------------------- */--/*- An LDV word is divided into 3 parts: state bits (LDV_STATE_MASK), creation- time bits (LDV_CREATE_MASK), and last use time bits (LDV_LAST_MASK).- */-#if SIZEOF_VOID_P == 8-#define LDV_SHIFT 30-#define LDV_STATE_MASK 0x1000000000000000-#define LDV_CREATE_MASK 0x0FFFFFFFC0000000-#define LDV_LAST_MASK 0x000000003FFFFFFF-#define LDV_STATE_CREATE 0x0000000000000000-#define LDV_STATE_USE 0x1000000000000000-#else-#define LDV_SHIFT 15-#define LDV_STATE_MASK 0x40000000-#define LDV_CREATE_MASK 0x3FFF8000-#define LDV_LAST_MASK 0x00007FFF-#define LDV_STATE_CREATE 0x00000000-#define LDV_STATE_USE 0x40000000-#endif /* SIZEOF_VOID_P */--/* ------------------------------------------------------------------------------ TSO related constants- -------------------------------------------------------------------------- */--/*- * Constants for the what_next field of a TSO, which indicates how it- * is to be run.- */-#define ThreadRunGHC 1 /* return to address on top of stack */-#define ThreadInterpret 2 /* interpret this thread */-#define ThreadKilled 3 /* thread has died, don't run it */-#define ThreadComplete 4 /* thread has finished */--/*- * Constants for the why_blocked field of a TSO- * NB. keep these in sync with GHC/Conc/Sync.hs: threadStatus- */-#define NotBlocked 0-#define BlockedOnMVar 1-#define BlockedOnMVarRead 14 /* TODO: renumber me, see #9003 */-#define BlockedOnBlackHole 2-#define BlockedOnRead 3-#define BlockedOnWrite 4-#define BlockedOnDelay 5-#define BlockedOnSTM 6--/* Win32 only: */-#define BlockedOnDoProc 7--/* Only relevant for THREADED_RTS: */-#define BlockedOnCCall 10-#define BlockedOnCCall_Interruptible 11- /* same as above but permit killing the worker thread */--/* Involved in a message sent to tso->msg_cap */-#define BlockedOnMsgThrowTo 12--/* The thread is not on any run queues, but can be woken up- by tryWakeupThread() */-#define ThreadMigrating 13--/* WARNING WARNING top number is BlockedOnMVarRead 14, not 13!! */--/*- * These constants are returned to the scheduler by a thread that has- * stopped for one reason or another. See typedef StgThreadReturnCode- * in TSO.h.- */-#define HeapOverflow 1 /* might also be StackOverflow */-#define StackOverflow 2-#define ThreadYielding 3-#define ThreadBlocked 4-#define ThreadFinished 5--/*- * Flags for the tso->flags field.- */--/*- * TSO_LOCKED is set when a TSO is locked to a particular Capability.- */-#define TSO_LOCKED 2--/*- * TSO_BLOCKEX: the TSO is blocking exceptions- *- * TSO_INTERRUPTIBLE: the TSO can be interrupted if it blocks- * interruptibly (eg. with BlockedOnMVar).- *- * TSO_STOPPED_ON_BREAKPOINT: the thread is currently stopped in a breakpoint- */-#define TSO_BLOCKEX 4-#define TSO_INTERRUPTIBLE 8-#define TSO_STOPPED_ON_BREAKPOINT 16--/*- * Used by the sanity checker to check whether TSOs are on the correct- * mutable list.- */-#define TSO_MARKED 64--/*- * Used to communicate between stackSqueeze() and- * threadStackOverflow() that a thread's stack was squeezed and the- * stack may not need to be expanded.- */-#define TSO_SQUEEZED 128--/*- * Enables the AllocationLimitExceeded exception when the thread's- * allocation limit goes negative.- */-#define TSO_ALLOC_LIMIT 256--/*- * The number of times we spin in a spin lock before yielding (see- * #3758). To tune this value, use the benchmark in #3758: run the- * server with -N2 and the client both on a dual-core. Also make sure- * that the chosen value doesn't slow down any of the parallel- * benchmarks in nofib/parallel.- */-#define SPIN_COUNT 1000--/* ------------------------------------------------------------------------------ Spare workers per Capability in the threaded RTS-- No more than MAX_SPARE_WORKERS will be kept in the thread pool- associated with each Capability.- -------------------------------------------------------------------------- */--#define MAX_SPARE_WORKERS 6--/*- * The maximum number of NUMA nodes we support. This is a fixed limit so that- * we can have static arrays of this size in the RTS for speed.- */-#define MAX_NUMA_NODES 16
− includes/rts/EventLogFormat.h
@@ -1,265 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 2008-2009- *- * Event log format- *- * The log format is designed to be extensible: old tools should be- * able to parse (but not necessarily understand all of) new versions- * of the format, and new tools will be able to understand old log- * files.- *- * Each event has a specific format. If you add new events, give them- * new numbers: we never re-use old event numbers.- *- * - The format is endian-independent: all values are represented in- * bigendian order.- *- * - The format is extensible:- *- * - The header describes each event type and its length. Tools- * that don't recognise a particular event type can skip those events.- *- * - There is room for extra information in the event type- * specification, which can be ignored by older tools.- *- * - Events can have extra information added, but existing fields- * cannot be changed. Tools should ignore extra fields at the- * end of the event record.- *- * - Old event type ids are never re-used; just take a new identifier.- *- *- * The format- * ----------- *- * log : EVENT_HEADER_BEGIN- * EventType*- * EVENT_HEADER_END- * EVENT_DATA_BEGIN- * Event*- * EVENT_DATA_END- *- * EventType :- * EVENT_ET_BEGIN- * Word16 -- unique identifier for this event- * Int16 -- >=0 size of the event in bytes (minus the header)- * -- -1 variable size- * Word32 -- length of the next field in bytes- * Word8* -- string describing the event- * Word32 -- length of the next field in bytes- * Word8* -- extra info (for future extensions)- * EVENT_ET_END- *- * Event :- * Word16 -- event_type- * Word64 -- time (nanosecs)- * [Word16] -- length of the rest (for variable-sized events only)- * ... extra event-specific info ...- *- *- * To add a new event- * ------------------- *- * - In this file:- * - give it a new number, add a new #define EVENT_XXX below- * - In EventLog.c- * - add it to the EventDesc array- * - emit the event type in initEventLogging()- * - emit the new event in postEvent_()- * - generate the event itself by calling postEvent() somewhere- * - In the Haskell code to parse the event log file:- * - add types and code to read the new event- *- * -------------------------------------------------------------------------- */--#pragma once--/*- * Markers for begin/end of the Header.- */-#define EVENT_HEADER_BEGIN 0x68647262 /* 'h' 'd' 'r' 'b' */-#define EVENT_HEADER_END 0x68647265 /* 'h' 'd' 'r' 'e' */--#define EVENT_DATA_BEGIN 0x64617462 /* 'd' 'a' 't' 'b' */-#define EVENT_DATA_END 0xffff--/*- * Markers for begin/end of the list of Event Types in the Header.- * Header, Event Type, Begin = hetb- * Header, Event Type, End = hete- */-#define EVENT_HET_BEGIN 0x68657462 /* 'h' 'e' 't' 'b' */-#define EVENT_HET_END 0x68657465 /* 'h' 'e' 't' 'e' */--#define EVENT_ET_BEGIN 0x65746200 /* 'e' 't' 'b' 0 */-#define EVENT_ET_END 0x65746500 /* 'e' 't' 'e' 0 */--/*- * Types of event- */-#define EVENT_CREATE_THREAD 0 /* (thread) */-#define EVENT_RUN_THREAD 1 /* (thread) */-#define EVENT_STOP_THREAD 2 /* (thread, status, blockinfo) */-#define EVENT_THREAD_RUNNABLE 3 /* (thread) */-#define EVENT_MIGRATE_THREAD 4 /* (thread, new_cap) */-/* 5, 6, 7 deprecated */-#define EVENT_THREAD_WAKEUP 8 /* (thread, other_cap) */-#define EVENT_GC_START 9 /* () */-#define EVENT_GC_END 10 /* () */-#define EVENT_REQUEST_SEQ_GC 11 /* () */-#define EVENT_REQUEST_PAR_GC 12 /* () */-/* 13, 14 deprecated */-#define EVENT_CREATE_SPARK_THREAD 15 /* (spark_thread) */-#define EVENT_LOG_MSG 16 /* (message ...) */-/* 17 deprecated */-#define EVENT_BLOCK_MARKER 18 /* (size, end_time, capability) */-#define EVENT_USER_MSG 19 /* (message ...) */-#define EVENT_GC_IDLE 20 /* () */-#define EVENT_GC_WORK 21 /* () */-#define EVENT_GC_DONE 22 /* () */-/* 23, 24 used by eden */-#define EVENT_CAPSET_CREATE 25 /* (capset, capset_type) */-#define EVENT_CAPSET_DELETE 26 /* (capset) */-#define EVENT_CAPSET_ASSIGN_CAP 27 /* (capset, cap) */-#define EVENT_CAPSET_REMOVE_CAP 28 /* (capset, cap) */-/* the RTS identifier is in the form of "GHC-version rts_way" */-#define EVENT_RTS_IDENTIFIER 29 /* (capset, name_version_string) */-/* the vectors in these events are null separated strings */-#define EVENT_PROGRAM_ARGS 30 /* (capset, commandline_vector) */-#define EVENT_PROGRAM_ENV 31 /* (capset, environment_vector) */-#define EVENT_OSPROCESS_PID 32 /* (capset, pid) */-#define EVENT_OSPROCESS_PPID 33 /* (capset, parent_pid) */-#define EVENT_SPARK_COUNTERS 34 /* (crt,dud,ovf,cnv,gcd,fiz,rem) */-#define EVENT_SPARK_CREATE 35 /* () */-#define EVENT_SPARK_DUD 36 /* () */-#define EVENT_SPARK_OVERFLOW 37 /* () */-#define EVENT_SPARK_RUN 38 /* () */-#define EVENT_SPARK_STEAL 39 /* (victim_cap) */-#define EVENT_SPARK_FIZZLE 40 /* () */-#define EVENT_SPARK_GC 41 /* () */-#define EVENT_INTERN_STRING 42 /* (string, id) {not used by ghc} */-#define EVENT_WALL_CLOCK_TIME 43 /* (capset, unix_epoch_seconds, nanoseconds) */-#define EVENT_THREAD_LABEL 44 /* (thread, name_string) */-#define EVENT_CAP_CREATE 45 /* (cap) */-#define EVENT_CAP_DELETE 46 /* (cap) */-#define EVENT_CAP_DISABLE 47 /* (cap) */-#define EVENT_CAP_ENABLE 48 /* (cap) */-#define EVENT_HEAP_ALLOCATED 49 /* (heap_capset, alloc_bytes) */-#define EVENT_HEAP_SIZE 50 /* (heap_capset, size_bytes) */-#define EVENT_HEAP_LIVE 51 /* (heap_capset, live_bytes) */-#define EVENT_HEAP_INFO_GHC 52 /* (heap_capset, n_generations,- max_heap_size, alloc_area_size,- mblock_size, block_size) */-#define EVENT_GC_STATS_GHC 53 /* (heap_capset, generation,- copied_bytes, slop_bytes, frag_bytes,- par_n_threads,- par_max_copied,- par_tot_copied, par_balanced_copied) */-#define EVENT_GC_GLOBAL_SYNC 54 /* () */-#define EVENT_TASK_CREATE 55 /* (taskID, cap, tid) */-#define EVENT_TASK_MIGRATE 56 /* (taskID, cap, new_cap) */-#define EVENT_TASK_DELETE 57 /* (taskID) */-#define EVENT_USER_MARKER 58 /* (marker_name) */-#define EVENT_HACK_BUG_T9003 59 /* Hack: see trac #9003 */--/* Range 60 - 80 is used by eden for parallel tracing- * see http://www.mathematik.uni-marburg.de/~eden/- */--/* Range 100 - 139 is reserved for Mercury. */--/* Range 140 - 159 is reserved for Perf events. */--/* Range 160 - 180 is reserved for cost-centre heap profiling events. */--#define EVENT_HEAP_PROF_BEGIN 160-#define EVENT_HEAP_PROF_COST_CENTRE 161-#define EVENT_HEAP_PROF_SAMPLE_BEGIN 162-#define EVENT_HEAP_PROF_SAMPLE_COST_CENTRE 163-#define EVENT_HEAP_PROF_SAMPLE_STRING 164-#define EVENT_HEAP_PROF_SAMPLE_END 165--#define EVENT_USER_BINARY_MSG 181--/*- * The highest event code +1 that ghc itself emits. Note that some event- * ranges higher than this are reserved but not currently emitted by ghc.- * This must match the size of the EventDesc[] array in EventLog.c- */-#define NUM_GHC_EVENT_TAGS 182--#if 0 /* DEPRECATED EVENTS: */-/* we don't actually need to record the thread, it's implicit */-#define EVENT_RUN_SPARK 5 /* (thread) */-#define EVENT_STEAL_SPARK 6 /* (thread, victim_cap) */-/* shutdown replaced by EVENT_CAP_DELETE */-#define EVENT_SHUTDOWN 7 /* () */-/* ghc changed how it handles sparks so these are no longer applicable */-#define EVENT_CREATE_SPARK 13 /* (cap, thread) */-#define EVENT_SPARK_TO_THREAD 14 /* (cap, thread, spark_thread) */-#define EVENT_STARTUP 17 /* (num_capabilities) */-/* these are used by eden but are replaced by new alternatives for ghc */-#define EVENT_VERSION 23 /* (version_string) */-#define EVENT_PROGRAM_INVOCATION 24 /* (commandline_string) */-#endif--/*- * Status values for EVENT_STOP_THREAD- *- * 1-5 are the StgRun return values (from includes/Constants.h):- *- * #define HeapOverflow 1- * #define StackOverflow 2- * #define ThreadYielding 3- * #define ThreadBlocked 4- * #define ThreadFinished 5- * #define ForeignCall 6- * #define BlockedOnMVar 7- * #define BlockedOnBlackHole 8- * #define BlockedOnRead 9- * #define BlockedOnWrite 10- * #define BlockedOnDelay 11- * #define BlockedOnSTM 12- * #define BlockedOnDoProc 13- * #define BlockedOnCCall -- not used (see ForeignCall)- * #define BlockedOnCCall_NoUnblockExc -- not used (see ForeignCall)- * #define BlockedOnMsgThrowTo 16- */-#define THREAD_SUSPENDED_FOREIGN_CALL 6--/*- * Capset type values for EVENT_CAPSET_CREATE- */-#define CAPSET_TYPE_CUSTOM 1 /* reserved for end-user applications */-#define CAPSET_TYPE_OSPROCESS 2 /* caps belong to the same OS process */-#define CAPSET_TYPE_CLOCKDOMAIN 3 /* caps share a local clock/time */--/*- * Heap profile breakdown types. See EVENT_HEAP_PROF_BEGIN.- */-typedef enum {- HEAP_PROF_BREAKDOWN_COST_CENTRE = 0x1,- HEAP_PROF_BREAKDOWN_MODULE,- HEAP_PROF_BREAKDOWN_CLOSURE_DESCR,- HEAP_PROF_BREAKDOWN_TYPE_DESCR,- HEAP_PROF_BREAKDOWN_RETAINER,- HEAP_PROF_BREAKDOWN_BIOGRAPHY,- HEAP_PROF_BREAKDOWN_CLOSURE_TYPE-} HeapProfBreakdown;--#if !defined(EVENTLOG_CONSTANTS_ONLY)--typedef StgWord16 EventTypeNum;-typedef StgWord64 EventTimestamp; /* in nanoseconds */-typedef StgWord32 EventThreadID;-typedef StgWord16 EventCapNo;-typedef StgWord16 EventPayloadSize; /* variable-size events */-typedef StgWord16 EventThreadStatus; /* status for EVENT_STOP_THREAD */-typedef StgWord32 EventCapsetID;-typedef StgWord16 EventCapsetType; /* types for EVENT_CAPSET_CREATE */-typedef StgWord64 EventTaskId; /* for EVENT_TASK_* */-typedef StgWord64 EventKernelThreadId; /* for EVENT_TASK_CREATE */--#define EVENT_PAYLOAD_SIZE_MAX STG_WORD16_MAX-#endif
− includes/rts/EventLogWriter.h
@@ -1,40 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 2008-2017- *- * Support for fast binary event logging.- *- * Do not #include this file directly: #include "Rts.h" instead.- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * ---------------------------------------------------------------------------*/--#pragma once--#include <stddef.h>-#include <stdbool.h>--/*- * Abstraction for writing eventlog data.- */-typedef struct {- // Initialize an EventLogWriter (may be NULL)- void (* initEventLogWriter) (void);-- // Write a series of events- bool (* writeEventLog) (void *eventlog, size_t eventlog_size);-- // Flush possibly existing buffers (may be NULL)- void (* flushEventLog) (void);-- // Close an initialized EventLogOutput (may be NULL)- void (* stopEventLogWriter) (void);-} EventLogWriter;--/*- * An EventLogWriter which writes eventlogs to- * a file `program.eventlog`.- */-extern const EventLogWriter FileEventLogWriter;
− includes/rts/FileLock.h
@@ -1,19 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 2007-2009- *- * File locking support as required by Haskell- *- * Do not #include this file directly: #include "Rts.h" instead.- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * ---------------------------------------------------------------------------*/--#pragma once--#include "Stg.h"--int lockFile(int fd, StgWord64 dev, StgWord64 ino, int for_writing);-int unlockFile(int fd);
− includes/rts/Flags.h
@@ -1,301 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 1998-2009- *- * Datatypes that holds the command-line flag settings.- *- * Do not #include this file directly: #include "Rts.h" instead.- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * ---------------------------------------------------------------------------*/--#pragma once--#include <stdio.h>-#include <stdint.h>-#include <stdbool.h>-#include "stg/Types.h"-#include "Time.h"--/* For defaults, see the @initRtsFlagsDefaults@ routine. */--/* Note [Synchronization of flags and base APIs]- *- * We provide accessors to RTS flags in base. (GHC.RTS module)- * The API should be updated whenever RTS flags are modified.- */--/* See Note [Synchronization of flags and base APIs] */-typedef struct _GC_FLAGS {- FILE *statsFile;- uint32_t giveStats;-#define NO_GC_STATS 0-#define COLLECT_GC_STATS 1-#define ONELINE_GC_STATS 2-#define SUMMARY_GC_STATS 3-#define VERBOSE_GC_STATS 4-- uint32_t maxStkSize; /* in *words* */- uint32_t initialStkSize; /* in *words* */- uint32_t stkChunkSize; /* in *words* */- uint32_t stkChunkBufferSize; /* in *words* */-- uint32_t maxHeapSize; /* in *blocks* */- uint32_t minAllocAreaSize; /* in *blocks* */- uint32_t largeAllocLim; /* in *blocks* */- uint32_t nurseryChunkSize; /* in *blocks* */- uint32_t minOldGenSize; /* in *blocks* */- uint32_t heapSizeSuggestion; /* in *blocks* */- bool heapSizeSuggestionAuto;- double oldGenFactor;- double pcFreeHeap;-- uint32_t generations;- bool squeezeUpdFrames;-- bool compact; /* True <=> "compact all the time" */- double compactThreshold;-- bool sweep; /* use "mostly mark-sweep" instead of copying- * for the oldest generation */- bool ringBell;-- Time idleGCDelayTime; /* units: TIME_RESOLUTION */- bool doIdleGC;-- Time longGCSync; /* units: TIME_RESOLUTION */-- StgWord heapBase; /* address to ask the OS for memory */-- StgWord allocLimitGrace; /* units: *blocks*- * After an AllocationLimitExceeded- * exception has been raised, how much- * extra space is given to the thread- * to handle the exception before we- * raise it again.- */- StgWord heapLimitGrace; /* units: *blocks*- * After a HeapOverflow exception has- * been raised, how much extra space is- * given to the thread to handle the- * exception before we raise it again.- */-- bool numa; /* Use NUMA */- StgWord numaMask;-} GC_FLAGS;--/* See Note [Synchronization of flags and base APIs] */-typedef struct _DEBUG_FLAGS {- /* flags to control debugging output & extra checking in various subsystems */- bool scheduler; /* 's' */- bool interpreter; /* 'i' */- bool weak; /* 'w' */- bool gccafs; /* 'G' */- bool gc; /* 'g' */- bool block_alloc; /* 'b' */- bool sanity; /* 'S' warning: might be expensive! */- bool stable; /* 't' */- bool prof; /* 'p' */- bool linker; /* 'l' the object linker */- bool apply; /* 'a' */- bool stm; /* 'm' */- bool squeeze; /* 'z' stack squeezing & lazy blackholing */- bool hpc; /* 'c' coverage */- bool sparks; /* 'r' */- bool numa; /* '--debug-numa' */- bool compact; /* 'C' */-} DEBUG_FLAGS;--/* See Note [Synchronization of flags and base APIs] */-typedef struct _COST_CENTRE_FLAGS {- uint32_t doCostCentres;-# define COST_CENTRES_NONE 0-# define COST_CENTRES_SUMMARY 1-# define COST_CENTRES_VERBOSE 2 /* incl. serial time profile */-# define COST_CENTRES_ALL 3-# define COST_CENTRES_JSON 4-- int profilerTicks; /* derived */- int msecsPerTick; /* derived */- char const *outputFileNameStem;-} COST_CENTRE_FLAGS;--/* See Note [Synchronization of flags and base APIs] */-typedef struct _PROFILING_FLAGS {- uint32_t doHeapProfile;-# define NO_HEAP_PROFILING 0 /* N.B. Used as indexes into arrays */-# define HEAP_BY_CCS 1-# define HEAP_BY_MOD 2-# define HEAP_BY_DESCR 4-# define HEAP_BY_TYPE 5-# define HEAP_BY_RETAINER 6-# define HEAP_BY_LDV 7--# define HEAP_BY_CLOSURE_TYPE 8-- Time heapProfileInterval; /* time between samples */- uint32_t heapProfileIntervalTicks; /* ticks between samples (derived) */- bool includeTSOs;--- bool showCCSOnException;-- uint32_t maxRetainerSetSize;-- uint32_t ccsLength;-- const char* modSelector;- const char* descrSelector;- const char* typeSelector;- const char* ccSelector;- const char* ccsSelector;- const char* retainerSelector;- const char* bioSelector;--} PROFILING_FLAGS;--#define TRACE_NONE 0-#define TRACE_EVENTLOG 1-#define TRACE_STDERR 2--/* See Note [Synchronization of flags and base APIs] */-typedef struct _TRACE_FLAGS {- int tracing;- bool timestamp; /* show timestamp in stderr output */- bool scheduler; /* trace scheduler events */- bool gc; /* trace GC events */- bool sparks_sampled; /* trace spark events by a sampled method */- bool sparks_full; /* trace spark events 100% accurately */- bool user; /* trace user events (emitted from Haskell code) */- char *trace_output; /* output filename for eventlog */-} TRACE_FLAGS;--/* See Note [Synchronization of flags and base APIs] */-typedef struct _CONCURRENT_FLAGS {- Time ctxtSwitchTime; /* units: TIME_RESOLUTION */- int ctxtSwitchTicks; /* derived */-} CONCURRENT_FLAGS;--/*- * The tickInterval is the time interval between "ticks", ie.- * timer signals (see Timer.{c,h}). It is the frequency at- * which we sample CCCS for profiling.- *- * It is changed by the +RTS -V<secs> flag.- */-#define DEFAULT_TICK_INTERVAL USToTime(10000)--/*- * When linkerAlwaysPic is true, the runtime linker assume that all object- * files were compiled with -fPIC -fexternal-dynamic-refs and load them- * anywhere in the address space.- */-#if defined(x86_64_HOST_ARCH) && defined(darwin_HOST_OS)-#define DEFAULT_LINKER_ALWAYS_PIC true-#else-#define DEFAULT_LINKER_ALWAYS_PIC false-#endif--/* See Note [Synchronization of flags and base APIs] */-typedef struct _MISC_FLAGS {- Time tickInterval; /* units: TIME_RESOLUTION */- bool install_signal_handlers;- bool install_seh_handlers;- bool generate_dump_file;- bool generate_stack_trace;- bool machineReadable;- bool internalCounters; /* See Note [Internal Counter Stats] */- bool linkerAlwaysPic; /* Assume the object code is always PIC */- StgWord linkerMemBase; /* address to ask the OS for memory- * for the linker, NULL ==> off */-} MISC_FLAGS;--/* See Note [Synchronization of flags and base APIs] */-typedef struct _PAR_FLAGS {- uint32_t nCapabilities; /* number of threads to run simultaneously */- bool migrate; /* migrate threads between capabilities */- uint32_t maxLocalSparks;- bool parGcEnabled; /* enable parallel GC */- uint32_t parGcGen; /* do parallel GC in this generation- * and higher only */- bool parGcLoadBalancingEnabled;- /* enable load-balancing in the- * parallel GC */- uint32_t parGcLoadBalancingGen;- /* do load-balancing in this- * generation and higher only */-- uint32_t parGcNoSyncWithIdle;- /* if a Capability has been idle for- * this many GCs, do not try to wake- * it up when doing a- * non-load-balancing parallel GC.- * (zero disables) */-- uint32_t parGcThreads;- /* Use this many threads for parallel- * GC (default: use all nNodes). */-- bool setAffinity; /* force thread affinity with CPUs */-} PAR_FLAGS;--/* See Note [Synchronization of flags and base APIs] */-typedef struct _TICKY_FLAGS {- bool showTickyStats;- FILE *tickyFile;-} TICKY_FLAGS;--/* Put them together: */--/* See Note [Synchronization of flags and base APIs] */-typedef struct _RTS_FLAGS {- /* The first portion of RTS_FLAGS is invariant. */- GC_FLAGS GcFlags;- CONCURRENT_FLAGS ConcFlags;- MISC_FLAGS MiscFlags;- DEBUG_FLAGS DebugFlags;- COST_CENTRE_FLAGS CcFlags;- PROFILING_FLAGS ProfFlags;- TRACE_FLAGS TraceFlags;- TICKY_FLAGS TickyFlags;- PAR_FLAGS ParFlags;-} RTS_FLAGS;--#if defined(COMPILING_RTS_MAIN)-extern DLLIMPORT RTS_FLAGS RtsFlags;-#elif IN_STG_CODE-/* Hack because the C code generator can't generate '&label'. */-extern RTS_FLAGS RtsFlags[];-#else-extern RTS_FLAGS RtsFlags;-#endif--/*- * The printf formats are here, so we are less likely to make- * overly-long filenames (with disastrous results). No more than 128- * chars, please!- */--#define STATS_FILENAME_MAXLEN 128--#define GR_FILENAME_FMT "%0.124s.gr"-#define HP_FILENAME_FMT "%0.124s.hp"-#define LIFE_FILENAME_FMT "%0.122s.life"-#define PROF_FILENAME_FMT "%0.122s.prof"-#define PROF_FILENAME_FMT_GUM "%0.118s.%03d.prof"-#define QP_FILENAME_FMT "%0.124s.qp"-#define STAT_FILENAME_FMT "%0.122s.stat"-#define TICKY_FILENAME_FMT "%0.121s.ticky"-#define TIME_FILENAME_FMT "%0.122s.time"-#define TIME_FILENAME_FMT_GUM "%0.118s.%03d.time"--/* an "int" so as to match normal "argc" */-/* Now defined in Stg.h (lib/std/cbits need these too.)-extern int prog_argc;-extern char **prog_argv;-*/-extern int rts_argc; /* ditto */-extern char **rts_argv;
− includes/rts/GetTime.h
@@ -1,16 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 1995-2009- *- * Interface to the RTS time- *- * Do not #include this file directly: #include "Rts.h" instead.- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * ---------------------------------------------------------------------------*/--#pragma once--StgWord64 getMonotonicNSec (void);
− includes/rts/Globals.h
@@ -1,36 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 2006-2009- *- * The RTS stores some "global" values on behalf of libraries, so that- * some libraries can ensure that certain top-level things are shared- * even when multiple versions of the library are loaded. e.g. see- * Data.Typeable and GHC.Conc.- *- * Do not #include this file directly: #include "Rts.h" instead.- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * ---------------------------------------------------------------------------*/--#pragma once--#define mkStoreAccessorPrototype(name) \- StgStablePtr \- getOrSet##name(StgStablePtr ptr);--mkStoreAccessorPrototype(GHCConcSignalSignalHandlerStore)-mkStoreAccessorPrototype(GHCConcWindowsPendingDelaysStore)-mkStoreAccessorPrototype(GHCConcWindowsIOManagerThreadStore)-mkStoreAccessorPrototype(GHCConcWindowsProddingStore)-mkStoreAccessorPrototype(SystemEventThreadEventManagerStore)-mkStoreAccessorPrototype(SystemEventThreadIOManagerThreadStore)-mkStoreAccessorPrototype(SystemTimerThreadEventManagerStore)-mkStoreAccessorPrototype(SystemTimerThreadIOManagerThreadStore)-mkStoreAccessorPrototype(LibHSghcFastStringTable)-mkStoreAccessorPrototype(LibHSghcPersistentLinkerState)-mkStoreAccessorPrototype(LibHSghcInitLinkerDone)-mkStoreAccessorPrototype(LibHSghcGlobalDynFlags)-mkStoreAccessorPrototype(LibHSghcStaticOptions)-mkStoreAccessorPrototype(LibHSghcStaticOptionsReady)
− includes/rts/Hpc.h
@@ -1,34 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 2008-2009- *- * Haskell Program Coverage- *- * Do not #include this file directly: #include "Rts.h" instead.- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * -------------------------------------------------------------------------- */--#pragma once--// Simple linked list of modules-typedef struct _HpcModuleInfo {- char *modName; // name of module- StgWord32 tickCount; // number of ticks- StgWord32 hashNo; // Hash number for this module's mix info- StgWord64 *tixArr; // tix Array; local for this module- bool from_file; // data was read from the .tix file- struct _HpcModuleInfo *next;-} HpcModuleInfo;--void hs_hpc_module (char *modName,- StgWord32 modCount,- StgWord32 modHashNo,- StgWord64 *tixArr);--HpcModuleInfo * hs_hpc_rootModule (void);--void startupHpc(void);-void exitHpc(void);
− includes/rts/IOManager.h
@@ -1,43 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 1998-2009- *- * IO Manager functionality in the RTS- *- * Do not #include this file directly: #include "Rts.h" instead.- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * -------------------------------------------------------------------------- */--#pragma once--#if defined(mingw32_HOST_OS)--int rts_InstallConsoleEvent ( int action, StgStablePtr *handler );-void rts_ConsoleHandlerDone ( int ev );-extern StgInt console_handler;--void * getIOManagerEvent (void);-HsWord32 readIOManagerEvent (void);-void sendIOManagerEvent (HsWord32 event);--#else--void setIOManagerControlFd (uint32_t cap_no, int fd);-void setTimerManagerControlFd(int fd);-void setIOManagerWakeupFd (int fd);--#endif--//-// Communicating with the IO manager thread (see GHC.Conc).-// Posix implementation in posix/Signals.c-// Win32 implementation in win32/ThrIOManager.c-//-void ioManagerWakeup (void);-#if defined(THREADED_RTS)-void ioManagerDie (void);-void ioManagerStart (void);-#endif
− includes/rts/Libdw.h
@@ -1,97 +0,0 @@-/* ---------------------------------------------------------------------------- *- * (c) The GHC Team, 2014-2015- *- * Producing DWARF-based stacktraces with libdw.- *- * --------------------------------------------------------------------------*/--#pragma once--// for FILE-#include <stdio.h>--// Chunk capacity-// This is rather arbitrary-#define BACKTRACE_CHUNK_SZ 256--/*- * Note [Chunked stack representation]- * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- *- * Consider the stack,- * main calls (bottom of stack)- * func1 which in turn calls- * func2 which calls- * func3 which calls- * func4 which calls- * func5 which calls- * func6 which calls- * func7 which requests a backtrace (top of stack)- *- * This would produce the Backtrace (using a smaller chunk size of three for- * illustrative purposes),- *- * Backtrace /----> Chunk /----> Chunk /----> Chunk- * last --------/ next --------/ next --------/ next- * n_frames=8 n_frames=2 n_frames=3 n_frames=3- * ~~~~~~~~~~ ~~~~~~~~~~ ~~~~~~~~~~- * func1 func4 func7- * main func3 func6- * func2 func5- *- */--/* A chunk of code addresses from an execution stack- *- * The first address in this list corresponds to the stack frame- * nearest to the "top" of the stack.- */-typedef struct BacktraceChunk_ {- StgWord n_frames; // number of frames in this chunk- struct BacktraceChunk_ *next; // the chunk following this one- StgPtr frames[BACKTRACE_CHUNK_SZ]; // the code addresses from the- // frames-} __attribute__((packed)) BacktraceChunk;--/* A chunked list of code addresses from an execution stack- *- * This structure is optimized for append operations since we append O(stack- * depth) times yet typically only traverse the stack trace once. Consequently,- * the "top" stack frame (that is, the one where we started unwinding) can be- * found in the last chunk. Yes, this is a bit inconsistent with the ordering- * within a chunk. See Note [Chunked stack representation] for a depiction.- */-typedef struct Backtrace_ {- StgWord n_frames; // Total number of frames in the backtrace- BacktraceChunk *last; // The first chunk of frames (corresponding to the- // bottom of the stack)-} Backtrace;--/* Various information describing the location of an address */-typedef struct Location_ {- const char *object_file;- const char *function;-- // lineno and colno are only valid if source_file /= NULL- const char *source_file;- StgWord32 lineno;- StgWord32 colno;-} __attribute__((packed)) Location;--struct LibdwSession_;-typedef struct LibdwSession_ LibdwSession;--/* Free a backtrace */-void backtraceFree(Backtrace *bt);--/* Request a backtrace of the current stack state.- * May return NULL if a backtrace can't be acquired. */-Backtrace *libdwGetBacktrace(LibdwSession *session);--/* Lookup Location information for the given address.- * Returns 0 if successful, 1 if address could not be found. */-int libdwLookupLocation(LibdwSession *session, Location *loc, StgPtr pc);--/* Pretty-print a backtrace to the given FILE */-void libdwPrintBacktrace(LibdwSession *session, FILE *file, Backtrace *bt);
− includes/rts/LibdwPool.h
@@ -1,19 +0,0 @@-/* ---------------------------------------------------------------------------- *- * (c) The GHC Team, 2015-2016- *- * A pool of libdw sessions- *- * --------------------------------------------------------------------------*/--#pragma once--/* Claim a session from the pool */-LibdwSession *libdwPoolTake(void);--/* Return a session to the pool */-void libdwPoolRelease(LibdwSession *sess);--/* Free any sessions in the pool forcing a reload of any loaded debug- * information */-void libdwPoolClear(void);
− includes/rts/Linker.h
@@ -1,101 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 2009- *- * RTS Object Linker- *- * Do not #include this file directly: #include "Rts.h" instead.- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * ---------------------------------------------------------------------------*/--#pragma once--#if defined(mingw32_HOST_OS)-typedef wchar_t pathchar;-#define PATH_FMT "ls"-#else-typedef char pathchar;-#define PATH_FMT "s"-#endif--/* Initialize the object linker. Equivalent to initLinker_(1). */-void initLinker (void);--/* Initialize the object linker.- * The retain_cafs argument is:- *- * non-zero => Retain CAFs unconditionally in linked Haskell code.- * Note that this prevents any code from being unloaded.- * It should not be necessary unless you are GHCi or- * hs-plugins, which needs to be able call any function- * in the compiled code.- *- * zero => Do not retain CAFs. Everything reachable from foreign- * exports will be retained, due to the StablePtrs- * created by the module initialisation code. unloadObj- * frees these StablePtrs, which will allow the CAFs to- * be GC'd and the code to be removed.- */-void initLinker_ (int retain_cafs);--/* insert a symbol in the hash table */-HsInt insertSymbol(pathchar* obj_name, char* key, void* data);--/* lookup a symbol in the hash table */-void *lookupSymbol( char *lbl );--/* See Linker.c Note [runtime-linker-phases] */-typedef enum {- OBJECT_LOADED,- OBJECT_NEEDED,- OBJECT_RESOLVED,- OBJECT_UNLOADED,- OBJECT_DONT_RESOLVE,- OBJECT_NOT_LOADED /* The object was either never loaded or has been- fully unloaded */-} OStatus;--/* check object load status */-OStatus getObjectLoadStatus( pathchar *path );--/* delete an object from the pool */-HsInt unloadObj( pathchar *path );--/* purge an object's symbols from the symbol table, but don't unload it */-HsInt purgeObj( pathchar *path );--/* add an obj (populate the global symbol table, but don't resolve yet) */-HsInt loadObj( pathchar *path );--/* add an arch (populate the global symbol table, but don't resolve yet) */-HsInt loadArchive( pathchar *path );--/* resolve all the currently unlinked objects in memory */-HsInt resolveObjs( void );--/* load a dynamic library */-const char *addDLL( pathchar* dll_name );--/* add a path to the library search path */-HsPtr addLibrarySearchPath(pathchar* dll_path);--/* removes a directory from the search path,- path must have been added using addLibrarySearchPath */-HsBool removeLibrarySearchPath(HsPtr dll_path_index);--/* give a warning about missing Windows patches that would make- the linker work better */-void warnMissingKBLibraryPaths( void );--/* ------------------------------------------------------------------------------* Searches the system directories to determine if there is a system DLL that-* satisfies the given name. This prevent GHCi from linking against a static-* library if a DLL is available.-*/-pathchar* findSystemLibrary(pathchar* dll_name);--/* called by the initialization code for a module, not a user API */-StgStablePtr foreignExportStablePtr (StgPtr p);
− includes/rts/Main.h
@@ -1,18 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 2009- *- * Entry point for standalone Haskell programs.- *- * ---------------------------------------------------------------------------*/--#pragma once--/* ------------------------------------------------------------------------------ * The entry point for Haskell programs that use a Haskell main function- * -------------------------------------------------------------------------- */--int hs_main (int argc, char *argv[], // program args- StgClosure *main_closure, // closure for Main.main- RtsConfig rts_config) // RTS configuration- GNUC3_ATTRIBUTE(__noreturn__);
− includes/rts/Messages.h
@@ -1,104 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 1998-2009- *- * Message API for use inside the RTS. All messages generated by the- * RTS should go through one of the functions declared here, and we- * also provide hooks so that messages from the RTS can be redirected- * as appropriate.- *- * Do not #include this file directly: #include "Rts.h" instead.- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * ---------------------------------------------------------------------------*/--#pragma once--#include <stdarg.h>--#if defined(mingw32_HOST_OS)-/* On Win64, if we say "printf" then gcc thinks we are going to use- MS format specifiers like %I64d rather than %llu */-#define PRINTF gnu_printf-#else-/* However, on OS X, "gnu_printf" isn't recognised */-#define PRINTF printf-#endif--/* ------------------------------------------------------------------------------ * Message generation- * -------------------------------------------------------------------------- */--/*- * A fatal internal error: this is for errors that probably indicate- * bugs in the RTS or compiler. We normally output bug reporting- * instructions along with the error message.- *- * barf() invokes (*fatalInternalErrorFn)(). This function is not- * expected to return.- */-void barf(const char *s, ...)- GNUC3_ATTRIBUTE(__noreturn__)- GNUC3_ATTRIBUTE(format(PRINTF, 1, 2));--void vbarf(const char *s, va_list ap)- GNUC3_ATTRIBUTE(__noreturn__);--// declared in Rts.h:-// extern void _assertFail(const char *filename, unsigned int linenum)-// GNUC3_ATTRIBUTE(__noreturn__);--/*- * An error condition which is caused by and/or can be corrected by- * the user.- *- * errorBelch() invokes (*errorMsgFn)().- */-void errorBelch(const char *s, ...)- GNUC3_ATTRIBUTE(format (PRINTF, 1, 2));--void verrorBelch(const char *s, va_list ap);--/*- * An error condition which is caused by and/or can be corrected by- * the user, and which has an associated error condition reported- * by the system (in errno on Unix, and GetLastError() on Windows).- * The system error message is appended to the message generated- * from the supplied format string.- *- * sysErrorBelch() invokes (*sysErrorMsgFn)().- */-void sysErrorBelch(const char *s, ...)- GNUC3_ATTRIBUTE(format (PRINTF, 1, 2));--void vsysErrorBelch(const char *s, va_list ap);--/*- * A debugging message. Debugging messages are generated either as a- * virtue of having DEBUG turned on, or by being explicitly selected- * via RTS options (eg. +RTS -Ds).- *- * debugBelch() invokes (*debugMsgFn)().- */-void debugBelch(const char *s, ...)- GNUC3_ATTRIBUTE(format (PRINTF, 1, 2));--void vdebugBelch(const char *s, va_list ap);---/* Hooks for redirecting message generation: */--typedef void RtsMsgFunction(const char *, va_list);--extern RtsMsgFunction *fatalInternalErrorFn;-extern RtsMsgFunction *debugMsgFn;-extern RtsMsgFunction *errorMsgFn;--/* Default stdio implementation of the message hooks: */--extern RtsMsgFunction rtsFatalInternalErrorFn;-extern RtsMsgFunction rtsDebugMsgFn;-extern RtsMsgFunction rtsErrorMsgFn;-extern RtsMsgFunction rtsSysErrorMsgFn;
− includes/rts/OSThreads.h
@@ -1,258 +0,0 @@-/* ---------------------------------------------------------------------------- *- * (c) The GHC Team, 2001-2009- *- * Accessing OS threads functionality in a (mostly) OS-independent- * manner.- *- * Do not #include this file directly: #include "Rts.h" instead.- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * --------------------------------------------------------------------------*/--#pragma once--#if defined(HAVE_PTHREAD_H) && !defined(mingw32_HOST_OS)--#if defined(CMINUSMINUS)--#define OS_ACQUIRE_LOCK(mutex) foreign "C" pthread_mutex_lock(mutex)-#define OS_RELEASE_LOCK(mutex) foreign "C" pthread_mutex_unlock(mutex)-#define OS_ASSERT_LOCK_HELD(mutex) /* nothing */--#else--#include <pthread.h>-#include <errno.h>--typedef pthread_cond_t Condition;-typedef pthread_mutex_t Mutex;-typedef pthread_t OSThreadId;-typedef pthread_key_t ThreadLocalKey;--#define OSThreadProcAttr /* nothing */--#define INIT_COND_VAR PTHREAD_COND_INITIALIZER--#if defined(LOCK_DEBUG)-#define LOCK_DEBUG_BELCH(what, mutex) \- debugBelch("%s(0x%p) %s %d\n", what, mutex, __FILE__, __LINE__)-#else-#define LOCK_DEBUG_BELCH(what, mutex) /* nothing */-#endif--/* Always check the result of lock and unlock. */-#define OS_ACQUIRE_LOCK(mutex) \- LOCK_DEBUG_BELCH("ACQUIRE_LOCK", mutex); \- if (pthread_mutex_lock(mutex) == EDEADLK) { \- barf("multiple ACQUIRE_LOCK: %s %d", __FILE__,__LINE__); \- }--// Returns zero if the lock was acquired.-EXTERN_INLINE int TRY_ACQUIRE_LOCK(pthread_mutex_t *mutex);-EXTERN_INLINE int TRY_ACQUIRE_LOCK(pthread_mutex_t *mutex)-{- LOCK_DEBUG_BELCH("TRY_ACQUIRE_LOCK", mutex);- return pthread_mutex_trylock(mutex);-}--#define OS_RELEASE_LOCK(mutex) \- LOCK_DEBUG_BELCH("RELEASE_LOCK", mutex); \- if (pthread_mutex_unlock(mutex) != 0) { \- barf("RELEASE_LOCK: I do not own this lock: %s %d", __FILE__,__LINE__); \- }--// Note: this assertion calls pthread_mutex_lock() on a mutex that-// is already held by the calling thread. The mutex should therefore-// have been created with PTHREAD_MUTEX_ERRORCHECK, otherwise this-// assertion will hang. We always initialise mutexes with-// PTHREAD_MUTEX_ERRORCHECK when DEBUG is on (see rts/posix/OSThreads.h).-#define OS_ASSERT_LOCK_HELD(mutex) ASSERT(pthread_mutex_lock(mutex) == EDEADLK)--#endif // CMINUSMINUS--# elif defined(HAVE_WINDOWS_H)--#if defined(CMINUSMINUS)--/* We jump through a hoop here to get a CCall EnterCriticalSection- and LeaveCriticalSection, as that's what C-- wants. */--#define OS_ACQUIRE_LOCK(mutex) foreign "stdcall" EnterCriticalSection(mutex)-#define OS_RELEASE_LOCK(mutex) foreign "stdcall" LeaveCriticalSection(mutex)-#define OS_ASSERT_LOCK_HELD(mutex) /* nothing */--#else--#include <windows.h>--typedef HANDLE Condition;-typedef DWORD OSThreadId;-// don't be tempted to use HANDLE as the OSThreadId: there can be-// many HANDLES to a given thread, so comparison would not work.-typedef DWORD ThreadLocalKey;--#define OSThreadProcAttr __stdcall--#define INIT_COND_VAR 0--// We have a choice for implementing Mutexes on Windows. Standard-// Mutexes are kernel objects that require kernel calls to-// acquire/release, whereas CriticalSections are spin-locks that block-// in the kernel after spinning for a configurable number of times.-// CriticalSections are *much* faster, so we use those. The Mutex-// implementation is left here for posterity.-#define USE_CRITICAL_SECTIONS 1--#if USE_CRITICAL_SECTIONS--typedef CRITICAL_SECTION Mutex;--#if defined(LOCK_DEBUG)--#define OS_ACQUIRE_LOCK(mutex) \- debugBelch("ACQUIRE_LOCK(0x%p) %s %d\n", mutex,__FILE__,__LINE__); \- EnterCriticalSection(mutex)-#define OS_RELEASE_LOCK(mutex) \- debugBelch("RELEASE_LOCK(0x%p) %s %d\n", mutex,__FILE__,__LINE__); \- LeaveCriticalSection(mutex)-#define OS_ASSERT_LOCK_HELD(mutex) /* nothing */--#else--#define OS_ACQUIRE_LOCK(mutex) EnterCriticalSection(mutex)-#define TRY_ACQUIRE_LOCK(mutex) (TryEnterCriticalSection(mutex) == 0)-#define OS_RELEASE_LOCK(mutex) LeaveCriticalSection(mutex)--// I don't know how to do this. TryEnterCriticalSection() doesn't do-// the right thing.-#define OS_ASSERT_LOCK_HELD(mutex) /* nothing */--#endif--#else--typedef HANDLE Mutex;--// casting to (Mutex *) here required due to use in .cmm files where-// the argument has (void *) type.-#define OS_ACQUIRE_LOCK(mutex) \- if (WaitForSingleObject(*((Mutex *)mutex),INFINITE) == WAIT_FAILED) { \- barf("WaitForSingleObject: %d", GetLastError()); \- }--#define OS_RELEASE_LOCK(mutex) \- if (ReleaseMutex(*((Mutex *)mutex)) == 0) { \- barf("ReleaseMutex: %d", GetLastError()); \- }--#define OS_ASSERT_LOCK_HELD(mutex) /* nothing */-#endif--#endif // CMINUSMINUS--# elif defined(THREADED_RTS)-# error "Threads not supported"-# endif---#if !defined(CMINUSMINUS)-//-// General thread operations-//-extern OSThreadId osThreadId ( void );-extern void shutdownThread ( void ) GNUC3_ATTRIBUTE(__noreturn__);-extern void yieldThread ( void );--typedef void* OSThreadProcAttr OSThreadProc(void *);--extern int createOSThread ( OSThreadId* tid, char *name,- OSThreadProc *startProc, void *param);-extern bool osThreadIsAlive ( OSThreadId id );-extern void interruptOSThread (OSThreadId id);--//-// Condition Variables-//-extern void initCondition ( Condition* pCond );-extern void closeCondition ( Condition* pCond );-extern bool broadcastCondition ( Condition* pCond );-extern bool signalCondition ( Condition* pCond );-extern bool waitCondition ( Condition* pCond, Mutex* pMut );--//-// Mutexes-//-extern void initMutex ( Mutex* pMut );-extern void closeMutex ( Mutex* pMut );--//-// Thread-local storage-//-void newThreadLocalKey (ThreadLocalKey *key);-void *getThreadLocalVar (ThreadLocalKey *key);-void setThreadLocalVar (ThreadLocalKey *key, void *value);-void freeThreadLocalKey (ThreadLocalKey *key);--// Processors and affinity-void setThreadAffinity (uint32_t n, uint32_t m);-void setThreadNode (uint32_t node);-void releaseThreadNode (void);-#endif // !CMINUSMINUS--#if defined(THREADED_RTS)--#define ACQUIRE_LOCK(l) OS_ACQUIRE_LOCK(l)-#define RELEASE_LOCK(l) OS_RELEASE_LOCK(l)-#define ASSERT_LOCK_HELD(l) OS_ASSERT_LOCK_HELD(l)--#else--#define ACQUIRE_LOCK(l)-#define RELEASE_LOCK(l)-#define ASSERT_LOCK_HELD(l)--#endif /* defined(THREADED_RTS) */--#if !defined(CMINUSMINUS)-//-// Support for forkOS (defined regardless of THREADED_RTS, but does-// nothing when !THREADED_RTS).-//-int forkOS_createThread ( HsStablePtr entry );--//-// Free any global resources created in OSThreads.-//-void freeThreadingResources(void);--//-// Returns the number of processor cores in the machine-//-uint32_t getNumberOfProcessors (void);--//-// Support for getting at the kernel thread Id for tracing/profiling.-//-// This stuff is optional and only used for tracing/profiling purposes, to-// match up thread ids recorded by other tools. For example, on Linux and OSX-// the pthread_t type is not the same as the kernel thread id, and system-// profiling tools like Linux perf, and OSX's DTrace use the kernel thread Id.-// So if we want to match up RTS tasks with kernel threads recorded by these-// tools then we need to know the kernel thread Id, and this must be a separate-// type from the OSThreadId.-//-// If the feature cannot be supported on an OS, it is OK to always return 0.-// In particular it would almost certaily be meaningless on systems not using-// a 1:1 threading model.--// We use a common serialisable representation on all OSs-// This is ok for Windows, OSX and Linux.-typedef StgWord64 KernelThreadId;--// Get the current kernel thread id-KernelThreadId kernelThreadId (void);--#endif /* CMINUSMINUS */
− includes/rts/Parallel.h
@@ -1,16 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 1998-2009- *- * Parallelism-related functionality- *- * Do not #include this file directly: #include "Rts.h" instead.- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * -------------------------------------------------------------------------- */--#pragma once--StgInt newSpark (StgRegTable *reg, StgClosure *p);
− includes/rts/PrimFloat.h
@@ -1,17 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 1998-2009- *- * Primitive floating-point operations- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * ---------------------------------------------------------------------------*/--#pragma once--StgDouble __int_encodeDouble (I_ j, I_ e);-StgFloat __int_encodeFloat (I_ j, I_ e);-StgDouble __word_encodeDouble (W_ j, I_ e);-StgFloat __word_encodeFloat (W_ j, I_ e);
− includes/rts/Profiling.h
@@ -1,17 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 2017-2018- *- * Cost-centre profiling API- *- * Do not #include this file directly: #include "Rts.h" instead.- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * -------------------------------------------------------------------------- */--#pragma once--void registerCcList(CostCentre **cc_list);-void registerCcsList(CostCentreStack **cc_list);
− includes/rts/Signals.h
@@ -1,23 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 1998-2009- *- * RTS signal handling - *- * Do not #include this file directly: #include "Rts.h" instead.- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * ---------------------------------------------------------------------------*/--#pragma once--/* NB. #included in Haskell code, no prototypes in here. */--/* arguments to stg_sig_install() */-#define STG_SIG_DFL (-1)-#define STG_SIG_IGN (-2)-#define STG_SIG_ERR (-3)-#define STG_SIG_HAN (-4)-#define STG_SIG_RST (-5)
− includes/rts/SpinLock.h
@@ -1,116 +0,0 @@-/* ----------------------------------------------------------------------------- *- * (c) The GHC Team, 2006-2009- *- * Spin locks- *- * These are simple spin-only locks as opposed to Mutexes which- * probably spin for a while before blocking in the kernel. We use- * these when we are sure that all our threads are actively running on- * a CPU, eg. in the GC.- *- * TODO: measure whether we really need these, or whether Mutexes- * would do (and be a bit safer if a CPU becomes loaded).- *- * Do not #include this file directly: #include "Rts.h" instead.- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * -------------------------------------------------------------------------- */--#pragma once--#if defined(THREADED_RTS)--#if defined(PROF_SPIN)-typedef struct SpinLock_-{- StgWord lock;- StgWord64 spin; // incremented every time we spin in ACQUIRE_SPIN_LOCK- StgWord64 yield; // incremented every time we yield in ACQUIRE_SPIN_LOCK-} SpinLock;-#else-typedef StgWord SpinLock;-#endif--#if defined(PROF_SPIN)--// PROF_SPIN enables counting the number of times we spin on a lock--// acquire spin lock-INLINE_HEADER void ACQUIRE_SPIN_LOCK(SpinLock * p)-{- StgWord32 r = 0;- uint32_t i;- do {- for (i = 0; i < SPIN_COUNT; i++) {- r = cas((StgVolatilePtr)&(p->lock), 1, 0);- if (r != 0) return;- p->spin++;- busy_wait_nop();- }- p->yield++;- yieldThread();- } while (1);-}--// release spin lock-INLINE_HEADER void RELEASE_SPIN_LOCK(SpinLock * p)-{- write_barrier();- p->lock = 1;-}--// initialise spin lock-INLINE_HEADER void initSpinLock(SpinLock * p)-{- write_barrier();- p->lock = 1;- p->spin = 0;- p->yield = 0;-}--#else--// acquire spin lock-INLINE_HEADER void ACQUIRE_SPIN_LOCK(SpinLock * p)-{- StgWord32 r = 0;- uint32_t i;- do {- for (i = 0; i < SPIN_COUNT; i++) {- r = cas((StgVolatilePtr)p, 1, 0);- if (r != 0) return;- busy_wait_nop();- }- yieldThread();- } while (1);-}--// release spin lock-INLINE_HEADER void RELEASE_SPIN_LOCK(SpinLock * p)-{- write_barrier();- (*p) = 1;-}--// init spin lock-INLINE_HEADER void initSpinLock(SpinLock * p)-{- write_barrier();- (*p) = 1;-}--#endif /* PROF_SPIN */--#else /* !THREADED_RTS */--// Using macros here means we don't have to ensure the argument is in scope-#define ACQUIRE_SPIN_LOCK(p) /* nothing */-#define RELEASE_SPIN_LOCK(p) /* nothing */--INLINE_HEADER void initSpinLock(void * p STG_UNUSED)-{ /* nothing */ }--#endif /* THREADED_RTS */
− includes/rts/StableName.h
@@ -1,32 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 1998-2009- *- * Stable Names- *- * Do not #include this file directly: #include "Rts.h" instead.- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * ---------------------------------------------------------------------------*/--#pragma once--/* ------------------------------------------------------------------------------ PRIVATE from here.- -------------------------------------------------------------------------- */--typedef struct {- StgPtr addr; // Haskell object when entry is in use, next free- // entry (NULL when this is the last free entry)- // otherwise. May be NULL temporarily during GC (when- // pointee dies).-- StgPtr old; // Old Haskell object, used during GC-- StgClosure *sn_obj; // The StableName object, or NULL when the entry is- // free-} snEntry;--extern DLL_IMPORT_RTS snEntry *stable_name_table;
− includes/rts/StablePtr.h
@@ -1,35 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 1998-2009- *- * Stable Pointers- *- * Do not #include this file directly: #include "Rts.h" instead.- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * ---------------------------------------------------------------------------*/--#pragma once--EXTERN_INLINE StgPtr deRefStablePtr (StgStablePtr stable_ptr);-StgStablePtr getStablePtr (StgPtr p);--/* ------------------------------------------------------------------------------ PRIVATE from here.- -------------------------------------------------------------------------- */--typedef struct {- StgPtr addr; // Haskell object when entry is in use, next free- // entry (NULL when this is the last free entry)- // otherwise.-} spEntry;--extern DLL_IMPORT_RTS spEntry *stable_ptr_table;--EXTERN_INLINE-StgPtr deRefStablePtr(StgStablePtr sp)-{- return stable_ptr_table[(StgWord)sp].addr;-}
− includes/rts/StaticPtrTable.h
@@ -1,44 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 2008-2009- *- * Initialization of the Static Pointer Table- *- * Do not #include this file directly: #include "Rts.h" instead.- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * -------------------------------------------------------------------------- */--#pragma once--/** Inserts an entry in the Static Pointer Table.- *- * The key is a fingerprint computed from the static pointer and the spe_closure- * is a pointer to the closure defining the table entry.- *- * A stable pointer to the closure is made to prevent it from being garbage- * collected while the entry exists on the table.- *- * This function is called from the code generated by- * compiler/deSugar/StaticPtrTable.sptInitCode- *- * */-void hs_spt_insert (StgWord64 key[2],void* spe_closure);--/** Inserts an entry for a StgTablePtr in the Static Pointer Table.- *- * This function is called from the GHCi interpreter to insert- * SPT entries for bytecode objects.- *- * */-void hs_spt_insert_stableptr(StgWord64 key[2], StgStablePtr *entry);--/** Removes an entry from the Static Pointer Table.- *- * This function is called from the code generated by- * compiler/deSugar/StaticPtrTable.sptInitCode- *- * */-void hs_spt_remove (StgWord64 key[2]);
− includes/rts/TTY.h
@@ -1,17 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 2009- *- * POSIX TTY-related functionality- *- * Do not #include this file directly: #include "Rts.h" instead.- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * -------------------------------------------------------------------------- */--#pragma once--void* __hscore_get_saved_termios(int fd);-void __hscore_set_saved_termios(int fd, void* ts);
− includes/rts/Threads.h
@@ -1,74 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team 1998-2009- *- * External API for the scheduler. For most uses, the functions in- * RtsAPI.h should be enough.- *- * Do not #include this file directly: #include "Rts.h" instead.- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * ---------------------------------------------------------------------------*/--#pragma once--#if defined(HAVE_SYS_TYPES_H)-#include <sys/types.h>-#endif--//-// Creating threads-//-StgTSO *createThread (Capability *cap, W_ stack_size);--void scheduleWaitThread (/* in */ StgTSO *tso,- /* out */ HaskellObj* ret,- /* inout */ Capability **cap);--StgTSO *createGenThread (Capability *cap, W_ stack_size,- StgClosure *closure);-StgTSO *createIOThread (Capability *cap, W_ stack_size,- StgClosure *closure);-StgTSO *createStrictIOThread (Capability *cap, W_ stack_size,- StgClosure *closure);--// Suspending/resuming threads around foreign calls-void * suspendThread (StgRegTable *, bool interruptible);-StgRegTable * resumeThread (void *);--//-// Thread operations from Threads.c-//-int cmp_thread (StgPtr tso1, StgPtr tso2);-int rts_getThreadId (StgPtr tso);-void rts_enableThreadAllocationLimit (StgPtr tso);-void rts_disableThreadAllocationLimit (StgPtr tso);--#if !defined(mingw32_HOST_OS)-pid_t forkProcess (HsStablePtr *entry);-#else-pid_t forkProcess (HsStablePtr *entry)- GNU_ATTRIBUTE(__noreturn__);-#endif--HsBool rtsSupportsBoundThreads (void);--// The number of Capabilities.-// ToDo: I would like this to be private to the RTS and instead expose a-// function getNumCapabilities(), but it is used in compiler/cbits/genSym.c-extern unsigned int n_capabilities;--// The number of Capabilities that are not disabled-extern uint32_t enabled_capabilities;--#if !IN_STG_CODE-extern Capability MainCapability;-#endif--//-// Change the number of capabilities (only supports increasing the-// current value at the moment).-//-extern void setNumCapabilities (uint32_t new_);
− includes/rts/Ticky.h
@@ -1,32 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 1998-2009- *- * TICKY_TICKY types- *- * Do not #include this file directly: #include "Rts.h" instead.- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * ---------------------------------------------------------------------------*/--#pragma once--/* ------------------------------------------------------------------------------ The StgEntCounter type - needed regardless of TICKY_TICKY- -------------------------------------------------------------------------- */--typedef struct _StgEntCounter {- /* Using StgWord for everything, because both the C and asm code- generators make trouble if you try to pack things tighter */- StgWord registeredp; /* 0 == no, 1 == yes */- StgInt arity; /* arity (static info) */- StgInt allocd; /* # allocation of this closure */- /* (rest of args are in registers) */- char *str; /* name of the thing */- char *arg_kinds; /* info about the args types */- StgInt entry_count; /* Trips to fast entry code */- StgInt allocs; /* number of allocations by this fun */- struct _StgEntCounter *link;/* link to chain them all together */-} StgEntCounter;
− includes/rts/Time.h
@@ -1,44 +0,0 @@-/* ----------------------------------------------------------------------------- *- * (c) The GHC Team, 1998-2004- *- * Time values in the RTS- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * --------------------------------------------------------------------------*/--#pragma once--// For most time values in the RTS we use a fixed resolution of nanoseconds,-// normalising the time we get from platform-dependent APIs to this-// resolution.-#define TIME_RESOLUTION 1000000000-typedef int64_t Time;--#define TIME_MAX HS_INT64_MAX--#if TIME_RESOLUTION == 1000000000-// I'm being lazy, but it's awkward to define fully general versions of these-#define TimeToMS(t) ((t) / 1000000)-#define TimeToUS(t) ((t) / 1000)-#define TimeToNS(t) (t)-#define MSToTime(t) ((Time)(t) * 1000000)-#define USToTime(t) ((Time)(t) * 1000)-#define NSToTime(t) ((Time)(t))-#else-#error Fix TimeToNS(), TimeToUS() etc.-#endif--#define SecondsToTime(t) ((Time)(t) * TIME_RESOLUTION)-#define TimeToSeconds(t) ((t) / TIME_RESOLUTION)--// Use instead of SecondsToTime() when we have a floating-point-// seconds value, to avoid truncating it.-INLINE_HEADER Time fsecondsToTime (double t)-{- return (Time)(t * TIME_RESOLUTION);-}--Time getProcessElapsedTime (void);
− includes/rts/Timer.h
@@ -1,18 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 1995-2009- *- * Interface to the RTS timer signal (uses OS-dependent Ticker.h underneath)- *- * Do not #include this file directly: #include "Rts.h" instead.- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * ---------------------------------------------------------------------------*/--#pragma once--void startTimer (void);-void stopTimer (void);-int rtsTimerSignal (void);
− includes/rts/Types.h
@@ -1,31 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 1998-2009- *- * RTS-specific types.- *- * Do not #include this file directly: #include "Rts.h" instead.- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * ---------------------------------------------------------------------------*/--#pragma once--#include <stddef.h>-#include <stdbool.h>--// Deprecated, use uint32_t instead.-typedef unsigned int nat __attribute__((deprecated)); /* uint32_t */--/* ullong (64|128-bit) type: only include if needed (not ANSI) */-#if defined(__GNUC__)-#define LL(x) (x##LL)-#else-#define LL(x) (x##L)-#endif--typedef struct StgClosure_ StgClosure;-typedef struct StgInfoTable_ StgInfoTable;-typedef struct StgTSO_ StgTSO;
− includes/rts/Utils.h
@@ -1,16 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 1998-2009- *- * RTS external APIs. This file declares everything that the GHC RTS- * exposes externally.- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * ---------------------------------------------------------------------------*/--#pragma once--/* Alternate to raise(3) for threaded rts, for BSD-based OSes */-int genericRaise(int sig);
− includes/rts/prof/CCS.h
@@ -1,226 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 2009-2012- *- * Macros for profiling operations in STG code- *- * Do not #include this file directly: #include "Rts.h" instead.- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * ---------------------------------------------------------------------------*/--#pragma once--/* ------------------------------------------------------------------------------ * Data Structures- * ---------------------------------------------------------------------------*/-/*- * Note [struct alignment]- * NB. be careful to avoid unwanted padding between fields, by- * putting the 8-byte fields on an 8-byte boundary. Padding can- * vary between C compilers, and we don't take into account any- * possible padding when generating CCS and CC decls in the code- * generator (compiler/codeGen/StgCmmProf.hs).- */--typedef struct CostCentre_ {- StgInt ccID; // Unique Id, allocated by the RTS-- char * label;- char * module;- char * srcloc;-- // used for accumulating costs at the end of the run...- StgWord64 mem_alloc; // align 8 (Note [struct alignment])- StgWord time_ticks;-- StgBool is_caf; // true <=> CAF cost centre-- struct CostCentre_ *link;-} CostCentre;--typedef struct CostCentreStack_ {- StgInt ccsID; // unique ID, allocated by the RTS-- CostCentre *cc; // Cost centre at the top of the stack-- struct CostCentreStack_ *prevStack; // parent- struct IndexTable_ *indexTable; // children- struct CostCentreStack_ *root; // root of stack- StgWord depth; // number of items in the stack-- StgWord64 scc_count; // Count of times this CCS is entered- // align 8 (Note [struct alignment])-- StgWord selected; // is this CCS shown in the heap- // profile? (zero if excluded via -hc- // -hm etc.)-- StgWord time_ticks; // number of time ticks accumulated by- // this CCS-- StgWord64 mem_alloc; // mem allocated by this CCS- // align 8 (Note [struct alignment])-- StgWord64 inherited_alloc; // sum of mem_alloc over all children- // (calculated at the end)- // align 8 (Note [struct alignment])-- StgWord inherited_ticks; // sum of time_ticks over all children- // (calculated at the end)-} CostCentreStack;---/* ------------------------------------------------------------------------------ * Start and stop the profiling timer. These can be called from- * Haskell to restrict the profile to portion(s) of the execution.- * See the module GHC.Profiling.- * ---------------------------------------------------------------------------*/--void stopProfTimer ( void );-void startProfTimer ( void );--/* ------------------------------------------------------------------------------ * The rest is PROFILING only...- * ---------------------------------------------------------------------------*/--#if defined(PROFILING)--/* ------------------------------------------------------------------------------ * Constants- * ---------------------------------------------------------------------------*/--#define EMPTY_STACK NULL-#define EMPTY_TABLE NULL--/* Constants used to set is_caf flag on CostCentres */-#define CC_IS_CAF true-#define CC_NOT_CAF false-/* ------------------------------------------------------------------------------ * Data Structures- * ---------------------------------------------------------------------------*/--// IndexTable is the list of children of a CCS. (Alternatively it is a-// cache of the results of pushing onto a CCS, so that the second and-// subsequent times we push a certain CC on a CCS we get the same-// result).--typedef struct IndexTable_ {- // Just a linked list of (cc, ccs) pairs, where the `ccs` is the result of- // pushing `cc` to the owner of the index table (another CostCentreStack).- CostCentre *cc;- CostCentreStack *ccs;- struct IndexTable_ *next;- // back_edge is true when `cc` is already in the stack, so pushing it- // truncates or drops (see RECURSION_DROPS and RECURSION_TRUNCATES in- // Profiling.c).- bool back_edge;-} IndexTable;---/* ------------------------------------------------------------------------------ Pre-defined cost centres and cost centre stacks- -------------------------------------------------------------------------- */--#if IN_STG_CODE--extern StgWord CC_MAIN[];-extern StgWord CCS_MAIN[]; // Top CCS--extern StgWord CC_SYSTEM[];-extern StgWord CCS_SYSTEM[]; // RTS costs--extern StgWord CC_GC[];-extern StgWord CCS_GC[]; // Garbage collector costs--extern StgWord CC_OVERHEAD[];-extern StgWord CCS_OVERHEAD[]; // Profiling overhead--extern StgWord CC_DONT_CARE[];-extern StgWord CCS_DONT_CARE[]; // CCS attached to static constructors--#else--extern CostCentre CC_MAIN[];-extern CostCentreStack CCS_MAIN[]; // Top CCS--extern CostCentre CC_SYSTEM[];-extern CostCentreStack CCS_SYSTEM[]; // RTS costs--extern CostCentre CC_GC[];-extern CostCentreStack CCS_GC[]; // Garbage collector costs--extern CostCentre CC_OVERHEAD[];-extern CostCentreStack CCS_OVERHEAD[]; // Profiling overhead--extern CostCentre CC_DONT_CARE[];-extern CostCentreStack CCS_DONT_CARE[]; // shouldn't ever get set--extern CostCentre CC_PINNED[];-extern CostCentreStack CCS_PINNED[]; // pinned memory--extern CostCentre CC_IDLE[];-extern CostCentreStack CCS_IDLE[]; // capability is idle--#endif /* IN_STG_CODE */--extern unsigned int RTS_VAR(era);--/* ------------------------------------------------------------------------------ * Functions- * ---------------------------------------------------------------------------*/--CostCentreStack * pushCostCentre (CostCentreStack *, CostCentre *);-void enterFunCCS (StgRegTable *reg, CostCentreStack *);-CostCentre *mkCostCentre (char *label, char *module, char *srcloc);--extern CostCentre * RTS_VAR(CC_LIST); // registered CC list--/* ------------------------------------------------------------------------------ * Declaring Cost Centres & Cost Centre Stacks.- * -------------------------------------------------------------------------- */--# define CC_DECLARE(cc_ident,name,mod,loc,caf,is_local) \- is_local CostCentre cc_ident[1] \- = {{ .ccID = 0, \- .label = name, \- .module = mod, \- .srcloc = loc, \- .time_ticks = 0, \- .mem_alloc = 0, \- .link = 0, \- .is_caf = caf \- }};--# define CCS_DECLARE(ccs_ident,cc_ident,is_local) \- is_local CostCentreStack ccs_ident[1] \- = {{ .ccsID = 0, \- .cc = cc_ident, \- .prevStack = NULL, \- .indexTable = NULL, \- .root = NULL, \- .depth = 0, \- .selected = 0, \- .scc_count = 0, \- .time_ticks = 0, \- .mem_alloc = 0, \- .inherited_ticks = 0, \- .inherited_alloc = 0 \- }};--/* ------------------------------------------------------------------------------ * Time / Allocation Macros- * ---------------------------------------------------------------------------*/--/* eliminate profiling overhead from allocation costs */-#define CCS_ALLOC(ccs, size) (ccs)->mem_alloc += ((size)-sizeofW(StgProfHeader))-#define ENTER_CCS_THUNK(cap,p) cap->r.rCCCS = p->header.prof.ccs--#else /* !PROFILING */--#define CCS_ALLOC(ccs, amount) doNothing()-#define ENTER_CCS_THUNK(cap,p) doNothing()--#endif /* PROFILING */
− includes/rts/prof/LDV.h
@@ -1,44 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The University of Glasgow, 2009- *- * Lag/Drag/Void profiling.- *- * Do not #include this file directly: #include "Rts.h" instead.- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * ---------------------------------------------------------------------------*/--#pragma once--#if defined(PROFILING)--/* retrieves the LDV word from closure c */-#define LDVW(c) (((StgClosure *)(c))->header.prof.hp.ldvw)--/*- * Stores the creation time for closure c.- * This macro is called at the very moment of closure creation.- *- * NOTE: this initializes LDVW(c) to zero, which ensures that there- * is no conflict between retainer profiling and LDV profiling,- * because retainer profiling also expects LDVW(c) to be initialised- * to zero.- */--#if defined(CMINUSMINUS)--#else--#define LDV_RECORD_CREATE(c) \- LDVW((c)) = ((StgWord)RTS_DEREF(era) << LDV_SHIFT) | LDV_STATE_CREATE--#endif--#else /* !PROFILING */--#define LDV_RECORD_CREATE(c) /* nothing */--#endif /* PROFILING */
− includes/rts/storage/Block.h
@@ -1,341 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 1998-1999- *- * Block structure for the storage manager- *- * ---------------------------------------------------------------------------*/--#pragma once--#include "ghcconfig.h"--/* The actual block and megablock-size constants are defined in- * includes/Constants.h, all constants here are derived from these.- */--/* Block related constants (BLOCK_SHIFT is defined in Constants.h) */--#if SIZEOF_LONG == SIZEOF_VOID_P-#define UNIT 1UL-#elif SIZEOF_LONG_LONG == SIZEOF_VOID_P-#define UNIT 1ULL-#else-#error "Size of pointer is suspicious."-#endif--#if defined(CMINUSMINUS)-#define BLOCK_SIZE (1<<BLOCK_SHIFT)-#else-#define BLOCK_SIZE (UNIT<<BLOCK_SHIFT)-// Note [integer overflow]-#endif--#define BLOCK_SIZE_W (BLOCK_SIZE/sizeof(W_))-#define BLOCK_MASK (BLOCK_SIZE-1)--#define BLOCK_ROUND_UP(p) (((W_)(p)+BLOCK_SIZE-1) & ~BLOCK_MASK)-#define BLOCK_ROUND_DOWN(p) ((void *) ((W_)(p) & ~BLOCK_MASK))--/* Megablock related constants (MBLOCK_SHIFT is defined in Constants.h) */--#if defined(CMINUSMINUS)-#define MBLOCK_SIZE (1<<MBLOCK_SHIFT)-#else-#define MBLOCK_SIZE (UNIT<<MBLOCK_SHIFT)-// Note [integer overflow]-#endif--#define MBLOCK_SIZE_W (MBLOCK_SIZE/sizeof(W_))-#define MBLOCK_MASK (MBLOCK_SIZE-1)--#define MBLOCK_ROUND_UP(p) ((void *)(((W_)(p)+MBLOCK_SIZE-1) & ~MBLOCK_MASK))-#define MBLOCK_ROUND_DOWN(p) ((void *)((W_)(p) & ~MBLOCK_MASK ))--/* The largest size an object can be before we give it a block of its- * own and treat it as an immovable object during GC, expressed as a- * fraction of BLOCK_SIZE.- */-#define LARGE_OBJECT_THRESHOLD ((uint32_t)(BLOCK_SIZE * 8 / 10))--/*- * Note [integer overflow]- *- * The UL suffix in BLOCK_SIZE and MBLOCK_SIZE promotes the expression- * to an unsigned long, which means that expressions involving these- * will be promoted to unsigned long, which makes integer overflow- * less likely. Historically, integer overflow in expressions like- * (n * BLOCK_SIZE)- * where n is int or unsigned int, have caused obscure segfaults in- * programs that use large amounts of memory (e.g. #7762, #5086).- */--/* ------------------------------------------------------------------------------ * Block descriptor. This structure *must* be the right length, so we- * can do pointer arithmetic on pointers to it.- */--/* The block descriptor is 64 bytes on a 64-bit machine, and 32-bytes- * on a 32-bit machine.- */--// Note: fields marked with [READ ONLY] must not be modified by the-// client of the block allocator API. All other fields can be-// freely modified.--#if !defined(CMINUSMINUS)-typedef struct bdescr_ {-- StgPtr start; // [READ ONLY] start addr of memory-- StgPtr free; // First free byte of memory.- // allocGroup() sets this to the value of start.- // NB. during use this value should lie- // between start and start + blocks *- // BLOCK_SIZE. Values outside this- // range are reserved for use by the- // block allocator. In particular, the- // value (StgPtr)(-1) is used to- // indicate that a block is unallocated.-- struct bdescr_ *link; // used for chaining blocks together-- union {- struct bdescr_ *back; // used (occasionally) for doubly-linked lists- StgWord *bitmap; // bitmap for marking GC- StgPtr scan; // scan pointer for copying GC- } u;-- struct generation_ *gen; // generation-- StgWord16 gen_no; // gen->no, cached- StgWord16 dest_no; // number of destination generation- StgWord16 node; // which memory node does this block live on?-- StgWord16 flags; // block flags, see below-- StgWord32 blocks; // [READ ONLY] no. of blocks in a group- // (if group head, 0 otherwise)--#if SIZEOF_VOID_P == 8- StgWord32 _padding[3];-#else- StgWord32 _padding[0];-#endif-} bdescr;-#endif--#if SIZEOF_VOID_P == 8-#define BDESCR_SIZE 0x40-#define BDESCR_MASK 0x3f-#define BDESCR_SHIFT 6-#else-#define BDESCR_SIZE 0x20-#define BDESCR_MASK 0x1f-#define BDESCR_SHIFT 5-#endif--/* Block contains objects evacuated during this GC */-#define BF_EVACUATED 1-/* Block is a large object */-#define BF_LARGE 2-/* Block is pinned */-#define BF_PINNED 4-/* Block is to be marked, not copied */-#define BF_MARKED 8-/* Block is executable */-#define BF_EXEC 32-/* Block contains only a small amount of live data */-#define BF_FRAGMENTED 64-/* we know about this block (for finding leaks) */-#define BF_KNOWN 128-/* Block was swept in the last generation */-#define BF_SWEPT 256-/* Block is part of a Compact */-#define BF_COMPACT 512-/* Maximum flag value (do not define anything higher than this!) */-#define BF_FLAG_MAX (1 << 15)--/* Finding the block descriptor for a given block -------------------------- */--#if defined(CMINUSMINUS)--#define Bdescr(p) \- ((((p) & MBLOCK_MASK & ~BLOCK_MASK) >> (BLOCK_SHIFT-BDESCR_SHIFT)) \- | ((p) & ~MBLOCK_MASK))--#else--EXTERN_INLINE bdescr *Bdescr(StgPtr p);-EXTERN_INLINE bdescr *Bdescr(StgPtr p)-{- return (bdescr *)- ((((W_)p & MBLOCK_MASK & ~BLOCK_MASK) >> (BLOCK_SHIFT-BDESCR_SHIFT))- | ((W_)p & ~MBLOCK_MASK)- );-}--#endif--/* Useful Macros ------------------------------------------------------------ */--/* Offset of first real data block in a megablock */--#define FIRST_BLOCK_OFF \- ((W_)BLOCK_ROUND_UP(BDESCR_SIZE * (MBLOCK_SIZE / BLOCK_SIZE)))--/* First data block in a given megablock */--#define FIRST_BLOCK(m) ((void *)(FIRST_BLOCK_OFF + (W_)(m)))--/* Last data block in a given megablock */--#define LAST_BLOCK(m) ((void *)(MBLOCK_SIZE-BLOCK_SIZE + (W_)(m)))--/* First real block descriptor in a megablock */--#define FIRST_BDESCR(m) \- ((bdescr *)((FIRST_BLOCK_OFF>>(BLOCK_SHIFT-BDESCR_SHIFT)) + (W_)(m)))--/* Last real block descriptor in a megablock */--#define LAST_BDESCR(m) \- ((bdescr *)(((MBLOCK_SIZE-BLOCK_SIZE)>>(BLOCK_SHIFT-BDESCR_SHIFT)) + (W_)(m)))--/* Number of usable blocks in a megablock */--#if !defined(CMINUSMINUS) // already defined in DerivedConstants.h-#define BLOCKS_PER_MBLOCK ((MBLOCK_SIZE - FIRST_BLOCK_OFF) / BLOCK_SIZE)-#endif--/* How many blocks in this megablock group */--#define MBLOCK_GROUP_BLOCKS(n) \- (BLOCKS_PER_MBLOCK + (n-1) * (MBLOCK_SIZE / BLOCK_SIZE))--/* Compute the required size of a megablock group */--#define BLOCKS_TO_MBLOCKS(n) \- (1 + (W_)MBLOCK_ROUND_UP((n-BLOCKS_PER_MBLOCK) * BLOCK_SIZE) / MBLOCK_SIZE)---#if !defined(CMINUSMINUS)-/* to the end... */--/* Double-linked block lists: --------------------------------------------- */--INLINE_HEADER void-dbl_link_onto(bdescr *bd, bdescr **list)-{- bd->link = *list;- bd->u.back = NULL;- if (*list) {- (*list)->u.back = bd; /* double-link the list */- }- *list = bd;-}--INLINE_HEADER void-dbl_link_remove(bdescr *bd, bdescr **list)-{- if (bd->u.back) {- bd->u.back->link = bd->link;- } else {- *list = bd->link;- }- if (bd->link) {- bd->link->u.back = bd->u.back;- }-}--INLINE_HEADER void-dbl_link_insert_after(bdescr *bd, bdescr *after)-{- bd->link = after->link;- bd->u.back = after;- if (after->link) {- after->link->u.back = bd;- }- after->link = bd;-}--INLINE_HEADER void-dbl_link_replace(bdescr *new_, bdescr *old, bdescr **list)-{- new_->link = old->link;- new_->u.back = old->u.back;- if (old->link) {- old->link->u.back = new_;- }- if (old->u.back) {- old->u.back->link = new_;- } else {- *list = new_;- }-}--/* Initialisation ---------------------------------------------------------- */--extern void initBlockAllocator(void);--/* Allocation -------------------------------------------------------------- */--bdescr *allocGroup(W_ n);--EXTERN_INLINE bdescr* allocBlock(void);-EXTERN_INLINE bdescr* allocBlock(void)-{- return allocGroup(1);-}--bdescr *allocGroupOnNode(uint32_t node, W_ n);--EXTERN_INLINE bdescr* allocBlockOnNode(uint32_t node);-EXTERN_INLINE bdescr* allocBlockOnNode(uint32_t node)-{- return allocGroupOnNode(node,1);-}--// versions that take the storage manager lock for you:-bdescr *allocGroup_lock(W_ n);-bdescr *allocBlock_lock(void);--bdescr *allocGroupOnNode_lock(uint32_t node, W_ n);-bdescr *allocBlockOnNode_lock(uint32_t node);--/* De-Allocation ----------------------------------------------------------- */--void freeGroup(bdescr *p);-void freeChain(bdescr *p);--// versions that take the storage manager lock for you:-void freeGroup_lock(bdescr *p);-void freeChain_lock(bdescr *p);--bdescr * splitBlockGroup (bdescr *bd, uint32_t blocks);--/* Round a value to megablocks --------------------------------------------- */--// We want to allocate an object around a given size, round it up or-// down to the nearest size that will fit in an mblock group.-INLINE_HEADER StgWord-round_to_mblocks(StgWord words)-{- if (words > BLOCKS_PER_MBLOCK * BLOCK_SIZE_W) {- // first, ignore the gap at the beginning of the first mblock by- // adding it to the total words. Then we can pretend we're- // dealing in a uniform unit of megablocks.- words += FIRST_BLOCK_OFF/sizeof(W_);-- if ((words % MBLOCK_SIZE_W) < (MBLOCK_SIZE_W / 2)) {- words = (words / MBLOCK_SIZE_W) * MBLOCK_SIZE_W;- } else {- words = ((words / MBLOCK_SIZE_W) + 1) * MBLOCK_SIZE_W;- }-- words -= FIRST_BLOCK_OFF/sizeof(W_);- }- return words;-}--#endif /* !CMINUSMINUS */
− includes/rts/storage/ClosureMacros.h
@@ -1,591 +0,0 @@-/* ----------------------------------------------------------------------------- *- * (c) The GHC Team, 1998-2012- *- * Macros for building and manipulating closures- *- * -------------------------------------------------------------------------- */--#pragma once--/* ------------------------------------------------------------------------------ Info tables are slammed up against the entry code, and the label- for the info table is at the *end* of the table itself. This- inline function adjusts an info pointer to point to the beginning- of the table, so we can use standard C structure indexing on it.-- Note: this works for SRT info tables as long as you don't want to- access the SRT, since they are laid out the same with the SRT- pointer as the first word in the table.-- NOTES ABOUT MANGLED C VS. MINI-INTERPRETER:-- A couple of definitions:-- "info pointer" The first word of the closure. Might point- to either the end or the beginning of the- info table, depending on whether we're using- the mini interpreter or not. GET_INFO(c)- retrieves the info pointer of a closure.-- "info table" The info table structure associated with a- closure. This is always a pointer to the- beginning of the structure, so we can- use standard C structure indexing to pull out- the fields. get_itbl(c) returns a pointer to- the info table for closure c.-- An address of the form xxxx_info points to the end of the info- table or the beginning of the info table depending on whether we're- mangling or not respectively. So,-- c->header.info = xxx_info-- makes absolute sense, whether mangling or not.-- -------------------------------------------------------------------------- */--INLINE_HEADER void SET_INFO(StgClosure *c, const StgInfoTable *info) {- c->header.info = info;-}-INLINE_HEADER const StgInfoTable *GET_INFO(StgClosure *c) {- return c->header.info;-}--#define GET_ENTRY(c) (ENTRY_CODE(GET_INFO(c)))--#if defined(TABLES_NEXT_TO_CODE)-EXTERN_INLINE StgInfoTable *INFO_PTR_TO_STRUCT(const StgInfoTable *info);-EXTERN_INLINE StgInfoTable *INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgInfoTable *)info - 1;}-EXTERN_INLINE StgRetInfoTable *RET_INFO_PTR_TO_STRUCT(const StgInfoTable *info);-EXTERN_INLINE StgRetInfoTable *RET_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgRetInfoTable *)info - 1;}-INLINE_HEADER StgFunInfoTable *FUN_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgFunInfoTable *)info - 1;}-INLINE_HEADER StgThunkInfoTable *THUNK_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgThunkInfoTable *)info - 1;}-INLINE_HEADER StgConInfoTable *CON_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgConInfoTable *)info - 1;}-INLINE_HEADER StgFunInfoTable *itbl_to_fun_itbl(const StgInfoTable *i) {return (StgFunInfoTable *)(i + 1) - 1;}-INLINE_HEADER StgRetInfoTable *itbl_to_ret_itbl(const StgInfoTable *i) {return (StgRetInfoTable *)(i + 1) - 1;}-INLINE_HEADER StgThunkInfoTable *itbl_to_thunk_itbl(const StgInfoTable *i) {return (StgThunkInfoTable *)(i + 1) - 1;}-INLINE_HEADER StgConInfoTable *itbl_to_con_itbl(const StgInfoTable *i) {return (StgConInfoTable *)(i + 1) - 1;}-#else-EXTERN_INLINE StgInfoTable *INFO_PTR_TO_STRUCT(const StgInfoTable *info);-EXTERN_INLINE StgInfoTable *INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgInfoTable *)info;}-EXTERN_INLINE StgRetInfoTable *RET_INFO_PTR_TO_STRUCT(const StgInfoTable *info);-EXTERN_INLINE StgRetInfoTable *RET_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgRetInfoTable *)info;}-INLINE_HEADER StgFunInfoTable *FUN_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgFunInfoTable *)info;}-INLINE_HEADER StgThunkInfoTable *THUNK_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgThunkInfoTable *)info;}-INLINE_HEADER StgConInfoTable *CON_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgConInfoTable *)info;}-INLINE_HEADER StgFunInfoTable *itbl_to_fun_itbl(const StgInfoTable *i) {return (StgFunInfoTable *)i;}-INLINE_HEADER StgRetInfoTable *itbl_to_ret_itbl(const StgInfoTable *i) {return (StgRetInfoTable *)i;}-INLINE_HEADER StgThunkInfoTable *itbl_to_thunk_itbl(const StgInfoTable *i) {return (StgThunkInfoTable *)i;}-INLINE_HEADER StgConInfoTable *itbl_to_con_itbl(const StgInfoTable *i) {return (StgConInfoTable *)i;}-#endif--EXTERN_INLINE const StgInfoTable *get_itbl(const StgClosure *c);-EXTERN_INLINE const StgInfoTable *get_itbl(const StgClosure *c)-{- return INFO_PTR_TO_STRUCT(c->header.info);-}--EXTERN_INLINE const StgRetInfoTable *get_ret_itbl(const StgClosure *c);-EXTERN_INLINE const StgRetInfoTable *get_ret_itbl(const StgClosure *c)-{- return RET_INFO_PTR_TO_STRUCT(c->header.info);-}--INLINE_HEADER const StgFunInfoTable *get_fun_itbl(const StgClosure *c)-{- return FUN_INFO_PTR_TO_STRUCT(c->header.info);-}--INLINE_HEADER const StgThunkInfoTable *get_thunk_itbl(const StgClosure *c)-{- return THUNK_INFO_PTR_TO_STRUCT(c->header.info);-}--INLINE_HEADER const StgConInfoTable *get_con_itbl(const StgClosure *c)-{- return CON_INFO_PTR_TO_STRUCT((c)->header.info);-}--INLINE_HEADER StgHalfWord GET_TAG(const StgClosure *con)-{- return get_itbl(con)->srt;-}--/* ------------------------------------------------------------------------------ Macros for building closures- -------------------------------------------------------------------------- */--#if defined(PROFILING)-#if defined(DEBUG_RETAINER)-/*- For the sake of debugging, we take the safest way for the moment. Actually, this- is useful to check the sanity of heap before beginning retainer profiling.- flip is defined in RetainerProfile.c, and declared as extern in RetainerProfile.h.- Note: change those functions building Haskell objects from C datatypes, i.e.,- all rts_mk???() functions in RtsAPI.c, as well.- */-#define SET_PROF_HDR(c,ccs_) \- ((c)->header.prof.ccs = ccs_, (c)->header.prof.hp.rs = (retainerSet *)((StgWord)NULL | flip))-#else-/*- For retainer profiling only: we do not have to set (c)->header.prof.hp.rs to- NULL | flip (flip is defined in RetainerProfile.c) because even when flip- is 1, rs is invalid and will be initialized to NULL | flip later when- the closure *c is visited.- */-/*-#define SET_PROF_HDR(c,ccs_) \- ((c)->header.prof.ccs = ccs_, (c)->header.prof.hp.rs = NULL)- */-/*- The following macro works for both retainer profiling and LDV profiling:- for retainer profiling, ldvTime remains 0, so rs fields are initialized to 0.- See the invariants on ldvTime.- */-#define SET_PROF_HDR(c,ccs_) \- ((c)->header.prof.ccs = ccs_, \- LDV_RECORD_CREATE((c)))-#endif /* DEBUG_RETAINER */-#else-#define SET_PROF_HDR(c,ccs)-#endif--#define SET_HDR(c,_info,ccs) \- { \- (c)->header.info = _info; \- SET_PROF_HDR((StgClosure *)(c),ccs); \- }--#define SET_ARR_HDR(c,info,costCentreStack,n_bytes) \- SET_HDR(c,info,costCentreStack); \- (c)->bytes = n_bytes;--// Use when changing a closure from one kind to another-#define OVERWRITE_INFO(c, new_info) \- OVERWRITING_CLOSURE((StgClosure *)(c)); \- SET_INFO((StgClosure *)(c), (new_info)); \- LDV_RECORD_CREATE(c);--/* ------------------------------------------------------------------------------ How to get hold of the static link field for a static closure.- -------------------------------------------------------------------------- */--/* These are hard-coded. */-#define THUNK_STATIC_LINK(p) (&(p)->payload[1])-#define IND_STATIC_LINK(p) (&(p)->payload[1])--INLINE_HEADER StgClosure **-STATIC_LINK(const StgInfoTable *info, StgClosure *p)-{- switch (info->type) {- case THUNK_STATIC:- return THUNK_STATIC_LINK(p);- case IND_STATIC:- return IND_STATIC_LINK(p);- default:- return &p->payload[info->layout.payload.ptrs +- info->layout.payload.nptrs];- }-}--/* ------------------------------------------------------------------------------ INTLIKE and CHARLIKE closures.- -------------------------------------------------------------------------- */--INLINE_HEADER P_ CHARLIKE_CLOSURE(int n) {- return (P_)&stg_CHARLIKE_closure[(n)-MIN_CHARLIKE];-}-INLINE_HEADER P_ INTLIKE_CLOSURE(int n) {- return (P_)&stg_INTLIKE_closure[(n)-MIN_INTLIKE];-}--/* ----------------------------------------------------------------------------- Macros for untagging and retagging closure pointers- For more information look at the comments in Cmm.h- ------------------------------------------------------------------------- */--static inline StgWord-GET_CLOSURE_TAG(const StgClosure * p)-{- return (StgWord)p & TAG_MASK;-}--static inline StgClosure *-UNTAG_CLOSURE(StgClosure * p)-{- return (StgClosure*)((StgWord)p & ~TAG_MASK);-}--static inline const StgClosure *-UNTAG_CONST_CLOSURE(const StgClosure * p)-{- return (const StgClosure*)((StgWord)p & ~TAG_MASK);-}--static inline StgClosure *-TAG_CLOSURE(StgWord tag,StgClosure * p)-{- return (StgClosure*)((StgWord)p | tag);-}--/* ------------------------------------------------------------------------------ Forwarding pointers- -------------------------------------------------------------------------- */--#define IS_FORWARDING_PTR(p) ((((StgWord)p) & 1) != 0)-#define MK_FORWARDING_PTR(p) (((StgWord)p) | 1)-#define UN_FORWARDING_PTR(p) (((StgWord)p) - 1)--/* ------------------------------------------------------------------------------ DEBUGGING predicates for pointers-- LOOKS_LIKE_INFO_PTR(p) returns False if p is definitely not an info ptr- LOOKS_LIKE_CLOSURE_PTR(p) returns False if p is definitely not a closure ptr-- These macros are complete but not sound. That is, they might- return false positives. Do not rely on them to distinguish info- pointers from closure pointers, for example.-- We don't use address-space predicates these days, for portability- reasons, and the fact that code/data can be scattered about the- address space in a dynamically-linked environment. Our best option- is to look at the alleged info table and see whether it seems to- make sense...- -------------------------------------------------------------------------- */--INLINE_HEADER bool LOOKS_LIKE_INFO_PTR_NOT_NULL (StgWord p)-{- StgInfoTable *info = INFO_PTR_TO_STRUCT((StgInfoTable *)p);- return info->type != INVALID_OBJECT && info->type < N_CLOSURE_TYPES;-}--INLINE_HEADER bool LOOKS_LIKE_INFO_PTR (StgWord p)-{- return p && (IS_FORWARDING_PTR(p) || LOOKS_LIKE_INFO_PTR_NOT_NULL(p));-}--INLINE_HEADER bool LOOKS_LIKE_CLOSURE_PTR (const void *p)-{- return LOOKS_LIKE_INFO_PTR((StgWord)- (UNTAG_CONST_CLOSURE((const StgClosure *)(p)))->header.info);-}--/* ------------------------------------------------------------------------------ Macros for calculating the size of a closure- -------------------------------------------------------------------------- */--EXTERN_INLINE StgOffset PAP_sizeW ( uint32_t n_args );-EXTERN_INLINE StgOffset PAP_sizeW ( uint32_t n_args )-{ return sizeofW(StgPAP) + n_args; }--EXTERN_INLINE StgOffset AP_sizeW ( uint32_t n_args );-EXTERN_INLINE StgOffset AP_sizeW ( uint32_t n_args )-{ return sizeofW(StgAP) + n_args; }--EXTERN_INLINE StgOffset AP_STACK_sizeW ( uint32_t size );-EXTERN_INLINE StgOffset AP_STACK_sizeW ( uint32_t size )-{ return sizeofW(StgAP_STACK) + size; }--EXTERN_INLINE StgOffset CONSTR_sizeW( uint32_t p, uint32_t np );-EXTERN_INLINE StgOffset CONSTR_sizeW( uint32_t p, uint32_t np )-{ return sizeofW(StgHeader) + p + np; }--EXTERN_INLINE StgOffset THUNK_SELECTOR_sizeW ( void );-EXTERN_INLINE StgOffset THUNK_SELECTOR_sizeW ( void )-{ return sizeofW(StgSelector); }--EXTERN_INLINE StgOffset BLACKHOLE_sizeW ( void );-EXTERN_INLINE StgOffset BLACKHOLE_sizeW ( void )-{ return sizeofW(StgInd); } // a BLACKHOLE is a kind of indirection--/* --------------------------------------------------------------------------- Sizes of closures- ------------------------------------------------------------------------*/--EXTERN_INLINE StgOffset sizeW_fromITBL( const StgInfoTable* itbl );-EXTERN_INLINE StgOffset sizeW_fromITBL( const StgInfoTable* itbl )-{ return sizeofW(StgClosure)- + sizeofW(StgPtr) * itbl->layout.payload.ptrs- + sizeofW(StgWord) * itbl->layout.payload.nptrs; }--EXTERN_INLINE StgOffset thunk_sizeW_fromITBL( const StgInfoTable* itbl );-EXTERN_INLINE StgOffset thunk_sizeW_fromITBL( const StgInfoTable* itbl )-{ return sizeofW(StgThunk)- + sizeofW(StgPtr) * itbl->layout.payload.ptrs- + sizeofW(StgWord) * itbl->layout.payload.nptrs; }--EXTERN_INLINE StgOffset ap_stack_sizeW( StgAP_STACK* x );-EXTERN_INLINE StgOffset ap_stack_sizeW( StgAP_STACK* x )-{ return AP_STACK_sizeW(x->size); }--EXTERN_INLINE StgOffset ap_sizeW( StgAP* x );-EXTERN_INLINE StgOffset ap_sizeW( StgAP* x )-{ return AP_sizeW(x->n_args); }--EXTERN_INLINE StgOffset pap_sizeW( StgPAP* x );-EXTERN_INLINE StgOffset pap_sizeW( StgPAP* x )-{ return PAP_sizeW(x->n_args); }--EXTERN_INLINE StgWord arr_words_words( StgArrBytes* x);-EXTERN_INLINE StgWord arr_words_words( StgArrBytes* x)-{ return ROUNDUP_BYTES_TO_WDS(x->bytes); }--EXTERN_INLINE StgOffset arr_words_sizeW( StgArrBytes* x );-EXTERN_INLINE StgOffset arr_words_sizeW( StgArrBytes* x )-{ return sizeofW(StgArrBytes) + arr_words_words(x); }--EXTERN_INLINE StgOffset mut_arr_ptrs_sizeW( StgMutArrPtrs* x );-EXTERN_INLINE StgOffset mut_arr_ptrs_sizeW( StgMutArrPtrs* x )-{ return sizeofW(StgMutArrPtrs) + x->size; }--EXTERN_INLINE StgOffset small_mut_arr_ptrs_sizeW( StgSmallMutArrPtrs* x );-EXTERN_INLINE StgOffset small_mut_arr_ptrs_sizeW( StgSmallMutArrPtrs* x )-{ return sizeofW(StgSmallMutArrPtrs) + x->ptrs; }--EXTERN_INLINE StgWord stack_sizeW ( StgStack *stack );-EXTERN_INLINE StgWord stack_sizeW ( StgStack *stack )-{ return sizeofW(StgStack) + stack->stack_size; }--EXTERN_INLINE StgWord bco_sizeW ( StgBCO *bco );-EXTERN_INLINE StgWord bco_sizeW ( StgBCO *bco )-{ return bco->size; }--EXTERN_INLINE StgWord compact_nfdata_full_sizeW ( StgCompactNFData *str );-EXTERN_INLINE StgWord compact_nfdata_full_sizeW ( StgCompactNFData *str )-{ return str->totalW; }--/*- * TODO: Consider to switch return type from 'uint32_t' to 'StgWord' #8742- *- * (Also for 'closure_sizeW' below)- */-EXTERN_INLINE uint32_t-closure_sizeW_ (const StgClosure *p, const StgInfoTable *info);-EXTERN_INLINE uint32_t-closure_sizeW_ (const StgClosure *p, const StgInfoTable *info)-{- switch (info->type) {- case THUNK_0_1:- case THUNK_1_0:- return sizeofW(StgThunk) + 1;- case FUN_0_1:- case CONSTR_0_1:- case FUN_1_0:- case CONSTR_1_0:- return sizeofW(StgHeader) + 1;- case THUNK_0_2:- case THUNK_1_1:- case THUNK_2_0:- return sizeofW(StgThunk) + 2;- case FUN_0_2:- case CONSTR_0_2:- case FUN_1_1:- case CONSTR_1_1:- case FUN_2_0:- case CONSTR_2_0:- return sizeofW(StgHeader) + 2;- case THUNK:- return thunk_sizeW_fromITBL(info);- case THUNK_SELECTOR:- return THUNK_SELECTOR_sizeW();- case AP_STACK:- return ap_stack_sizeW((StgAP_STACK *)p);- case AP:- return ap_sizeW((StgAP *)p);- case PAP:- return pap_sizeW((StgPAP *)p);- case IND:- return sizeofW(StgInd);- case ARR_WORDS:- return arr_words_sizeW((StgArrBytes *)p);- case MUT_ARR_PTRS_CLEAN:- case MUT_ARR_PTRS_DIRTY:- case MUT_ARR_PTRS_FROZEN_CLEAN:- case MUT_ARR_PTRS_FROZEN_DIRTY:- return mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);- case SMALL_MUT_ARR_PTRS_CLEAN:- case SMALL_MUT_ARR_PTRS_DIRTY:- case SMALL_MUT_ARR_PTRS_FROZEN_CLEAN:- case SMALL_MUT_ARR_PTRS_FROZEN_DIRTY:- return small_mut_arr_ptrs_sizeW((StgSmallMutArrPtrs*)p);- case TSO:- return sizeofW(StgTSO);- case STACK:- return stack_sizeW((StgStack*)p);- case BCO:- return bco_sizeW((StgBCO *)p);- case TREC_CHUNK:- return sizeofW(StgTRecChunk);- default:- return sizeW_fromITBL(info);- }-}--// The definitive way to find the size, in words, of a heap-allocated closure-EXTERN_INLINE uint32_t closure_sizeW (const StgClosure *p);-EXTERN_INLINE uint32_t closure_sizeW (const StgClosure *p)-{- return closure_sizeW_(p, get_itbl(p));-}--/* ------------------------------------------------------------------------------ Sizes of stack frames- -------------------------------------------------------------------------- */--EXTERN_INLINE StgWord stack_frame_sizeW( StgClosure *frame );-EXTERN_INLINE StgWord stack_frame_sizeW( StgClosure *frame )-{- const StgRetInfoTable *info;-- info = get_ret_itbl(frame);- switch (info->i.type) {-- case RET_FUN:- return sizeofW(StgRetFun) + ((StgRetFun *)frame)->size;-- case RET_BIG:- return 1 + GET_LARGE_BITMAP(&info->i)->size;-- case RET_BCO:- return 2 + BCO_BITMAP_SIZE((StgBCO *)((P_)frame)[1]);-- default:- return 1 + BITMAP_SIZE(info->i.layout.bitmap);- }-}--/* ------------------------------------------------------------------------------ StgMutArrPtrs macros-- An StgMutArrPtrs has a card table to indicate which elements are- dirty for the generational GC. The card table is an array of- bytes, where each byte covers (1 << MUT_ARR_PTRS_CARD_BITS)- elements. The card table is directly after the array data itself.- -------------------------------------------------------------------------- */--// The number of card bytes needed-INLINE_HEADER W_ mutArrPtrsCards (W_ elems)-{- return (W_)((elems + (1 << MUT_ARR_PTRS_CARD_BITS) - 1)- >> MUT_ARR_PTRS_CARD_BITS);-}--// The number of words in the card table-INLINE_HEADER W_ mutArrPtrsCardTableSize (W_ elems)-{- return ROUNDUP_BYTES_TO_WDS(mutArrPtrsCards(elems));-}--// The address of the card for a particular card number-INLINE_HEADER StgWord8 *mutArrPtrsCard (StgMutArrPtrs *a, W_ n)-{- return ((StgWord8 *)&(a->payload[a->ptrs]) + n);-}--/* ------------------------------------------------------------------------------ Replacing a closure with a different one. We must call- OVERWRITING_CLOSURE(p) on the old closure that is about to be- overwritten.-- Note [zeroing slop]-- In some scenarios we write zero words into "slop"; memory that is- left unoccupied after we overwrite a closure in the heap with a- smaller closure.-- Zeroing slop is required for:-- - full-heap sanity checks (DEBUG, and +RTS -DS)- - LDV profiling (PROFILING, and +RTS -hb)-- Zeroing slop must be disabled for:-- - THREADED_RTS with +RTS -N2 and greater, because we cannot- overwrite slop when another thread might be reading it.-- Hence, slop is zeroed when either:-- - PROFILING && era <= 0 (LDV is on)- - !THREADED_RTS && DEBUG-- And additionally:-- - LDV profiling and +RTS -N2 are incompatible- - full-heap sanity checks are disabled for THREADED_RTS-- -------------------------------------------------------------------------- */--#if defined(PROFILING)-#define ZERO_SLOP_FOR_LDV_PROF 1-#else-#define ZERO_SLOP_FOR_LDV_PROF 0-#endif--#if defined(DEBUG) && !defined(THREADED_RTS)-#define ZERO_SLOP_FOR_SANITY_CHECK 1-#else-#define ZERO_SLOP_FOR_SANITY_CHECK 0-#endif--#if ZERO_SLOP_FOR_LDV_PROF || ZERO_SLOP_FOR_SANITY_CHECK-#define OVERWRITING_CLOSURE(c) overwritingClosure(c)-#define OVERWRITING_CLOSURE_OFS(c,n) overwritingClosureOfs(c,n)-#else-#define OVERWRITING_CLOSURE(c) /* nothing */-#define OVERWRITING_CLOSURE_OFS(c,n) /* nothing */-#endif--#if defined(PROFILING)-void LDV_recordDead (const StgClosure *c, uint32_t size);-#endif--EXTERN_INLINE void overwritingClosure_ (StgClosure *p,- uint32_t offset /* in words */,- uint32_t size /* closure size, in words */,- bool prim /* Whether to call LDV_recordDead */- );-EXTERN_INLINE void overwritingClosure_ (StgClosure *p, uint32_t offset, uint32_t size, bool prim USED_IF_PROFILING)-{-#if ZERO_SLOP_FOR_LDV_PROF && !ZERO_SLOP_FOR_SANITY_CHECK- // see Note [zeroing slop], also #8402- if (era <= 0) return;-#endif-- // For LDV profiling, we need to record the closure as dead-#if defined(PROFILING)- if (!prim) { LDV_recordDead(p, size); };-#endif-- for (uint32_t i = offset; i < size; i++) {- ((StgWord *)p)[i] = 0;- }-}--EXTERN_INLINE void overwritingClosure (StgClosure *p);-EXTERN_INLINE void overwritingClosure (StgClosure *p)-{- overwritingClosure_(p, sizeofW(StgThunkHeader), closure_sizeW(p), false);-}--// Version of 'overwritingClosure' which overwrites only a suffix of a-// closure. The offset is expressed in words relative to 'p' and shall-// be less than or equal to closure_sizeW(p), and usually at least as-// large as the respective thunk header.-//-// Note: As this calls LDV_recordDead() you have to call LDV_RECORD()-// on the final state of the closure at the call-site-EXTERN_INLINE void overwritingClosureOfs (StgClosure *p, uint32_t offset);-EXTERN_INLINE void overwritingClosureOfs (StgClosure *p, uint32_t offset)-{- // Set prim = true because only called on ARR_WORDS with the- // shrinkMutableByteArray# primop- overwritingClosure_(p, offset, closure_sizeW(p), true);-}--// Version of 'overwritingClosure' which takes closure size as argument.-EXTERN_INLINE void overwritingClosureSize (StgClosure *p, uint32_t size /* in words */);-EXTERN_INLINE void overwritingClosureSize (StgClosure *p, uint32_t size)-{- overwritingClosure_(p, sizeofW(StgThunkHeader), size, false);-}
− includes/rts/storage/ClosureTypes.h
@@ -1,86 +0,0 @@-/* ----------------------------------------------------------------------------- *- * (c) The GHC Team, 1998-2005- *- * Closure Type Constants: out here because the native code generator- * needs to get at them.- *- * -------------------------------------------------------------------------- */--#pragma once--/*- * WARNING WARNING WARNING- *- * If you add or delete any closure types, don't forget to update the following,- * - the closure flags table in rts/ClosureFlags.c- * - isRetainer in rts/RetainerProfile.c- * - the closure_type_names list in rts/Printer.c- */--/* Object tag 0 raises an internal error */-#define INVALID_OBJECT 0-#define CONSTR 1-#define CONSTR_1_0 2-#define CONSTR_0_1 3-#define CONSTR_2_0 4-#define CONSTR_1_1 5-#define CONSTR_0_2 6-#define CONSTR_NOCAF 7-#define FUN 8-#define FUN_1_0 9-#define FUN_0_1 10-#define FUN_2_0 11-#define FUN_1_1 12-#define FUN_0_2 13-#define FUN_STATIC 14-#define THUNK 15-#define THUNK_1_0 16-#define THUNK_0_1 17-#define THUNK_2_0 18-#define THUNK_1_1 19-#define THUNK_0_2 20-#define THUNK_STATIC 21-#define THUNK_SELECTOR 22-#define BCO 23-#define AP 24-#define PAP 25-#define AP_STACK 26-#define IND 27-#define IND_STATIC 28-#define RET_BCO 29-#define RET_SMALL 30-#define RET_BIG 31-#define RET_FUN 32-#define UPDATE_FRAME 33-#define CATCH_FRAME 34-#define UNDERFLOW_FRAME 35-#define STOP_FRAME 36-#define BLOCKING_QUEUE 37-#define BLACKHOLE 38-#define MVAR_CLEAN 39-#define MVAR_DIRTY 40-#define TVAR 41-#define ARR_WORDS 42-#define MUT_ARR_PTRS_CLEAN 43-#define MUT_ARR_PTRS_DIRTY 44-#define MUT_ARR_PTRS_FROZEN_DIRTY 45-#define MUT_ARR_PTRS_FROZEN_CLEAN 46-#define MUT_VAR_CLEAN 47-#define MUT_VAR_DIRTY 48-#define WEAK 49-#define PRIM 50-#define MUT_PRIM 51-#define TSO 52-#define STACK 53-#define TREC_CHUNK 54-#define ATOMICALLY_FRAME 55-#define CATCH_RETRY_FRAME 56-#define CATCH_STM_FRAME 57-#define WHITEHOLE 58-#define SMALL_MUT_ARR_PTRS_CLEAN 59-#define SMALL_MUT_ARR_PTRS_DIRTY 60-#define SMALL_MUT_ARR_PTRS_FROZEN_DIRTY 61-#define SMALL_MUT_ARR_PTRS_FROZEN_CLEAN 62-#define COMPACT_NFDATA 63-#define N_CLOSURE_TYPES 64
− includes/rts/storage/Closures.h
@@ -1,470 +0,0 @@-/* ----------------------------------------------------------------------------- *- * (c) The GHC Team, 1998-2004- *- * Closures- *- * -------------------------------------------------------------------------- */--#pragma once--/*- * The Layout of a closure header depends on which kind of system we're- * compiling for: profiling, parallel, ticky, etc.- */--/* ------------------------------------------------------------------------------ The profiling header- -------------------------------------------------------------------------- */--typedef struct {- CostCentreStack *ccs;- union {- struct _RetainerSet *rs; /* Retainer Set */- StgWord ldvw; /* Lag/Drag/Void Word */- } hp;-} StgProfHeader;--/* ------------------------------------------------------------------------------ The SMP header-- A thunk has a padding word to take the updated value. This is so- that the update doesn't overwrite the payload, so we can avoid- needing to lock the thunk during entry and update.-- Note: this doesn't apply to THUNK_STATICs, which have no payload.-- Note: we leave this padding word in all ways, rather than just SMP,- so that we don't have to recompile all our libraries for SMP.- -------------------------------------------------------------------------- */--typedef struct {- StgWord pad;-} StgSMPThunkHeader;--/* ------------------------------------------------------------------------------ The full fixed-size closure header-- The size of the fixed header is the sum of the optional parts plus a single- word for the entry code pointer.- -------------------------------------------------------------------------- */--typedef struct {- const StgInfoTable* info;-#if defined(PROFILING)- StgProfHeader prof;-#endif-} StgHeader;--typedef struct {- const StgInfoTable* info;-#if defined(PROFILING)- StgProfHeader prof;-#endif- StgSMPThunkHeader smp;-} StgThunkHeader;--#define THUNK_EXTRA_HEADER_W (sizeofW(StgThunkHeader)-sizeofW(StgHeader))--/* ------------------------------------------------------------------------------ Closure Types-- For any given closure type (defined in InfoTables.h), there is a- corresponding structure defined below. The name of the structure- is obtained by concatenating the closure type with '_closure'- -------------------------------------------------------------------------- */--/* All closures follow the generic format */--typedef struct StgClosure_ {- StgHeader header;- struct StgClosure_ *payload[];-} *StgClosurePtr; // StgClosure defined in rts/Types.h--typedef struct {- StgThunkHeader header;- struct StgClosure_ *payload[];-} StgThunk;--typedef struct {- StgThunkHeader header;- StgClosure *selectee;-} StgSelector;--typedef struct {- StgHeader header;- StgHalfWord arity; /* zero if it is an AP */- StgHalfWord n_args;- StgClosure *fun; /* really points to a fun */- StgClosure *payload[];-} StgPAP;--typedef struct {- StgThunkHeader header;- StgHalfWord arity; /* zero if it is an AP */- StgHalfWord n_args;- StgClosure *fun; /* really points to a fun */- StgClosure *payload[];-} StgAP;--typedef struct {- StgThunkHeader header;- StgWord size; /* number of words in payload */- StgClosure *fun;- StgClosure *payload[]; /* contains a chunk of *stack* */-} StgAP_STACK;--typedef struct {- StgHeader header;- StgClosure *indirectee;-} StgInd;--typedef struct {- StgHeader header;- StgClosure *indirectee;- StgClosure *static_link; // See Note [CAF lists]- const StgInfoTable *saved_info;- // `saved_info` also used for the link field for `debug_caf_list`,- // see `newCAF` and Note [CAF lists] in rts/sm/Storage.h.-} StgIndStatic;--typedef struct StgBlockingQueue_ {- StgHeader header;- struct StgBlockingQueue_ *link;- // here so it looks like an IND, to be able to skip the queue without- // deleting it (done in wakeBlockingQueue())- StgClosure *bh; // the BLACKHOLE- StgTSO *owner;- struct MessageBlackHole_ *queue;- // holds TSOs blocked on `bh`-} StgBlockingQueue;--typedef struct {- StgHeader header;- StgWord bytes;- StgWord payload[];-} StgArrBytes;--typedef struct {- StgHeader header;- StgWord ptrs;- StgWord size; // ptrs plus card table- StgClosure *payload[];- // see also: StgMutArrPtrs macros in ClosureMacros.h-} StgMutArrPtrs;--typedef struct {- StgHeader header;- StgWord ptrs;- StgClosure *payload[];-} StgSmallMutArrPtrs;--typedef struct {- StgHeader header;- StgClosure *var;-} StgMutVar;--typedef struct _StgUpdateFrame {- StgHeader header;- StgClosure *updatee;-} StgUpdateFrame;--typedef struct {- StgHeader header;- StgWord exceptions_blocked;- StgClosure *handler;-} StgCatchFrame;--typedef struct {- const StgInfoTable* info;- struct StgStack_ *next_chunk;-} StgUnderflowFrame;--typedef struct {- StgHeader header;-} StgStopFrame;--typedef struct {- StgHeader header;- StgWord data;-} StgIntCharlikeClosure;--/* statically allocated */-typedef struct {- StgHeader header;-} StgRetry;--typedef struct _StgStableName {- StgHeader header;- StgWord sn;-} StgStableName;--typedef struct _StgWeak { /* Weak v */- StgHeader header;- StgClosure *cfinalizers;- StgClosure *key;- StgClosure *value; /* v */- StgClosure *finalizer;- struct _StgWeak *link;-} StgWeak;--typedef struct _StgCFinalizerList {- StgHeader header;- StgClosure *link;- void (*fptr)(void);- void *ptr;- void *eptr;- StgWord flag; /* has environment (0 or 1) */-} StgCFinalizerList;--/* Byte code objects. These are fixed size objects with pointers to- * four arrays, designed so that a BCO can be easily "re-linked" to- * other BCOs, to facilitate GHC's intelligent recompilation. The- * array of instructions is static and not re-generated when the BCO- * is re-linked, but the other 3 arrays will be regenerated.- *- * A BCO represents either a function or a stack frame. In each case,- * it needs a bitmap to describe to the garbage collector the- * pointerhood of its arguments/free variables respectively, and in- * the case of a function it also needs an arity. These are stored- * directly in the BCO, rather than in the instrs array, for two- * reasons:- * (a) speed: we need to get at the bitmap info quickly when- * the GC is examining APs and PAPs that point to this BCO- * (b) a subtle interaction with the compacting GC. In compacting- * GC, the info that describes the size/layout of a closure- * cannot be in an object more than one level of indirection- * away from the current object, because of the order in- * which pointers are updated to point to their new locations.- */--typedef struct {- StgHeader header;- StgArrBytes *instrs; /* a pointer to an ArrWords */- StgArrBytes *literals; /* a pointer to an ArrWords */- StgMutArrPtrs *ptrs; /* a pointer to a MutArrPtrs */- StgHalfWord arity; /* arity of this BCO */- StgHalfWord size; /* size of this BCO (in words) */- StgWord bitmap[]; /* an StgLargeBitmap */-} StgBCO;--#define BCO_BITMAP(bco) ((StgLargeBitmap *)((StgBCO *)(bco))->bitmap)-#define BCO_BITMAP_SIZE(bco) (BCO_BITMAP(bco)->size)-#define BCO_BITMAP_BITS(bco) (BCO_BITMAP(bco)->bitmap)-#define BCO_BITMAP_SIZEW(bco) ((BCO_BITMAP_SIZE(bco) + BITS_IN(StgWord) - 1) \- / BITS_IN(StgWord))--/* A function return stack frame: used when saving the state for a- * garbage collection at a function entry point. The function- * arguments are on the stack, and we also save the function (its- * info table describes the pointerhood of the arguments).- *- * The stack frame size is also cached in the frame for convenience.- *- * The only RET_FUN is stg_gc_fun, which is created by __stg_gc_fun,- * both in HeapStackCheck.cmm.- */-typedef struct {- const StgInfoTable* info;- StgWord size;- StgClosure * fun;- StgClosure * payload[];-} StgRetFun;--/* Concurrent communication objects */--typedef struct StgMVarTSOQueue_ {- StgHeader header;- struct StgMVarTSOQueue_ *link;- struct StgTSO_ *tso;-} StgMVarTSOQueue;--typedef struct {- StgHeader header;- struct StgMVarTSOQueue_ *head;- struct StgMVarTSOQueue_ *tail;- StgClosure* value;-} StgMVar;---/* STM data structures- *- * StgTVar defines the only type that can be updated through the STM- * interface.- *- * Note that various optimisations may be possible in order to use less- * space for these data structures at the cost of more complexity in the- * implementation:- *- * - In StgTVar, current_value and first_watch_queue_entry could be held in- * the same field: if any thread is waiting then its expected_value for- * the tvar is the current value.- *- * - In StgTRecHeader, it might be worthwhile having separate chunks- * of read-only and read-write locations. This would save a- * new_value field in the read-only locations.- *- * - In StgAtomicallyFrame, we could combine the waiting bit into- * the header (maybe a different info tbl for a waiting transaction).- * This means we can specialise the code for the atomically frame- * (it immediately switches on frame->waiting anyway).- */--typedef struct StgTRecHeader_ StgTRecHeader;--typedef struct StgTVarWatchQueue_ {- StgHeader header;- StgClosure *closure; // StgTSO- struct StgTVarWatchQueue_ *next_queue_entry;- struct StgTVarWatchQueue_ *prev_queue_entry;-} StgTVarWatchQueue;--typedef struct {- StgHeader header;- StgClosure *volatile current_value;- StgTVarWatchQueue *volatile first_watch_queue_entry;- StgInt volatile num_updates;-} StgTVar;--/* new_value == expected_value for read-only accesses */-/* new_value is a StgTVarWatchQueue entry when trec in state TREC_WAITING */-typedef struct {- StgTVar *tvar;- StgClosure *expected_value;- StgClosure *new_value;-#if defined(THREADED_RTS)- StgInt num_updates;-#endif-} TRecEntry;--#define TREC_CHUNK_NUM_ENTRIES 16--typedef struct StgTRecChunk_ {- StgHeader header;- struct StgTRecChunk_ *prev_chunk;- StgWord next_entry_idx;- TRecEntry entries[TREC_CHUNK_NUM_ENTRIES];-} StgTRecChunk;--typedef enum {- TREC_ACTIVE, /* Transaction in progress, outcome undecided */- TREC_CONDEMNED, /* Transaction in progress, inconsistent / out of date reads */- TREC_COMMITTED, /* Transaction has committed, now updating tvars */- TREC_ABORTED, /* Transaction has aborted, now reverting tvars */- TREC_WAITING, /* Transaction currently waiting */-} TRecState;--struct StgTRecHeader_ {- StgHeader header;- struct StgTRecHeader_ *enclosing_trec;- StgTRecChunk *current_chunk;- TRecState state;-};--typedef struct {- StgHeader header;- StgClosure *code;- StgClosure *result;-} StgAtomicallyFrame;--typedef struct {- StgHeader header;- StgClosure *code;- StgClosure *handler;-} StgCatchSTMFrame;--typedef struct {- StgHeader header;- StgWord running_alt_code;- StgClosure *first_code;- StgClosure *alt_code;-} StgCatchRetryFrame;--/* ----------------------------------------------------------------------------- Messages- ------------------------------------------------------------------------- */--typedef struct Message_ {- StgHeader header;- struct Message_ *link;-} Message;--typedef struct MessageWakeup_ {- StgHeader header;- Message *link;- StgTSO *tso;-} MessageWakeup;--typedef struct MessageThrowTo_ {- StgHeader header;- struct MessageThrowTo_ *link;- StgTSO *source;- StgTSO *target;- StgClosure *exception;-} MessageThrowTo;--typedef struct MessageBlackHole_ {- StgHeader header;- struct MessageBlackHole_ *link;- // here so it looks like an IND, to be able to skip the message without- // deleting it (done in throwToMsg())- StgTSO *tso;- StgClosure *bh;-} MessageBlackHole;--/* ----------------------------------------------------------------------------- Compact Regions- ------------------------------------------------------------------------- */--//-// A compact region is a list of blocks. Each block starts with an-// StgCompactNFDataBlock structure, and the list is chained through the next-// field of these structs. (the link field of the bdescr is used to chain-// together multiple compact region on the compact_objects field of a-// generation).-//-// See Note [Compact Normal Forms] for details-//-typedef struct StgCompactNFDataBlock_ {- struct StgCompactNFDataBlock_ *self;- // the address of this block this is copied over to the- // receiving end when serializing a compact, so the receiving- // end can allocate the block at best as it can, and then- // verify if pointer adjustment is needed or not by comparing- // self with the actual address; the same data is sent over as- // SerializedCompact metadata, but having it here simplifies- // the fixup implementation.- struct StgCompactNFData_ *owner;- // the closure who owns this block (used in objectGetCompact)- struct StgCompactNFDataBlock_ *next;- // chain of blocks used for serialization and freeing-} StgCompactNFDataBlock;--//-// This is the Compact# primitive object.-//-typedef struct StgCompactNFData_ {- StgHeader header;- // for sanity and other checks in practice, nothing should ever- // need the compact info pointer (we don't even need fwding- // pointers because it's a large object)- StgWord totalW;- // Total number of words in all blocks in the compact- StgWord autoBlockW;- // size of automatically appended blocks- StgPtr hp, hpLim;- // the beginning and end of the free area in the nursery block. This is- // just a convenience so that we can avoid multiple indirections through- // the nursery pointer below during compaction.- StgCompactNFDataBlock *nursery;- // where to (try to) allocate from when appending- StgCompactNFDataBlock *last;- // the last block of the chain (to know where to append new- // blocks for resize)- struct hashtable *hash;- // the hash table for the current compaction, or NULL if- // there's no (sharing-preserved) compaction in progress.- StgClosure *result;- // Used temporarily to store the result of compaction. Doesn't need to be- // a GC root.-} StgCompactNFData;
− includes/rts/storage/FunTypes.h
@@ -1,54 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 2002- *- * Things for functions.- *- * ---------------------------------------------------------------------------*/--#pragma once--/* generic - function comes with a small bitmap */-#define ARG_GEN 0 --/* generic - function comes with a large bitmap */-#define ARG_GEN_BIG 1--/* BCO - function is really a BCO */-#define ARG_BCO 2--/*- * Specialised function types: bitmaps and calling sequences- * for these functions are pre-generated: see ghc/utils/genapply and- * generated code in ghc/rts/AutoApply.cmm.- *- * NOTE: other places to change if you change this table:- * - utils/genapply/Main.hs: stackApplyTypes- * - compiler/codeGen/StgCmmLayout.hs: stdPattern- */-#define ARG_NONE 3 -#define ARG_N 4 -#define ARG_P 5 -#define ARG_F 6 -#define ARG_D 7 -#define ARG_L 8 -#define ARG_V16 9 -#define ARG_V32 10-#define ARG_V64 11-#define ARG_NN 12 -#define ARG_NP 13-#define ARG_PN 14-#define ARG_PP 15-#define ARG_NNN 16-#define ARG_NNP 17-#define ARG_NPN 18-#define ARG_NPP 19-#define ARG_PNN 20-#define ARG_PNP 21-#define ARG_PPN 22-#define ARG_PPP 23-#define ARG_PPPP 24-#define ARG_PPPPP 25-#define ARG_PPPPPP 26-#define ARG_PPPPPPP 27-#define ARG_PPPPPPPP 28
− includes/rts/storage/GC.h
@@ -1,248 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 1998-2004- *- * External Storage Manger Interface- *- * ---------------------------------------------------------------------------*/--#pragma once--#include <stddef.h>-#include "rts/OSThreads.h"--/* ------------------------------------------------------------------------------ * Generational GC- *- * We support an arbitrary number of generations. Notes (in no particular- * order):- *- * - Objects "age" in the nursery for one GC cycle before being promoted- * to the next generation. There is no aging in other generations.- *- * - generation 0 is the allocation area. It is given- * a fixed set of blocks during initialisation, and these blocks- * normally stay in G0S0. In parallel execution, each- * Capability has its own nursery.- *- * - during garbage collection, each generation which is an- * evacuation destination (i.e. all generations except G0) is- * allocated a to-space. evacuated objects are allocated into- * the generation's to-space until GC is finished, when the- * original generations's contents may be freed and replaced- * by the to-space.- *- * - the mutable-list is per-generation. G0 doesn't have one- * (since every garbage collection collects at least G0).- *- * - block descriptors contain a pointer to the generation that- * the block belongs to, for convenience.- *- * - static objects are stored in per-generation lists. See GC.c for- * details of how we collect CAFs in the generational scheme.- *- * - large objects are per-generation, and are promoted in the- * same way as small objects.- *- * ------------------------------------------------------------------------- */--// A count of blocks needs to store anything up to the size of memory-// divided by the block size. The safest thing is therefore to use a-// type that can store the full range of memory addresses,-// ie. StgWord. Note that we have had some tricky int overflows in a-// couple of cases caused by using ints rather than longs (e.g. #5086)--typedef StgWord memcount;--typedef struct nursery_ {- bdescr * blocks;- memcount n_blocks;-} nursery;--// Nursery invariants:-//-// - cap->r.rNursery points to the nursery for this capability-//-// - cap->r.rCurrentNursery points to the block in the nursery that we are-// currently allocating into. While in Haskell the current heap pointer is-// in Hp, outside Haskell it is stored in cap->r.rCurrentNursery->free.-//-// - the blocks *after* cap->rCurrentNursery in the chain are empty-// (although their bd->free pointers have not been updated to-// reflect that)-//-// - the blocks *before* cap->rCurrentNursery have been used. Except-// for rCurrentAlloc.-//-// - cap->r.rCurrentAlloc is either NULL, or it points to a block in-// the nursery *before* cap->r.rCurrentNursery.-//-// See also Note [allocation accounting] to understand how total-// memory allocation is tracked.--typedef struct generation_ {- uint32_t no; // generation number-- bdescr * blocks; // blocks in this gen- memcount n_blocks; // number of blocks- memcount n_words; // number of used words-- bdescr * large_objects; // large objects (doubly linked)- memcount n_large_blocks; // no. of blocks used by large objs- memcount n_large_words; // no. of words used by large objs- memcount n_new_large_words; // words of new large objects- // (for doYouWantToGC())-- bdescr * compact_objects; // compact objects chain- // the second block in each compact is- // linked from the closure object, while- // the second compact object in the- // chain is linked from bd->link (like- // large objects)- memcount n_compact_blocks; // no. of blocks used by all compacts- bdescr * compact_blocks_in_import; // compact objects being imported- // (not known to the GC because- // potentially invalid, but we- // need to keep track of them- // to avoid assertions in Sanity)- // this is a list shaped like compact_objects- memcount n_compact_blocks_in_import; // no. of blocks used by compacts- // being imported-- // Max blocks to allocate in this generation before collecting it. Collect- // this generation when- //- // n_blocks + n_large_blocks + n_compact_blocks > max_blocks- //- memcount max_blocks;-- StgTSO * threads; // threads in this gen- // linked via global_link- StgWeak * weak_ptr_list; // weak pointers in this gen-- struct generation_ *to; // destination gen for live objects-- // stats information- uint32_t collections;- uint32_t par_collections;- uint32_t failed_promotions; // Currently unused-- // ------------------------------------- // Fields below are used during GC only--#if defined(THREADED_RTS)- char pad[128]; // make sure the following is- // on a separate cache line.- SpinLock sync; // lock for large_objects- // and scavenged_large_objects-#endif-- int mark; // mark (not copy)? (old gen only)- int compact; // compact (not sweep)? (old gen only)-- // During GC, if we are collecting this gen, blocks and n_blocks- // are copied into the following two fields. After GC, these blocks- // are freed.- bdescr * old_blocks; // bdescr of first from-space block- memcount n_old_blocks; // number of blocks in from-space- memcount live_estimate; // for sweeping: estimate of live data-- bdescr * scavenged_large_objects; // live large objs after GC (d-link)- memcount n_scavenged_large_blocks; // size (not count) of above-- bdescr * live_compact_objects; // live compact objs after GC (d-link)- memcount n_live_compact_blocks; // size (not count) of above-- bdescr * bitmap; // bitmap for compacting collection-- StgTSO * old_threads;- StgWeak * old_weak_ptr_list;-} generation;--extern generation * generations;-extern generation * g0;-extern generation * oldest_gen;--/* ------------------------------------------------------------------------------ Generic allocation-- StgPtr allocate(Capability *cap, W_ n)- Allocates memory from the nursery in- the current Capability.-- StgPtr allocatePinned(Capability *cap, W_ n)- Allocates a chunk of contiguous store- n words long, which is at a fixed- address (won't be moved by GC).- Returns a pointer to the first word.- Always succeeds.-- NOTE: the GC can't in general handle- pinned objects, so allocatePinned()- can only be used for ByteArrays at the- moment.-- Don't forget to TICK_ALLOC_XXX(...)- after calling allocate or- allocatePinned, for the- benefit of the ticky-ticky profiler.-- -------------------------------------------------------------------------- */--StgPtr allocate ( Capability *cap, W_ n );-StgPtr allocateMightFail ( Capability *cap, W_ n );-StgPtr allocatePinned ( Capability *cap, W_ n );--/* memory allocator for executable memory */-typedef void* AdjustorWritable;-typedef void* AdjustorExecutable;--AdjustorWritable allocateExec(W_ len, AdjustorExecutable *exec_addr);-void flushExec(W_ len, AdjustorExecutable exec_addr);-#if defined(ios_HOST_OS)-AdjustorWritable execToWritable(AdjustorExecutable exec);-#endif-void freeExec (AdjustorExecutable p);--// Used by GC checks in external .cmm code:-extern W_ large_alloc_lim;--/* ------------------------------------------------------------------------------ Performing Garbage Collection- -------------------------------------------------------------------------- */--void performGC(void);-void performMajorGC(void);--/* ------------------------------------------------------------------------------ The CAF table - used to let us revert CAFs in GHCi- -------------------------------------------------------------------------- */--StgInd *newCAF (StgRegTable *reg, StgIndStatic *caf);-StgInd *newRetainedCAF (StgRegTable *reg, StgIndStatic *caf);-StgInd *newGCdCAF (StgRegTable *reg, StgIndStatic *caf);-void revertCAFs (void);--// Request that all CAFs are retained indefinitely.-// (preferably use RtsConfig.keep_cafs instead)-void setKeepCAFs (void);--/* ------------------------------------------------------------------------------ This is the write barrier for MUT_VARs, a.k.a. IORefs. A- MUT_VAR_CLEAN object is not on the mutable list; a MUT_VAR_DIRTY- is. When written to, a MUT_VAR_CLEAN turns into a MUT_VAR_DIRTY- and is put on the mutable list.- -------------------------------------------------------------------------- */--void dirty_MUT_VAR(StgRegTable *reg, StgClosure *p);--/* set to disable CAF garbage collection in GHCi. */-/* (needed when dynamic libraries are used). */-extern bool keepCAFs;--INLINE_HEADER void initBdescr(bdescr *bd, generation *gen, generation *dest)-{- bd->gen = gen;- bd->gen_no = gen->no;- bd->dest_no = dest->no;-}
− includes/rts/storage/Heap.h
@@ -1,18 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The University of Glasgow 2006-2017- *- * Introspection into GHC's heap representation- *- * ---------------------------------------------------------------------------*/--#pragma once--#include "rts/storage/Closures.h"--StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure);--void heap_view_closure_ptrs_in_pap_payload(StgClosure *ptrs[], StgWord *nptrs- , StgClosure *fun, StgClosure **payload, StgWord size);--StgWord heap_view_closureSize(StgClosure *closure);
− includes/rts/storage/InfoTables.h
@@ -1,405 +0,0 @@-/* ----------------------------------------------------------------------------- *- * (c) The GHC Team, 1998-2002- *- * Info Tables- *- * -------------------------------------------------------------------------- */--#pragma once--/* ----------------------------------------------------------------------------- Relative pointers-- Several pointer fields in info tables are expressed as offsets- relative to the info pointer, so that we can generate- position-independent code.-- Note [x86-64-relative]- There is a complication on the x86_64 platform, where pointers are- 64 bits, but the tools don't support 64-bit relative relocations.- However, the default memory model (small) ensures that all symbols- have values in the lower 2Gb of the address space, so offsets all- fit in 32 bits. Hence we can use 32-bit offset fields.-- Somewhere between binutils-2.16.1 and binutils-2.16.91.0.6,- support for 64-bit PC-relative relocations was added, so maybe this- hackery can go away sometime.- ------------------------------------------------------------------------- */--#if defined(x86_64_TARGET_ARCH)-#define OFFSET_FIELD(n) StgHalfInt n; StgHalfWord __pad_##n-#else-#define OFFSET_FIELD(n) StgInt n-#endif--/* ------------------------------------------------------------------------------ Profiling info- -------------------------------------------------------------------------- */--typedef struct {-#if !defined(TABLES_NEXT_TO_CODE)- char *closure_type;- char *closure_desc;-#else- OFFSET_FIELD(closure_type_off);- OFFSET_FIELD(closure_desc_off);-#endif-} StgProfInfo;--/* ------------------------------------------------------------------------------ Closure flags- -------------------------------------------------------------------------- */--/* The type flags provide quick access to certain properties of a closure. */--#define _HNF (1<<0) /* head normal form? */-#define _BTM (1<<1) /* uses info->layout.bitmap */-#define _NS (1<<2) /* non-sparkable */-#define _THU (1<<3) /* thunk? */-#define _MUT (1<<4) /* mutable? */-#define _UPT (1<<5) /* unpointed? */-#define _SRT (1<<6) /* has an SRT? */-#define _IND (1<<7) /* is an indirection? */--#define isMUTABLE(flags) ((flags) &_MUT)-#define isBITMAP(flags) ((flags) &_BTM)-#define isTHUNK(flags) ((flags) &_THU)-#define isUNPOINTED(flags) ((flags) &_UPT)-#define hasSRT(flags) ((flags) &_SRT)--extern StgWord16 closure_flags[];--#define closureFlags(c) (closure_flags[get_itbl \- (UNTAG_CONST_CLOSURE(c))->type])--#define closure_HNF(c) ( closureFlags(c) & _HNF)-#define closure_BITMAP(c) ( closureFlags(c) & _BTM)-#define closure_NON_SPARK(c) ( (closureFlags(c) & _NS))-#define closure_SHOULD_SPARK(c) (!(closureFlags(c) & _NS))-#define closure_THUNK(c) ( closureFlags(c) & _THU)-#define closure_MUTABLE(c) ( closureFlags(c) & _MUT)-#define closure_UNPOINTED(c) ( closureFlags(c) & _UPT)-#define closure_SRT(c) ( closureFlags(c) & _SRT)-#define closure_IND(c) ( closureFlags(c) & _IND)--/* same as above but for info-ptr rather than closure */-#define ipFlags(ip) (closure_flags[ip->type])--#define ip_HNF(ip) ( ipFlags(ip) & _HNF)-#define ip_BITMAP(ip) ( ipFlags(ip) & _BTM)-#define ip_SHOULD_SPARK(ip) (!(ipFlags(ip) & _NS))-#define ip_THUNK(ip) ( ipFlags(ip) & _THU)-#define ip_MUTABLE(ip) ( ipFlags(ip) & _MUT)-#define ip_UNPOINTED(ip) ( ipFlags(ip) & _UPT)-#define ip_SRT(ip) ( ipFlags(ip) & _SRT)-#define ip_IND(ip) ( ipFlags(ip) & _IND)--/* ------------------------------------------------------------------------------ Bitmaps-- These are used to describe the pointerhood of a sequence of words- (usually on the stack) to the garbage collector. The two primary- uses are for stack frames, and functions (where we need to describe- the layout of a PAP to the GC).-- In these bitmaps: 0 == ptr, 1 == non-ptr.- -------------------------------------------------------------------------- */--/*- * Small bitmaps: for a small bitmap, we store the size and bitmap in- * the same word, using the following macros. If the bitmap doesn't- * fit in a single word, we use a pointer to an StgLargeBitmap below.- */-#define MK_SMALL_BITMAP(size,bits) (((bits)<<BITMAP_BITS_SHIFT) | (size))--#define BITMAP_SIZE(bitmap) ((bitmap) & BITMAP_SIZE_MASK)-#define BITMAP_BITS(bitmap) ((bitmap) >> BITMAP_BITS_SHIFT)--/*- * A large bitmap.- */-typedef struct {- StgWord size;- StgWord bitmap[];-} StgLargeBitmap;--/* ----------------------------------------------------------------------------- Info Tables- ------------------------------------------------------------------------- */--/*- * Stuff describing the closure layout. Well, actually, it might- * contain the selector index for a THUNK_SELECTOR. This union is one- * word long.- */-typedef union {- struct { /* Heap closure payload layout: */- StgHalfWord ptrs; /* number of pointers */- StgHalfWord nptrs; /* number of non-pointers */- } payload;-- StgWord bitmap; /* word-sized bit pattern describing */- /* a stack frame: see below */--#if !defined(TABLES_NEXT_TO_CODE)- StgLargeBitmap* large_bitmap; /* pointer to large bitmap structure */-#else- OFFSET_FIELD(large_bitmap_offset); /* offset from info table to large bitmap structure */-#endif-- StgWord selector_offset; /* used in THUNK_SELECTORs */--} StgClosureInfo;---#if defined(x86_64_TARGET_ARCH) && defined(TABLES_NEXT_TO_CODE)-// On x86_64 we can fit a pointer offset in half a word, so put the SRT offset-// in the info->srt field directly.-//-// See the section "Referring to an SRT from the info table" in-// Note [SRTs] in CmmBuildInfoTables.hs-#define USE_INLINE_SRT_FIELD-#endif--#if defined(USE_INLINE_SRT_FIELD)-// offset to the SRT / closure, or zero if there's no SRT-typedef StgHalfInt StgSRTField;-#else-// non-zero if there is an SRT, the offset is in the optional srt field.-typedef StgHalfWord StgSRTField;-#endif---/*- * The "standard" part of an info table. Every info table has this bit.- */-typedef struct StgInfoTable_ {--#if !defined(TABLES_NEXT_TO_CODE)- StgFunPtr entry; /* pointer to the entry code */-#endif--#if defined(PROFILING)- StgProfInfo prof;-#endif-- StgClosureInfo layout; /* closure layout info (one word) */-- StgHalfWord type; /* closure type */- StgSRTField srt;- /* In a CONSTR:- - the zero-based constructor tag- In a FUN/THUNK- - if USE_INLINE_SRT_FIELD- - offset to the SRT (or zero if no SRT)- - otherwise- - non-zero if there is an SRT, offset is in srt_offset- */--#if defined(TABLES_NEXT_TO_CODE)- StgCode code[];-#endif-} *StgInfoTablePtr; // StgInfoTable defined in rts/Types.h---/* ------------------------------------------------------------------------------ Function info tables-- This is the general form of function info tables. The compiler- will omit some of the fields in common cases:-- - If fun_type is not ARG_GEN or ARG_GEN_BIG, then the slow_apply- and bitmap fields may be left out (they are at the end, so omitting- them doesn't affect the layout).-- - If has_srt (in the std info table part) is zero, then the srt- field needn't be set. This only applies if the slow_apply and- bitmap fields have also been omitted.- -------------------------------------------------------------------------- */--/*- Note [Encoding static reference tables]- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-- As static reference tables appear frequently in code, we use a special- compact encoding for the common case of a module defining only a few CAFs: We- produce one table containing a list of CAFs in the module and then include a- bitmap in each info table describing which entries of this table the closure- references.- */--typedef struct StgFunInfoExtraRev_ {- OFFSET_FIELD(slow_apply_offset); /* apply to args on the stack */- union {- StgWord bitmap;- OFFSET_FIELD(bitmap_offset); /* arg ptr/nonptr bitmap */- } b;-#if !defined(USE_INLINE_SRT_FIELD)- OFFSET_FIELD(srt_offset); /* pointer to the SRT closure */-#endif- StgHalfWord fun_type; /* function type */- StgHalfWord arity; /* function arity */-} StgFunInfoExtraRev;--typedef struct StgFunInfoExtraFwd_ {- StgHalfWord fun_type; /* function type */- StgHalfWord arity; /* function arity */- StgClosure *srt; /* pointer to the SRT closure */- union { /* union for compat. with TABLES_NEXT_TO_CODE version */- StgWord bitmap; /* arg ptr/nonptr bitmap */- } b;- StgFun *slow_apply; /* apply to args on the stack */-} StgFunInfoExtraFwd;--typedef struct {-#if defined(TABLES_NEXT_TO_CODE)- StgFunInfoExtraRev f;- StgInfoTable i;-#else- StgInfoTable i;- StgFunInfoExtraFwd f;-#endif-} StgFunInfoTable;--// canned bitmap for each arg type, indexed by constants in FunTypes.h-extern const StgWord stg_arg_bitmaps[];--/* ------------------------------------------------------------------------------ Return info tables- -------------------------------------------------------------------------- */--/*- * When info tables are laid out backwards, we can omit the SRT- * pointer iff has_srt is zero.- */--typedef struct {-#if defined(TABLES_NEXT_TO_CODE)-#if !defined(USE_INLINE_SRT_FIELD)- OFFSET_FIELD(srt_offset); /* offset to the SRT closure */-#endif- StgInfoTable i;-#else- StgInfoTable i;- StgClosure *srt; /* pointer to the SRT closure */-#endif-} StgRetInfoTable;--/* ------------------------------------------------------------------------------ Thunk info tables- -------------------------------------------------------------------------- */--/*- * When info tables are laid out backwards, we can omit the SRT- * pointer iff has_srt is zero.- */--typedef struct StgThunkInfoTable_ {-#if defined(TABLES_NEXT_TO_CODE)-#if !defined(USE_INLINE_SRT_FIELD)- OFFSET_FIELD(srt_offset); /* offset to the SRT closure */-#endif- StgInfoTable i;-#else- StgInfoTable i;- StgClosure *srt; /* pointer to the SRT closure */-#endif-} StgThunkInfoTable;--/* ------------------------------------------------------------------------------ Constructor info tables- -------------------------------------------------------------------------- */--typedef struct StgConInfoTable_ {-#if !defined(TABLES_NEXT_TO_CODE)- StgInfoTable i;-#endif--#if defined(TABLES_NEXT_TO_CODE)- OFFSET_FIELD(con_desc); // the name of the data constructor- // as: Package:Module.Name-#else- char *con_desc;-#endif--#if defined(TABLES_NEXT_TO_CODE)- StgInfoTable i;-#endif-} StgConInfoTable;---/* ------------------------------------------------------------------------------ Accessor macros for fields that might be offsets (C version)- -------------------------------------------------------------------------- */--/*- * GET_SRT(info)- * info must be a Stg[Ret|Thunk]InfoTable* (an info table that has a SRT)- */-#if defined(TABLES_NEXT_TO_CODE)-#if defined(x86_64_TARGET_ARCH)-#define GET_SRT(info) \- ((StgClosure*) (((StgWord) ((info)+1)) + (info)->i.srt))-#else-#define GET_SRT(info) \- ((StgClosure*) (((StgWord) ((info)+1)) + (info)->srt_offset))-#endif-#else // !TABLES_NEXT_TO_CODE-#define GET_SRT(info) ((info)->srt)-#endif--/*- * GET_CON_DESC(info)- * info must be a StgConInfoTable*.- */-#if defined(TABLES_NEXT_TO_CODE)-#define GET_CON_DESC(info) \- ((const char *)((StgWord)((info)+1) + (info->con_desc)))-#else-#define GET_CON_DESC(info) ((const char *)(info)->con_desc)-#endif--/*- * GET_FUN_SRT(info)- * info must be a StgFunInfoTable*- */-#if defined(TABLES_NEXT_TO_CODE)-#if defined(x86_64_TARGET_ARCH)-#define GET_FUN_SRT(info) \- ((StgClosure*) (((StgWord) ((info)+1)) + (info)->i.srt))-#else-#define GET_FUN_SRT(info) \- ((StgClosure*) (((StgWord) ((info)+1)) + (info)->f.srt_offset))-#endif-#else-#define GET_FUN_SRT(info) ((info)->f.srt)-#endif--#if defined(TABLES_NEXT_TO_CODE)-#define GET_LARGE_BITMAP(info) ((StgLargeBitmap*) (((StgWord) ((info)+1)) \- + (info)->layout.large_bitmap_offset))-#else-#define GET_LARGE_BITMAP(info) ((info)->layout.large_bitmap)-#endif--#if defined(TABLES_NEXT_TO_CODE)-#define GET_FUN_LARGE_BITMAP(info) ((StgLargeBitmap*) (((StgWord) ((info)+1)) \- + (info)->f.b.bitmap_offset))-#else-#define GET_FUN_LARGE_BITMAP(info) ((StgLargeBitmap*) ((info)->f.b.bitmap))-#endif--/*- * GET_PROF_TYPE, GET_PROF_DESC- */-#if defined(TABLES_NEXT_TO_CODE)-#define GET_PROF_TYPE(info) ((char *)((StgWord)((info)+1) + (info->prof.closure_type_off)))-#else-#define GET_PROF_TYPE(info) ((info)->prof.closure_type)-#endif-#if defined(TABLES_NEXT_TO_CODE)-#define GET_PROF_DESC(info) ((char *)((StgWord)((info)+1) + (info->prof.closure_desc_off)))-#else-#define GET_PROF_DESC(info) ((info)->prof.closure_desc)-#endif
− includes/rts/storage/MBlock.h
@@ -1,32 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 1998-2008- *- * MegaBlock Allocator interface.- *- * See wiki commentary at- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/heap-alloced- *- * ---------------------------------------------------------------------------*/--#pragma once--extern W_ peak_mblocks_allocated;-extern W_ mblocks_allocated;--extern void initMBlocks(void);-extern void * getMBlock(void);-extern void * getMBlocks(uint32_t n);-extern void * getMBlockOnNode(uint32_t node);-extern void * getMBlocksOnNode(uint32_t node, uint32_t n);-extern void freeMBlocks(void *addr, uint32_t n);-extern void releaseFreeMemory(void);-extern void freeAllMBlocks(void);--extern void *getFirstMBlock(void **state);-extern void *getNextMBlock(void **state, void *mblock);--#if defined(THREADED_RTS)-// needed for HEAP_ALLOCED below-extern SpinLock gc_alloc_block_sync;-#endif
− includes/rts/storage/TSO.h
@@ -1,261 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 1998-2009- *- * The definitions for Thread State Objects.- *- * ---------------------------------------------------------------------------*/--#pragma once--/*- * PROFILING info in a TSO- */-typedef struct {- CostCentreStack *cccs; /* thread's current CCS */-} StgTSOProfInfo;--/*- * There is no TICKY info in a TSO at this time.- */--/*- * Thread IDs are 32 bits.- */-typedef StgWord32 StgThreadID;--#define tsoLocked(tso) ((tso)->flags & TSO_LOCKED)--/*- * Type returned after running a thread. Values of this type- * include HeapOverflow, StackOverflow etc. See Constants.h for the- * full list.- */-typedef unsigned int StgThreadReturnCode;--#if defined(mingw32_HOST_OS)-/* results from an async I/O request + its request ID. */-typedef struct {- unsigned int reqID;- int len;- int errCode;-} StgAsyncIOResult;-#endif--/* Reason for thread being blocked. See comment above struct StgTso_. */-typedef union {- StgClosure *closure;- StgTSO *prev; // a back-link when the TSO is on the run queue (NotBlocked)- struct MessageBlackHole_ *bh;- struct MessageThrowTo_ *throwto;- struct MessageWakeup_ *wakeup;- StgInt fd; /* StgInt instead of int, so that it's the same size as the ptrs */-#if defined(mingw32_HOST_OS)- StgAsyncIOResult *async_result;-#endif-#if !defined(THREADED_RTS)- StgWord target;- // Only for the non-threaded RTS: the target time for a thread- // blocked in threadDelay, in units of 1ms. This is a- // compromise: we don't want to take up much space in the TSO. If- // you want better resolution for threadDelay, use -threaded.-#endif-} StgTSOBlockInfo;---/*- * TSOs live on the heap, and therefore look just like heap objects.- * Large TSOs will live in their own "block group" allocated by the- * storage manager, and won't be copied during garbage collection.- */--/*- * Threads may be blocked for several reasons. A blocked thread will- * have the reason in the why_blocked field of the TSO, and some- * further info (such as the closure the thread is blocked on, or the- * file descriptor if the thread is waiting on I/O) in the block_info- * field.- */--typedef struct StgTSO_ {- StgHeader header;-- /* The link field, for linking threads together in lists (e.g. the- run queue on a Capability.- */- struct StgTSO_* _link;- /*- Currently used for linking TSOs on:- * cap->run_queue_{hd,tl}- * (non-THREADED_RTS); the blocked_queue- * and pointing to the next chunk for a ThreadOldStack-- NOTE!!! do not modify _link directly, it is subject to- a write barrier for generational GC. Instead use the- setTSOLink() function. Exceptions to this rule are:-- * setting the link field to END_TSO_QUEUE- * setting the link field of the currently running TSO, as it- will already be dirty.- */-- struct StgTSO_* global_link; // Links threads on the- // generation->threads lists-- /*- * The thread's stack- */- struct StgStack_ *stackobj;-- /*- * The tso->dirty flag indicates that this TSO's stack should be- * scanned during garbage collection. It also indicates that this- * TSO is on the mutable list.- *- * NB. The dirty flag gets a word to itself, so that it can be set- * safely by multiple threads simultaneously (the flags field is- * not safe for this purpose; see #3429). It is harmless for the- * TSO to be on the mutable list multiple times.- *- * tso->dirty is set by dirty_TSO(), and unset by the garbage- * collector (only).- */-- StgWord16 what_next; // Values defined in Constants.h- StgWord16 why_blocked; // Values defined in Constants.h- StgWord32 flags; // Values defined in Constants.h- StgTSOBlockInfo block_info;- StgThreadID id;- StgWord32 saved_errno;- StgWord32 dirty; /* non-zero => dirty */- struct InCall_* bound;- struct Capability_* cap;-- struct StgTRecHeader_ * trec; /* STM transaction record */-- /*- * A list of threads blocked on this TSO waiting to throw exceptions.- */- struct MessageThrowTo_ * blocked_exceptions;-- /*- * A list of StgBlockingQueue objects, representing threads- * blocked on thunks that are under evaluation by this thread.- */- struct StgBlockingQueue_ *bq;-- /*- * The allocation limit for this thread, which is updated as the- * thread allocates. If the value drops below zero, and- * TSO_ALLOC_LIMIT is set in flags, we raise an exception in the- * thread, and give the thread a little more space to handle the- * exception before we raise the exception again.- *- * This is an integer, because we might update it in a place where- * it isn't convenient to raise the exception, so we want it to- * stay negative until we get around to checking it.- *- * Use only PK_Int64/ASSIGN_Int64 macros to get/set the value of alloc_limit- * in C code otherwise you will cause alignment issues on SPARC- */- StgInt64 alloc_limit; /* in bytes */-- /*- * sum of the sizes of all stack chunks (in words), used to decide- * whether to throw the StackOverflow exception when the stack- * overflows, or whether to just chain on another stack chunk.- *- * Note that this overestimates the real stack size, because each- * chunk will have a gap at the end, of +RTS -kb<size> words.- * This means stack overflows are not entirely accurate, because- * the more gaps there are, the sooner the stack will run into the- * hard +RTS -K<size> limit.- */- StgWord32 tot_stack_size;--#if defined(TICKY_TICKY)- /* TICKY-specific stuff would go here. */-#endif-#if defined(PROFILING)- StgTSOProfInfo prof;-#endif-#if defined(mingw32_HOST_OS)- StgWord32 saved_winerror;-#endif--} *StgTSOPtr; // StgTSO defined in rts/Types.h--typedef struct StgStack_ {- StgHeader header;- StgWord32 stack_size; // stack size in *words*- StgWord32 dirty; // non-zero => dirty- StgPtr sp; // current stack pointer- StgWord stack[];-} StgStack;--// Calculate SpLim from a TSO (reads tso->stackobj, but no fields from-// the stackobj itself).-INLINE_HEADER StgPtr tso_SpLim (StgTSO* tso)-{- return tso->stackobj->stack + RESERVED_STACK_WORDS;-}--/* ------------------------------------------------------------------------------ functions- -------------------------------------------------------------------------- */--void dirty_TSO (Capability *cap, StgTSO *tso);-void setTSOLink (Capability *cap, StgTSO *tso, StgTSO *target);-void setTSOPrev (Capability *cap, StgTSO *tso, StgTSO *target);--void dirty_STACK (Capability *cap, StgStack *stack);--/* ------------------------------------------------------------------------------ Invariants:-- An active thread has the following properties:-- tso->stack < tso->sp < tso->stack+tso->stack_size- tso->stack_size <= tso->max_stack_size-- RESERVED_STACK_WORDS is large enough for any heap-check or- stack-check failure.-- The size of the TSO struct plus the stack is either- (a) smaller than a block, or- (b) a multiple of BLOCK_SIZE-- tso->why_blocked tso->block_info location- ----------------------------------------------------------------------- NotBlocked END_TSO_QUEUE runnable_queue, or running-- BlockedOnBlackHole MessageBlackHole * TSO->bq-- BlockedOnMVar the MVAR the MVAR's queue-- BlockedOnSTM END_TSO_QUEUE STM wait queue(s)- BlockedOnSTM STM_AWOKEN run queue-- BlockedOnMsgThrowTo MessageThrowTo * TSO->blocked_exception-- BlockedOnRead NULL blocked_queue- BlockedOnWrite NULL blocked_queue- BlockedOnDelay NULL blocked_queue-- tso->link == END_TSO_QUEUE, if the thread is currently running.-- A zombie thread has the following properties:-- tso->what_next == ThreadComplete or ThreadKilled- tso->link == (could be on some queue somewhere)- tso->sp == tso->stack + tso->stack_size - 1 (i.e. top stack word)- tso->sp[0] == return value of thread, if what_next == ThreadComplete,- exception , if what_next == ThreadKilled-- (tso->sp is left pointing at the top word on the stack so that- the return value or exception will be retained by a GC).-- ---------------------------------------------------------------------------- */--/* this is the NIL ptr for a TSO queue (e.g. runnable queue) */-#define END_TSO_QUEUE ((StgTSO *)(void*)&stg_END_TSO_QUEUE_closure)
libraries/ghci/GHCi/TH.hs view
@@ -183,6 +183,7 @@ qLookupName isType occ = ghcCmd (LookupName isType occ) qReify name = ghcCmd (Reify name) qReifyFixity name = ghcCmd (ReifyFixity name)+ qReifyType name = ghcCmd (ReifyType name) qReifyInstances name tys = ghcCmd (ReifyInstances name tys) qReifyRoles name = ghcCmd (ReifyRoles name)