ghc 9.8.2 → 9.8.3
raw patch · 76 files changed
+1023/−486 lines, 76 filesdep ~ghc-bootdep ~ghc-heapdep ~ghciPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: ghc-boot, ghc-heap, ghci
API changes (from Hackage documentation)
- GHC.Runtime.Interpreter.Types: [instLookupSymbolCache] :: ExtInterpInstance c -> !MVar (UniqFM FastString (Ptr ()))
- GHC.Tc.Types.Constraint: arisesFromGivens :: Ct -> Bool
+ GHC.CmmToAsm.AArch64.Instr: canFallthroughTo :: Instr -> BlockId -> Bool
+ GHC.CmmToAsm.Instr: canFallthroughTo :: Instruction instr => instr -> BlockId -> Bool
+ GHC.CmmToAsm.PPC.Instr: canFallthroughTo :: Instr -> BlockId -> Bool
+ GHC.CmmToAsm.X86.Instr: canFallthroughTo :: Instr -> BlockId -> Bool
+ GHC.Core.Utils: trivial_expr_fold :: (Id -> r) -> (Literal -> r) -> r -> r -> CoreExpr -> r
+ GHC.Linker.Types: [loaded_pkg_hs_dlls] :: LoadedPkgInfo -> ![RemotePtr LoadedDLL]
+ GHC.Runtime.Interpreter: [LookupSymbolInDLL] :: RemotePtr LoadedDLL -> String -> Message (Maybe (RemotePtr ()))
+ GHC.Runtime.Interpreter: lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> FastString -> IO (Maybe (Ptr ()))
+ GHC.Runtime.Interpreter.Process: [LookupSymbolInDLL] :: RemotePtr LoadedDLL -> String -> Message (Maybe (RemotePtr ()))
+ GHC.Runtime.Interpreter.Types: [interpLookupSymbolCache] :: Interp -> !MVar (UniqFM FastString (Ptr ()))
- GHC.ByteCode.Linker: linkBCO :: Interp -> LinkerEnv -> NameEnv Int -> RemoteRef BreakArray -> UnlinkedBCO -> IO ResolvedBCO
+ GHC.ByteCode.Linker: linkBCO :: Interp -> PkgsLoaded -> LinkerEnv -> NameEnv Int -> RemoteRef BreakArray -> UnlinkedBCO -> IO ResolvedBCO
- GHC.ByteCode.Linker: lookupIE :: Interp -> ItblEnv -> Name -> IO (Ptr ())
+ GHC.ByteCode.Linker: lookupIE :: Interp -> PkgsLoaded -> ItblEnv -> Name -> IO (Ptr ())
- GHC.CmmToAsm.Reg.Linear.AArch64: allocateReg :: HasCallStack => RealReg -> FreeRegs -> FreeRegs
+ GHC.CmmToAsm.Reg.Linear.AArch64: allocateReg :: HasDebugCallStack => RealReg -> FreeRegs -> FreeRegs
- GHC.CmmToAsm.Reg.Linear.AArch64: releaseReg :: HasCallStack => RealReg -> FreeRegs -> FreeRegs
+ GHC.CmmToAsm.Reg.Linear.AArch64: releaseReg :: HasDebugCallStack => RealReg -> FreeRegs -> FreeRegs
- GHC.Core.Opt.Arity: exprEtaExpandArity :: ArityOpts -> CoreExpr -> Maybe SafeArityType
+ GHC.Core.Opt.Arity: exprEtaExpandArity :: HasDebugCallStack => ArityOpts -> CoreExpr -> Maybe SafeArityType
- GHC.Core.Type: tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type])
+ GHC.Core.Type: tcSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])
- GHC.Core.Type: tyConAppArgs :: HasCallStack => Type -> [Type]
+ GHC.Core.Type: tyConAppArgs :: HasDebugCallStack => Type -> [Type]
- GHC.Data.Maybe: expectJust :: HasCallStack => String -> Maybe a -> a
+ GHC.Data.Maybe: expectJust :: HasDebugCallStack => String -> Maybe a -> a
- GHC.Driver.Make: checkHomeUnitsClosed :: UnitEnv -> Set UnitId -> [(UnitId, UnitId)] -> [DriverMessages]
+ GHC.Driver.Make: checkHomeUnitsClosed :: UnitEnv -> [DriverMessages]
- GHC.Linker.Types: LoadedPkgInfo :: !UnitId -> ![LibrarySpec] -> ![LibrarySpec] -> UniqDSet UnitId -> LoadedPkgInfo
+ GHC.Linker.Types: LoadedPkgInfo :: !UnitId -> ![LibrarySpec] -> ![LibrarySpec] -> ![RemotePtr LoadedDLL] -> UniqDSet UnitId -> LoadedPkgInfo
- GHC.Plugins: mkLocalCoVar :: Name -> Type -> CoVar
+ GHC.Plugins: mkLocalCoVar :: HasDebugCallStack => Name -> Type -> CoVar
- GHC.Plugins: mkLocalIdOrCoVar :: Name -> Mult -> Type -> Id
+ GHC.Plugins: mkLocalIdOrCoVar :: HasDebugCallStack => Name -> Mult -> Type -> Id
- GHC.Plugins: mkVanillaGlobal :: Name -> Type -> Id
+ GHC.Plugins: mkVanillaGlobal :: HasDebugCallStack => Name -> Type -> Id
- GHC.Plugins: mkVanillaGlobalWithInfo :: Name -> Type -> IdInfo -> Id
+ GHC.Plugins: mkVanillaGlobalWithInfo :: HasDebugCallStack => Name -> Type -> IdInfo -> Id
- GHC.Plugins: tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type])
+ GHC.Plugins: tcSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])
- GHC.Plugins: tyConAppArgs :: HasCallStack => Type -> [Type]
+ GHC.Plugins: tyConAppArgs :: HasDebugCallStack => Type -> [Type]
- GHC.Runtime.Interpreter: [LoadDLL] :: String -> Message (Maybe String)
+ GHC.Runtime.Interpreter: [LoadDLL] :: String -> Message (Either String (RemotePtr LoadedDLL))
- GHC.Runtime.Interpreter: loadDLL :: Interp -> String -> IO (Maybe String)
+ GHC.Runtime.Interpreter: loadDLL :: Interp -> String -> IO (Either String (RemotePtr LoadedDLL))
- GHC.Runtime.Interpreter.Process: [LoadDLL] :: String -> Message (Maybe String)
+ GHC.Runtime.Interpreter.Process: [LoadDLL] :: String -> Message (Either String (RemotePtr LoadedDLL))
- GHC.Runtime.Interpreter.Types: ExtInterpInstance :: {-# UNPACK #-} !InterpProcess -> !MVar [HValueRef] -> !MVar (UniqFM FastString (Ptr ())) -> !c -> ExtInterpInstance c
+ GHC.Runtime.Interpreter.Types: ExtInterpInstance :: {-# UNPACK #-} !InterpProcess -> !MVar [HValueRef] -> !c -> ExtInterpInstance c
- GHC.Runtime.Interpreter.Types: Interp :: !InterpInstance -> !Loader -> Interp
+ GHC.Runtime.Interpreter.Types: Interp :: !InterpInstance -> !Loader -> !MVar (UniqFM FastString (Ptr ())) -> Interp
- GHC.Stg.Subst: lookupIdSubst :: HasCallStack => Id -> Subst -> Id
+ GHC.Stg.Subst: lookupIdSubst :: HasDebugCallStack => Id -> Subst -> Id
- GHC.Stg.Subst: noWarnLookupIdSubst :: HasCallStack => Id -> Subst -> Id
+ GHC.Stg.Subst: noWarnLookupIdSubst :: HasDebugCallStack => Id -> Subst -> Id
- GHC.Tc.Deriv.Utils: substPredSpec :: HasCallStack => Subst -> PredSpec -> PredSpec
+ GHC.Tc.Deriv.Utils: substPredSpec :: HasDebugCallStack => Subst -> PredSpec -> PredSpec
- GHC.Tc.Types.Origin: unkSkol :: HasCallStack => SkolemInfo
+ GHC.Tc.Types.Origin: unkSkol :: HasDebugCallStack => SkolemInfo
- GHC.Tc.Types.Origin: unkSkolAnon :: HasCallStack => SkolemInfoAnon
+ GHC.Tc.Types.Origin: unkSkolAnon :: HasDebugCallStack => SkolemInfoAnon
- GHC.Tc.Utils.TcType: tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type])
+ GHC.Tc.Utils.TcType: tcSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])
- GHC.Tc.Utils.TcType: vanillaSkolemTvUnk :: HasCallStack => TcTyVarDetails
+ GHC.Tc.Utils.TcType: vanillaSkolemTvUnk :: HasDebugCallStack => TcTyVarDetails
- GHC.Types.Id: mkLocalCoVar :: Name -> Type -> CoVar
+ GHC.Types.Id: mkLocalCoVar :: HasDebugCallStack => Name -> Type -> CoVar
- GHC.Types.Id: mkLocalIdOrCoVar :: Name -> Mult -> Type -> Id
+ GHC.Types.Id: mkLocalIdOrCoVar :: HasDebugCallStack => Name -> Mult -> Type -> Id
- GHC.Types.Id: mkVanillaGlobal :: Name -> Type -> Id
+ GHC.Types.Id: mkVanillaGlobal :: HasDebugCallStack => Name -> Type -> Id
- GHC.Types.Id: mkVanillaGlobalWithInfo :: Name -> Type -> IdInfo -> Id
+ GHC.Types.Id: mkVanillaGlobalWithInfo :: HasDebugCallStack => Name -> Type -> IdInfo -> Id
- GHC.Utils.Misc: expectNonEmpty :: HasCallStack => String -> [a] -> NonEmpty a
+ GHC.Utils.Misc: expectNonEmpty :: HasDebugCallStack => String -> [a] -> NonEmpty a
- GHC.Utils.Misc: expectOnly :: HasCallStack => String -> [a] -> a
+ GHC.Utils.Misc: expectOnly :: HasDebugCallStack => String -> [a] -> a
Files
- GHC.hs +5/−3
- GHC/ByteCode/Instr.hs +1/−1
- GHC/ByteCode/Linker.hs +48/−21
- GHC/Cmm/Lexer.hs +2/−2
- GHC/Cmm/Opt.hs +18/−1
- GHC/CmmToAsm/AArch64.hs +1/−0
- GHC/CmmToAsm/AArch64/CodeGen.hs +1/−1
- GHC/CmmToAsm/AArch64/Instr.hs +10/−0
- GHC/CmmToAsm/AArch64/Ppr.hs +1/−0
- GHC/CmmToAsm/AArch64/Regs.hs +1/−0
- GHC/CmmToAsm/BlockLayout.hs +2/−3
- GHC/CmmToAsm/Instr.hs +7/−1
- GHC/CmmToAsm/Monad.hs +26/−0
- GHC/CmmToAsm/PPC.hs +1/−0
- GHC/CmmToAsm/PPC/CodeGen.hs +1/−1
- GHC/CmmToAsm/PPC/Instr.hs +8/−0
- GHC/CmmToAsm/Reg/Graph/TrivColorable.hs +2/−1
- GHC/CmmToAsm/Reg/Linear/AArch64.hs +3/−3
- GHC/CmmToAsm/Reg/Liveness.hs +5/−0
- GHC/CmmToAsm/X86.hs +1/−0
- GHC/CmmToAsm/X86/CodeGen.hs +44/−13
- GHC/CmmToAsm/X86/Instr.hs +12/−0
- GHC/Core/Opt/Arity.hs +1/−1
- GHC/Core/Opt/DmdAnal.hs +1/−1
- GHC/Core/Opt/Simplify/Iteration.hs +26/−13
- GHC/Core/Rules.hs +46/−29
- GHC/Core/SimpleOpt.hs +5/−3
- GHC/Core/Type.hs +2/−2
- GHC/Core/Utils.hs +37/−31
- GHC/CoreToStg.hs +33/−34
- GHC/Data/Maybe.hs +2/−2
- GHC/Driver/Config/Core/Opt/Simplify.hs +35/−0
- GHC/Driver/Main.hs +1/−1
- GHC/Driver/Make.hs +97/−90
- GHC/Driver/Pipeline/Execute.hs +17/−9
- GHC/Driver/Plugins.hs +6/−6
- GHC/HsToCore/Foreign/C.hs +21/−11
- GHC/Iface/Recomp/Flags.hs +4/−1
- GHC/Iface/Tidy.hs +5/−2
- GHC/Linker/Loader.hs +34/−26
- GHC/Linker/MacOS.hs +2/−2
- GHC/Linker/Types.hs +54/−4
- GHC/Parser/HaddockLex.hs +2/−2
- GHC/Parser/Lexer.hs +2/−2
- GHC/Rename/Module.hs +2/−0
- GHC/Runtime/Eval.hs +4/−2
- GHC/Runtime/Interpreter.hs +58/−22
- GHC/Runtime/Interpreter/JS.hs +0/−3
- GHC/Runtime/Interpreter/Types.hs +3/−3
- GHC/Runtime/Utils.hs +1/−1
- GHC/Settings/IO.hs +29/−7
- GHC/Stg/Subst.hs +2/−2
- GHC/StgToCmm/Prim.hs +2/−2
- GHC/StgToCmm/Ticky.hs +1/−1
- GHC/StgToJS/Apply.hs +0/−18
- GHC/StgToJS/Expr.hs +34/−1
- GHC/StgToJS/Literal.hs +42/−2
- GHC/SysTools/Cpp.hs +11/−5
- GHC/Tc/Deriv/Generate.hs +1/−1
- GHC/Tc/Deriv/Utils.hs +1/−1
- GHC/Tc/Errors.hs +2/−0
- GHC/Tc/Gen/HsType.hs +72/−23
- GHC/Tc/Solver/Monad.hs +12/−1
- GHC/Tc/Types/Constraint.hs +59/−23
- GHC/Tc/Types/Origin.hs +4/−3
- GHC/Tc/Types/Origin.hs-boot +2/−2
- GHC/Tc/Utils/TcType.hs +1/−1
- GHC/Tc/Utils/TcType.hs-boot +2/−2
- GHC/ThToHs.hs +2/−1
- GHC/Types/Id.hs +12/−7
- GHC/Types/Id/Make.hs +14/−16
- GHC/Unit/Types.hs +2/−2
- GHC/Utils/Binary.hs +6/−3
- GHC/Utils/Lexeme.hs +3/−2
- GHC/Utils/Misc.hs +2/−2
- ghc.cabal +4/−4
GHC.hs view
@@ -397,6 +397,7 @@ import GHC.Types.TypeEnv import GHC.Types.BreakInfo import GHC.Types.PkgQual+import GHC.Types.Unique.FM import GHC.Unit import GHC.Unit.Env@@ -676,6 +677,7 @@ setTopSessionDynFlags dflags = do hsc_env <- getSession logger <- getLogger+ lookup_cache <- liftIO $ newMVar emptyUFM -- Interpreter interp <- if@@ -705,7 +707,7 @@ } s <- liftIO $ newMVar InterpPending loader <- liftIO Loader.uninitializedLoader- return (Just (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader))+ return (Just (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache)) -- JavaScript interpreter | ArchJavaScript <- platformArch (targetPlatform dflags)@@ -723,7 +725,7 @@ , jsInterpFinderOpts = initFinderOpts dflags , jsInterpFinderCache = hsc_FC hsc_env }- return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader))+ return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader lookup_cache)) -- Internal interpreter | otherwise@@ -731,7 +733,7 @@ #if defined(HAVE_INTERNAL_INTERPRETER) do loader <- liftIO Loader.uninitializedLoader- return (Just (Interp InternalInterp loader))+ return (Just (Interp InternalInterp loader lookup_cache)) #else return Nothing #endif
GHC/ByteCode/Instr.hs view
@@ -82,7 +82,7 @@ | PUSH16_W !ByteOff | PUSH32_W !ByteOff - -- Push a ptr (these all map to PUSH_G really)+ -- Push a (heap) ptr (these all map to PUSH_G really) | PUSH_G Name | PUSH_PRIMOP PrimOp | PUSH_BCO (ProtoBCO Name)
GHC/ByteCode/Linker.hs view
@@ -25,6 +25,7 @@ import GHCi.BreakArray import GHC.Builtin.PrimOps+import GHC.Builtin.PrimOps.Ids import GHC.Builtin.Names import GHC.Unit.Types@@ -40,6 +41,8 @@ import GHC.Types.Name import GHC.Types.Name.Env+import qualified GHC.Types.Id as Id+import GHC.Types.Unique.DFM import Language.Haskell.Syntax.Module.Name @@ -54,32 +57,33 @@ linkBCO :: Interp+ -> PkgsLoaded -> LinkerEnv -> NameEnv Int -> RemoteRef BreakArray -> UnlinkedBCO -> IO ResolvedBCO-linkBCO interp le bco_ix breakarray+linkBCO interp pkgs_loaded le bco_ix breakarray (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do -- fromIntegral Word -> Word64 should be a no op if Word is Word64 -- otherwise it will result in a cast to longlong on 32bit systems.- lits <- mapM (fmap fromIntegral . lookupLiteral interp le) (ssElts lits0)- ptrs <- mapM (resolvePtr interp le bco_ix breakarray) (ssElts ptrs0)+ lits <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded le) (ssElts lits0)+ ptrs <- mapM (resolvePtr interp pkgs_loaded le bco_ix breakarray) (ssElts ptrs0) return (ResolvedBCO isLittleEndian arity insns bitmap (listArray (0, fromIntegral (sizeSS lits0)-1) lits) (addListToSS emptySS ptrs)) -lookupLiteral :: Interp -> LinkerEnv -> BCONPtr -> IO Word-lookupLiteral interp le ptr = case ptr of+lookupLiteral :: Interp -> PkgsLoaded -> LinkerEnv -> BCONPtr -> IO Word+lookupLiteral interp pkgs_loaded le ptr = case ptr of BCONPtrWord lit -> return lit BCONPtrLbl sym -> do Ptr a# <- lookupStaticPtr interp sym return (W# (int2Word# (addr2Int# a#))) BCONPtrItbl nm -> do- Ptr a# <- lookupIE interp (itbl_env le) nm+ Ptr a# <- lookupIE interp pkgs_loaded (itbl_env le) nm return (W# (int2Word# (addr2Int# a#))) BCONPtrAddr nm -> do- Ptr a# <- lookupAddr interp (addr_env le) nm+ Ptr a# <- lookupAddr interp pkgs_loaded (addr_env le) nm return (W# (int2Word# (addr2Int# a#))) BCONPtrStr _ -> -- should be eliminated during assembleBCOs@@ -93,19 +97,19 @@ Nothing -> linkFail "GHC.ByteCode.Linker: can't find label" (unpackFS addr_of_label_string) -lookupIE :: Interp -> ItblEnv -> Name -> IO (Ptr ())-lookupIE interp ie con_nm =+lookupIE :: Interp -> PkgsLoaded -> ItblEnv -> Name -> IO (Ptr ())+lookupIE interp pkgs_loaded ie con_nm = case lookupNameEnv ie con_nm of Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a)) Nothing -> do -- try looking up in the object files. let sym_to_find1 = nameToCLabel con_nm "con_info"- m <- lookupSymbol interp sym_to_find1+ m <- lookupHsSymbol interp pkgs_loaded con_nm "con_info" case m of Just addr -> return addr Nothing -> do -- perhaps a nullary constructor? let sym_to_find2 = nameToCLabel con_nm "static_info"- n <- lookupSymbol interp sym_to_find2+ n <- lookupHsSymbol interp pkgs_loaded con_nm "static_info" case n of Just addr -> return addr Nothing -> linkFail "GHC.ByteCode.Linker.lookupIE"@@ -113,35 +117,36 @@ unpackFS sym_to_find2) -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode-lookupAddr :: Interp -> AddrEnv -> Name -> IO (Ptr ())-lookupAddr interp ae addr_nm = do+lookupAddr :: Interp -> PkgsLoaded -> AddrEnv -> Name -> IO (Ptr ())+lookupAddr interp pkgs_loaded ae addr_nm = do case lookupNameEnv ae addr_nm of Just (_, AddrPtr ptr) -> return (fromRemotePtr ptr) Nothing -> do -- try looking up in the object files. let sym_to_find = nameToCLabel addr_nm "bytes" -- see Note [Bytes label] in GHC.Cmm.CLabel- m <- lookupSymbol interp sym_to_find+ m <- lookupHsSymbol interp pkgs_loaded addr_nm "bytes" case m of Just ptr -> return ptr Nothing -> linkFail "GHC.ByteCode.Linker.lookupAddr" (unpackFS sym_to_find) -lookupPrimOp :: Interp -> PrimOp -> IO (RemotePtr ())-lookupPrimOp interp primop = do+lookupPrimOp :: Interp -> PkgsLoaded -> PrimOp -> IO (RemotePtr ())+lookupPrimOp interp pkgs_loaded primop = do let sym_to_find = primopToCLabel primop "closure"- m <- lookupSymbol interp (mkFastString sym_to_find)+ m <- lookupHsSymbol interp pkgs_loaded (Id.idName $ primOpId primop) "closure" case m of Just p -> return (toRemotePtr p) Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" sym_to_find resolvePtr :: Interp+ -> PkgsLoaded -> LinkerEnv -> NameEnv Int -> RemoteRef BreakArray -> BCOPtr -> IO ResolvedBCOPtr-resolvePtr interp le bco_ix breakarray ptr = case ptr of+resolvePtr interp pkgs_loaded le bco_ix breakarray ptr = case ptr of BCOPtrName nm | Just ix <- lookupNameEnv bco_ix nm -> return (ResolvedBCORef ix) -- ref to another BCO in this group@@ -153,19 +158,41 @@ -> assertPpr (isExternalName nm) (ppr nm) $ do let sym_to_find = nameToCLabel nm "closure"- m <- lookupSymbol interp sym_to_find+ m <- lookupHsSymbol interp pkgs_loaded nm "closure" case m of Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p)) Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (unpackFS sym_to_find) BCOPtrPrimOp op- -> ResolvedBCOStaticPtr <$> lookupPrimOp interp op+ -> ResolvedBCOStaticPtr <$> lookupPrimOp interp pkgs_loaded op BCOPtrBCO bco- -> ResolvedBCOPtrBCO <$> linkBCO interp le bco_ix breakarray bco+ -> ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded le bco_ix breakarray bco BCOPtrBreakArray -> return (ResolvedBCOPtrBreakArray breakarray)++-- | Look up the address of a Haskell symbol in the currently+-- loaded units.+--+-- See Note [Looking up symbols in the relevant objects].+lookupHsSymbol :: Interp -> PkgsLoaded -> Name -> String -> IO (Maybe (Ptr ()))+lookupHsSymbol interp pkgs_loaded nm sym_suffix = do+ massertPpr (isExternalName nm) (ppr nm)+ let sym_to_find = nameToCLabel nm sym_suffix+ pkg_id = moduleUnitId $ nameModule nm+ loaded_dlls = maybe [] loaded_pkg_hs_dlls $ lookupUDFM pkgs_loaded pkg_id++ go (dll:dlls) = do+ mb_ptr <- lookupSymbolInDLL interp dll sym_to_find+ case mb_ptr of+ Just ptr -> pure (Just ptr)+ Nothing -> go dlls+ go [] =+ -- See Note [Symbols may not be found in pkgs_loaded] in GHC.Linker.Types+ lookupSymbol interp sym_to_find++ go loaded_dlls linkFail :: String -> String -> IO a linkFail who what
GHC/Cmm/Lexer.hs view
@@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}-{-# LINE 13 "_build/source-dist/ghc-9.8.2-src/ghc-9.8.2/compiler/GHC/Cmm/Lexer.x" #-}+{-# LINE 13 "_build/source-dist/ghc-9.8.3-src/ghc-9.8.3/compiler/GHC/Cmm/Lexer.x" #-} module GHC.Cmm.Lexer ( CmmToken(..), cmmlex, ) where@@ -386,7 +386,7 @@ , (0,alex_action_20) ] -{-# LINE 134 "_build/source-dist/ghc-9.8.2-src/ghc-9.8.2/compiler/GHC/Cmm/Lexer.x" #-}+{-# LINE 134 "_build/source-dist/ghc-9.8.3-src/ghc-9.8.3/compiler/GHC/Cmm/Lexer.x" #-} data CmmToken = CmmT_SpecChar Char | CmmT_DotDot
GHC/Cmm/Opt.hs view
@@ -213,23 +213,33 @@ = Just $! CmmMachOp op [pic, CmmLit $ cmmOffsetLit lit off ] where off = fromIntegral (narrowS rep n) --- Make a RegOff if we can+-- Make a RegOff if we can. We don't perform this optimization if rep is greater+-- than the host word size because we use an Int to store the offset. See+-- #24893 and #24700. This should be fixed to ensure that optimizations don't+-- depend on the compiler host platform. cmmMachOpFoldM _ (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)]+ | validOffsetRep rep = Just $! cmmRegOff reg (fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]+ | validOffsetRep rep = Just $! cmmRegOff reg (off + fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)]+ | validOffsetRep rep = Just $! cmmRegOff reg (- fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]+ | validOffsetRep rep = Just $! cmmRegOff reg (off - fromIntegral (narrowS rep n)) -- Fold label(+/-)offset into a CmmLit where possible cmmMachOpFoldM _ (MO_Add _) [CmmLit lit, CmmLit (CmmInt i rep)]+ | validOffsetRep rep = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i))) cmmMachOpFoldM _ (MO_Add _) [CmmLit (CmmInt i rep), CmmLit lit]+ | validOffsetRep rep = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i))) cmmMachOpFoldM _ (MO_Sub _) [CmmLit lit, CmmLit (CmmInt i rep)]+ | validOffsetRep rep = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (negate (narrowU rep i)))) @@ -409,6 +419,13 @@ -- Anything else is just too hard. cmmMachOpFoldM _ _ _ = Nothing++-- | Check that a literal width is compatible with the host word size used to+-- store offsets. This should be fixed properly (using larger types to store+-- literal offsets). See #24893+validOffsetRep :: Width -> Bool+validOffsetRep rep = widthInBits rep <= finiteBitSize (undefined :: Int)+ {- Note [Comparison operators] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
GHC/CmmToAsm/AArch64.hs view
@@ -47,6 +47,7 @@ patchRegsOfInstr = AArch64.patchRegsOfInstr isJumpishInstr = AArch64.isJumpishInstr jumpDestsOfInstr = AArch64.jumpDestsOfInstr+ canFallthroughTo = AArch64.canFallthroughTo patchJumpInstr = AArch64.patchJumpInstr mkSpillInstr = AArch64.mkSpillInstr mkLoadInstr = AArch64.mkLoadInstr
GHC/CmmToAsm/AArch64/CodeGen.hs view
@@ -383,7 +383,7 @@ -- TODO OPT: we might be able give getRegister -- a hint, what kind of register we want.-getFloatReg :: HasCallStack => CmmExpr -> NatM (Reg, Format, InstrBlock)+getFloatReg :: HasDebugCallStack => CmmExpr -> NatM (Reg, Format, InstrBlock) getFloatReg expr = do r <- getRegister expr case r of
GHC/CmmToAsm/AArch64/Instr.hs view
@@ -176,6 +176,8 @@ interesting _ (RegReal (RealRegSingle (-1))) = False interesting platform (RegReal (RealRegSingle i)) = freeReg platform i +-- Note [AArch64 Register assignments]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Save caller save registers -- This is x0-x18 --@@ -198,6 +200,8 @@ -- '---------------------------------------------------------------------------------------------------------------------------------------------------------------' -- IR: Indirect result location register, IP: Intra-procedure register, PL: Platform register, FP: Frame pointer, LR: Link register, SP: Stack pointer -- BR: Base, SL: SpLim+--+-- TODO: The zero register is currently mapped to -1 but should get it's own separate number. callerSavedRegisters :: [Reg] callerSavedRegisters = map regSingle [0..18]@@ -327,6 +331,12 @@ jumpDestsOfInstr (BL t _ _) = [ id | TBlock id <- [t]] jumpDestsOfInstr (BCOND _ t) = [ id | TBlock id <- [t]] jumpDestsOfInstr _ = []++canFallthroughTo :: Instr -> BlockId -> Bool+canFallthroughTo (ANN _ i) bid = canFallthroughTo i bid+canFallthroughTo (J (TBlock target)) bid = bid == target+canFallthroughTo (B (TBlock target)) bid = bid == target+canFallthroughTo _ _ = False -- | Change the destination of this jump instruction. -- Used in the linear allocator when adding fixup blocks for join
GHC/CmmToAsm/AArch64/Ppr.hs view
@@ -317,6 +317,7 @@ | w == W64 = text "sp" | w == W32 = text "wsp" + -- See Note [AArch64 Register assignments] ppr_reg_no w i | i < 0, w == W32 = text "wzr" | i < 0, w == W64 = text "xzr"
GHC/CmmToAsm/AArch64/Regs.hs view
@@ -17,6 +17,7 @@ import GHC.Utils.Panic import GHC.Platform +-- TODO: Should this include the zero register? allMachRegNos :: [RegNo] allMachRegNos = [0..31] ++ [32..63] -- allocatableRegs is allMachRegNos with the fixed-use regs removed.
GHC/CmmToAsm/BlockLayout.hs view
@@ -777,10 +777,9 @@ dropJumps _ [] = [] dropJumps info (BasicBlock lbl ins:todo) | Just ins <- nonEmpty ins --This can happen because of shortcutting- , [dest] <- jumpDestsOfInstr (NE.last ins) , BasicBlock nextLbl _ : _ <- todo- , not (mapMember dest info)- , nextLbl == dest+ , canFallthroughTo (NE.last ins) nextLbl+ , not (mapMember nextLbl info) = BasicBlock lbl (NE.init ins) : dropJumps info todo | otherwise = BasicBlock lbl ins : dropJumps info todo
GHC/CmmToAsm/Instr.hs view
@@ -71,10 +71,16 @@ :: instr -> Bool - -- | Give the possible destinations of this jump instruction.+ -- | Give the possible *local block* destinations of this jump instruction. -- Must be defined for all jumpish instructions. jumpDestsOfInstr :: instr -> [BlockId]++ -- | Check if the instr always transfers control flow+ -- to the given block. Used by code layout to eliminate+ -- jumps that can be replaced by fall through.+ canFallthroughTo+ :: instr -> BlockId -> Bool -- | Change the destination of this jump instruction.
GHC/CmmToAsm/Monad.hs view
@@ -79,8 +79,15 @@ cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl statics instr], generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr), getJumpDestBlockId :: jumpDest -> Maybe BlockId,+ -- | Does this jump always jump to a single destination and is shortcutable?+ --+ -- We use this to determine shortcutable instructions - See Note [What is shortcutting]+ -- Note that if we return a destination here we *most* support the relevant shortcutting in+ -- shortcutStatics for jump tables and shortcutJump for the instructions itself. canShortcut :: instr -> Maybe jumpDest,+ -- | Replace references to blockIds with other destinations - used to update jump tables. shortcutStatics :: (BlockId -> Maybe jumpDest) -> statics -> statics,+ -- | Change the jump destination(s) of an instruction. shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr, -- | 'Module' is only for printing internal labels. See Note [Internal proc -- labels] in CLabel.@@ -105,6 +112,25 @@ -- ^ Turn the sequence of @jcc l1; jmp l2@ into @jncc l2; \<block_l1>@ -- when possible. }++{- Note [supporting shortcutting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For the concept of shortcutting see Note [What is shortcutting].++In order to support shortcutting across multiple backends uniformly we+use canShortcut, shortcutStatics and shortcutJump.++canShortcut tells us if the backend support shortcutting of a instruction+and if so what destination we should retarget instruction to instead.++shortcutStatics exists to allow us to update jump destinations in jump tables.++shortcutJump updates the instructions itself.++A backend can opt out of those by always returning Nothing for canShortcut+and implementing shortcutStatics/shortcutJump as \_ x -> x++-} {- Note [pprNatCmmDeclS and pprNatCmmDeclH] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
GHC/CmmToAsm/PPC.hs view
@@ -46,6 +46,7 @@ patchRegsOfInstr = PPC.patchRegsOfInstr isJumpishInstr = PPC.isJumpishInstr jumpDestsOfInstr = PPC.jumpDestsOfInstr+ canFallthroughTo = PPC.canFallthroughTo patchJumpInstr = PPC.patchJumpInstr mkSpillInstr = PPC.mkSpillInstr mkLoadInstr = PPC.mkLoadInstr
GHC/CmmToAsm/PPC/CodeGen.hs view
@@ -1766,7 +1766,7 @@ _ -> panic "genCall': unknown calling conv." argReps = map (cmmExprType platform) args- (argHints, _) = foreignTargetHints target+ (_, argHints) = foreignTargetHints target roundTo a x | x `mod` a == 0 = x | otherwise = x + a - (x `mod` a)
GHC/CmmToAsm/PPC/Instr.hs view
@@ -22,6 +22,7 @@ , patchJumpInstr , patchRegsOfInstr , jumpDestsOfInstr+ , canFallthroughTo , takeRegRegMoveInstr , takeDeltaInstr , mkRegRegMoveInstr@@ -509,6 +510,13 @@ BL{} -> True JMP{} -> True _ -> False++canFallthroughTo :: Instr -> BlockId -> Bool+canFallthroughTo instr bid+ = case instr of+ BCC _ target _ -> target == bid+ BCCFAR _ target _ -> target == bid+ _ -> False -- | Checks whether this instruction is a jump/branch instruction.
GHC/CmmToAsm/Reg/Graph/TrivColorable.hs view
@@ -179,7 +179,8 @@ ArchPPC -> 26 ArchPPC_64 _ -> 20 ArchARM _ _ _ -> panic "trivColorable ArchARM"- ArchAArch64 -> 32+ ArchAArch64 -> 24 -- 32 - F1 .. F4, D1..D4 - it's odd but see Note [AArch64 Register assignments] for our reg use.+ -- Seems we reserve different registers for D1..D4 and F1 .. F4 somehow, we should fix this. ArchAlpha -> panic "trivColorable ArchAlpha" ArchMipseb -> panic "trivColorable ArchMipseb" ArchMipsel -> panic "trivColorable ArchMipsel"
GHC/CmmToAsm/Reg/Linear/AArch64.hs view
@@ -8,11 +8,11 @@ import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Misc( HasDebugCallStack ) import GHC.Platform import Data.Word -import GHC.Stack -- AArch64 has 32 64bit general purpose register r0..r30, and zr/sp -- AArch64 has 32 128bit floating point registers v0..v31 as part of the NEON -- extension in Armv8-A.@@ -65,7 +65,7 @@ showBits w = map (\i -> if testBit w i then '1' else '0') [0..31] -- FR instance implementation (See Linear.FreeRegs)-allocateReg :: HasCallStack => RealReg -> FreeRegs -> FreeRegs+allocateReg :: HasDebugCallStack => RealReg -> FreeRegs -> FreeRegs allocateReg (RealRegSingle r) (FreeRegs g f) | r > 31 && testBit f (r - 32) = FreeRegs g (clearBit f (r - 32)) | r < 32 && testBit g r = FreeRegs (clearBit g r) f@@ -127,7 +127,7 @@ initFreeRegs :: Platform -> FreeRegs initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) -releaseReg :: HasCallStack => RealReg -> FreeRegs -> FreeRegs+releaseReg :: HasDebugCallStack => RealReg -> FreeRegs -> FreeRegs releaseReg (RealRegSingle r) (FreeRegs g f) | r > 31 && testBit f (r - 32) = pprPanic "Linear.AArch64.releaseReg" (text "can't release non-allocated reg v" <> int (r - 32)) | r < 32 && testBit g r = pprPanic "Linear.AArch64.releaseReg" (text "can't release non-allocated reg x" <> int r)
GHC/CmmToAsm/Reg/Liveness.hs view
@@ -133,6 +133,11 @@ Instr instr -> isJumpishInstr instr _ -> False + canFallthroughTo i bid+ = case i of+ Instr instr -> canFallthroughTo instr bid+ _ -> False+ jumpDestsOfInstr i = case i of Instr instr -> jumpDestsOfInstr instr
GHC/CmmToAsm/X86.hs view
@@ -51,6 +51,7 @@ patchRegsOfInstr = X86.patchRegsOfInstr isJumpishInstr = X86.isJumpishInstr jumpDestsOfInstr = X86.jumpDestsOfInstr+ canFallthroughTo = X86.canFallthroughTo patchJumpInstr = X86.patchJumpInstr mkSpillInstr = X86.mkSpillInstr mkLoadInstr = X86.mkLoadInstr
GHC/CmmToAsm/X86/CodeGen.hs view
@@ -2441,10 +2441,11 @@ -> [CmmFormal] -- ^ where to put the result -> [CmmActual] -- ^ arguments (of mixed type) -> NatM InstrBlock-genCCall32 addr conv dest_regs args = do+genCCall32 addr conv@(ForeignConvention _ argHints _ _) dest_regs args = do config <- getConfig let platform = ncgPlatform config- prom_args = map (maybePromoteCArg platform W32) args+ args_hints = zip args (argHints ++ repeat NoHint)+ prom_args = map (maybePromoteCArg platform W32) args_hints -- If the size is smaller than the word, we widen things (see maybePromoteCArg) arg_size_bytes :: CmmType -> Int@@ -2598,10 +2599,11 @@ -> [CmmFormal] -- ^ where to put the result -> [CmmActual] -- ^ arguments (of mixed type) -> NatM InstrBlock-genCCall64 addr conv dest_regs args = do+genCCall64 addr conv@(ForeignConvention _ argHints _ _) dest_regs args = do platform <- getPlatform -- load up the register arguments- let prom_args = map (maybePromoteCArg platform W32) args+ let args_hints = zip args (argHints ++ repeat NoHint)+ let prom_args = map (maybePromoteCArg platform W32) args_hints let load_args :: [CmmExpr] -> [Reg] -- int regs avail for args@@ -2839,9 +2841,11 @@ assign_code dest_regs) -maybePromoteCArg :: Platform -> Width -> CmmExpr -> CmmExpr-maybePromoteCArg platform wto arg- | wfrom < wto = CmmMachOp (MO_UU_Conv wfrom wto) [arg]+maybePromoteCArg :: Platform -> Width -> (CmmExpr, ForeignHint) -> CmmExpr+maybePromoteCArg platform wto (arg, hint)+ | wfrom < wto = case hint of+ SignedHint -> CmmMachOp (MO_SS_Conv wfrom wto) [arg]+ _ -> CmmMachOp (MO_UU_Conv wfrom wto) [arg] | otherwise = arg where wfrom = cmmExprWidth platform arg@@ -3205,7 +3209,6 @@ -> FMASign -> CmmExpr -> CmmExpr -> CmmExpr -> NatM Register genFMA3Code w signs x y z = do- -- For the FMA instruction, we want to compute x * y + z -- -- There are three possible instructions we could emit:@@ -3226,17 +3229,45 @@ -- -- Currently we follow neither of these optimisations, -- opting to always use fmadd213 for simplicity.+ --+ -- We would like to compute the result directly into the requested register.+ -- To do so we must first compute `x` into the destination register. This is+ -- only possible if the other arguments don't use the destination register.+ -- We check for this and if there is a conflict we move the result only after+ -- the computation. See #24496 how this went wrong in the past. let rep = floatFormat w (y_reg, y_code) <- getNonClobberedReg y- (z_reg, z_code) <- getNonClobberedReg z+ (z_op, z_code) <- getNonClobberedOperand z x_code <- getAnyReg x+ x_tmp <- getNewRegNat rep let fma213 = FMA3 rep signs FMA213- code dst- = y_code `appOL`++ code, code_direct, code_mov :: Reg -> InstrBlock+ -- Ideal: Compute the result directly into dst+ code_direct dst = x_code dst `snocOL`+ fma213 z_op y_reg dst+ -- Fallback: Compute the result into a tmp reg and then move it.+ code_mov dst = x_code x_tmp `snocOL`+ fma213 z_op y_reg x_tmp `snocOL`+ MOV rep (OpReg x_tmp) (OpReg dst)++ code dst =+ y_code `appOL` z_code `appOL`- x_code dst `snocOL`- fma213 (OpReg z_reg) y_reg dst+ ( if arg_regs_conflict then code_mov dst else code_direct dst )++ where++ arg_regs_conflict =+ y_reg == dst ||+ case z_op of+ OpReg z_reg -> z_reg == dst+ OpAddr amode -> dst `elem` addrModeRegs amode+ OpImm {} -> False++ -- NB: Computing the result into a desired register using Any can be tricky.+ -- So for now, we keep it simple. (See #24496). return (Any rep code) -----------
GHC/CmmToAsm/X86/Instr.hs view
@@ -31,6 +31,7 @@ , mkSpillInstr , mkRegRegMoveInstr , jumpDestsOfInstr+ , canFallthroughTo , patchRegsOfInstr , patchJumpInstr , isMetaInstr@@ -664,6 +665,17 @@ CALL{} -> True _ -> False +canFallthroughTo :: Instr -> BlockId -> Bool+canFallthroughTo insn bid+ = case insn of+ JXX _ target -> bid == target+ JMP_TBL _ targets _ _ -> all isTargetBid targets+ _ -> False+ where+ isTargetBid target = case target of+ Nothing -> True+ Just (DestBlockId target) -> target == bid+ _ -> False jumpDestsOfInstr :: Instr
GHC/Core/Opt/Arity.hs view
@@ -855,7 +855,7 @@ -- | The Arity returned is the number of value args the -- expression can be applied to without doing much work-exprEtaExpandArity :: ArityOpts -> CoreExpr -> Maybe SafeArityType+exprEtaExpandArity :: HasDebugCallStack => ArityOpts -> CoreExpr -> Maybe SafeArityType -- exprEtaExpandArity is used when eta expanding -- e ==> \xy -> e x y -- Nothing if the expression has arity 0
GHC/Core/Opt/DmdAnal.hs view
@@ -2349,7 +2349,7 @@ -- L demand doesn't get both'd with the Bot coming up from the inner -- call to f. So we just get an L demand for x for g. -setBndrsDemandInfo :: HasCallStack => [Var] -> [Demand] -> [Var]+setBndrsDemandInfo :: HasDebugCallStack => [Var] -> [Demand] -> [Var] setBndrsDemandInfo (b:bs) ds | isTyVar b = b : setBndrsDemandInfo bs ds setBndrsDemandInfo (b:bs) (d:ds) =
GHC/Core/Opt/Simplify/Iteration.hs view
@@ -2251,34 +2251,44 @@ (ApplyToVal { sc_arg = arg, sc_env = arg_se , sc_cont = cont, sc_hole_ty = fun_ty }) | fun_id `hasKey` runRWKey- , [ TyArg {}, TyArg {} ] <- rev_args- -- Do this even if (contIsStop cont)+ , [ TyArg { as_arg_ty = hole_ty }, TyArg {} ] <- rev_args+ -- Do this even if (contIsStop cont), or if seCaseCase is off. -- See Note [No eta-expansion in runRW#] = do { let arg_env = arg_se `setInScopeFromE` env- ty' = contResultType cont + overall_res_ty = contResultType cont+ -- hole_ty is the type of the current runRW# application+ (outer_cont, new_runrw_res_ty, inner_cont)+ | seCaseCase env = (mkBoringStop overall_res_ty, overall_res_ty, cont)+ | otherwise = (cont, hole_ty, mkBoringStop hole_ty)+ -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify+ -- Note [Case-of-case and full laziness]+ -- If the argument is a literal lambda already, take a short cut- -- This isn't just efficiency; if we don't do this we get a beta-redex- -- every time, so the simplifier keeps doing more iterations.+ -- This isn't just efficiency:+ -- * If we don't do this we get a beta-redex every time, so the+ -- simplifier keeps doing more iterations.+ -- * Even more important: see Note [No eta-expansion in runRW#] ; arg' <- case arg of Lam s body -> do { (env', s') <- simplBinder arg_env s- ; body' <- simplExprC env' body cont+ ; body' <- simplExprC env' body inner_cont ; return (Lam s' body') } -- Important: do not try to eta-expand this lambda -- See Note [No eta-expansion in runRW#]+ _ -> do { s' <- newId (fsLit "s") ManyTy realWorldStatePrimTy ; let (m,_,_) = splitFunTy fun_ty env' = arg_env `addNewInScopeIds` [s'] cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s'- , sc_env = env', sc_cont = cont- , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' }+ , sc_env = env', sc_cont = inner_cont+ , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy new_runrw_res_ty } -- cont' applies to s', then K ; body' <- simplExprC env' arg cont' ; return (Lam s' body') } - ; let rr' = getRuntimeRep ty'- call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg ty', arg']- ; return (emptyFloats env, call') }+ ; let rr' = getRuntimeRep new_runrw_res_ty+ call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg new_runrw_res_ty, arg']+ ; rebuild env call' outer_cont } ---------- Simplify value arguments -------------------- rebuildCall env fun_info@@ -2291,7 +2301,8 @@ -- Strict arguments | isStrictArgInfo fun_info- , seCaseCase env+ , seCaseCase env -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify+ -- Note [Case-of-case and full laziness] = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ simplExprF (arg_se `setInScopeFromE` env) arg (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty@@ -3110,7 +3121,9 @@ -------------------------------------------------- reallyRebuildCase env scrut case_bndr alts cont- | not (seCaseCase env)+ | not (seCaseCase env) -- Only when case-of-case is on.+ -- See GHC.Driver.Config.Core.Opt.Simplify+ -- Note [Case-of-case and full laziness] = do { case_expr <- simplAlts env scrut case_bndr alts (mkBoringStop (contHoleType cont)) ; rebuild env case_expr cont }
GHC/Core/Rules.hs view
@@ -47,7 +47,7 @@ import GHC.Core -- All of it import GHC.Core.Subst import GHC.Core.SimpleOpt ( exprIsLambda_maybe )-import GHC.Core.FVs ( exprFreeVars, exprsFreeVars, bindFreeVars+import GHC.Core.FVs ( exprFreeVars, bindFreeVars , rulesFreeVarsDSet, exprsOrphNames ) import GHC.Core.Utils ( exprType, mkTick, mkTicks , stripTicksTopT, stripTicksTopE@@ -1805,41 +1805,59 @@ vcat [ p $$ line | p <- bagToList results ] ] where+ line = text (replicate 20 '-') env = RuleCheckEnv { rc_is_active = isActive phase , rc_id_unf = idUnfolding -- Not quite right -- Should use activeUnfolding , rc_pattern = rule_pat , rc_rules = rules , rc_ropts = ropts- }- results = unionManyBags (map (ruleCheckBind env) binds)- line = text (replicate 20 '-')+ , rc_in_scope = emptyInScopeSet } -data RuleCheckEnv = RuleCheckEnv {- rc_is_active :: Activation -> Bool,- rc_id_unf :: IdUnfoldingFun,- rc_pattern :: String,- rc_rules :: Id -> [CoreRule],- rc_ropts :: RuleOpts-}+ results = go env binds -ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc+ go _ [] = emptyBag+ go env (bind:binds) = let (env', ds) = ruleCheckBind env bind+ in ds `unionBags` go env' binds++data RuleCheckEnv = RuleCheckEnv+ { rc_is_active :: Activation -> Bool+ , rc_id_unf :: IdUnfoldingFun+ , rc_pattern :: String+ , rc_rules :: Id -> [CoreRule]+ , rc_ropts :: RuleOpts+ , rc_in_scope :: InScopeSet }++extendInScopeRC :: RuleCheckEnv -> Var -> RuleCheckEnv+extendInScopeRC env@(RuleCheckEnv { rc_in_scope = in_scope }) v+ = env { rc_in_scope = in_scope `extendInScopeSet` v }++extendInScopeListRC :: RuleCheckEnv -> [Var] -> RuleCheckEnv+extendInScopeListRC env@(RuleCheckEnv { rc_in_scope = in_scope }) vs+ = env { rc_in_scope = in_scope `extendInScopeSetList` vs }++ruleCheckBind :: RuleCheckEnv -> CoreBind -> (RuleCheckEnv, Bag SDoc) -- The Bag returned has one SDoc for each call site found-ruleCheckBind env (NonRec _ r) = ruleCheck env r-ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (_,r) <- prs]+ruleCheckBind env (NonRec b r) = (env `extendInScopeRC` b, ruleCheck env r)+ruleCheckBind env (Rec prs) = (env', unionManyBags (map (ruleCheck env') rhss))+ where+ (bs, rhss) = unzip prs+ env' = env `extendInScopeListRC` bs ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc-ruleCheck _ (Var _) = emptyBag-ruleCheck _ (Lit _) = emptyBag-ruleCheck _ (Type _) = emptyBag-ruleCheck _ (Coercion _) = emptyBag-ruleCheck env (App f a) = ruleCheckApp env (App f a) []-ruleCheck env (Tick _ e) = ruleCheck env e-ruleCheck env (Cast e _) = ruleCheck env e-ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e-ruleCheck env (Lam _ e) = ruleCheck env e-ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags`- unionManyBags [ruleCheck env r | Alt _ _ r <- as]+ruleCheck _ (Var _) = emptyBag+ruleCheck _ (Lit _) = emptyBag+ruleCheck _ (Type _) = emptyBag+ruleCheck _ (Coercion _) = emptyBag+ruleCheck env (App f a) = ruleCheckApp env (App f a) []+ruleCheck env (Tick _ e) = ruleCheck env e+ruleCheck env (Cast e _) = ruleCheck env e+ruleCheck env (Let bd e) = let (env', ds) = ruleCheckBind env bd+ in ds `unionBags` ruleCheck env' e+ruleCheck env (Lam b e) = ruleCheck (env `extendInScopeRC` b) e+ruleCheck env (Case e b _ as) = ruleCheck env e `unionBags`+ unionManyBags [ruleCheck (env `extendInScopeListRC` (b:bs)) r+ | Alt _ bs r <- as] ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as)@@ -1863,8 +1881,9 @@ vcat [text "Expression:" <+> ppr (mkApps (Var fn) args), vcat (map check_rule rules)] where- n_args = length args- i_args = args `zip` [1::Int ..]+ in_scope = rc_in_scope env+ n_args = length args+ i_args = args `zip` [1::Int ..] rough_args = map roughTopName args check_rule rule = rule_herald rule <> colon <+> rule_info (rc_ropts env) rule@@ -1894,10 +1913,8 @@ mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args, not (isJust (match_fn rule_arg arg))] - lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg MRefl where- in_scope = mkInScopeSet (lhs_fvs `unionVarSet` exprFreeVars arg) renv = RV { rv_lcl = mkRnEnv2 in_scope , rv_tmpls = mkVarSet rule_bndrs , rv_fltR = mkEmptySubst in_scope
GHC/Core/SimpleOpt.hs view
@@ -229,13 +229,14 @@ (env', r) = k env{soe_rec_ids = extendUnVarSetList bndrs (soe_rec_ids env)} ----------------simple_opt_clo :: InScopeSet+simple_opt_clo :: HasCallStack+ => InScopeSet -> SimpleClo -> OutExpr simple_opt_clo in_scope (e_env, e) = simple_opt_expr (soeSetInScope in_scope e_env) e -simple_opt_expr :: HasCallStack => SimpleOptEnv -> InExpr -> OutExpr+simple_opt_expr :: HasDebugCallStack => SimpleOptEnv -> InExpr -> OutExpr simple_opt_expr env expr = go expr where@@ -399,7 +400,8 @@ simple_app env e as = finish_app env (simple_opt_expr env e) as -finish_app :: SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr+finish_app :: HasCallStack+ => SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr -- See Note [Eliminate casts in function position] finish_app env (Cast (Lam x e) co) as@(_:_) | not (isTyVar x) && not (isCoVar x)
GHC/Core/Type.hs view
@@ -1587,7 +1587,7 @@ Just (_, tys) -> Just tys Nothing -> Nothing -tyConAppArgs :: HasCallStack => Type -> [Type]+tyConAppArgs :: HasDebugCallStack => Type -> [Type] tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty) -- | Attempts to tease a type apart into a type constructor and the application@@ -1627,7 +1627,7 @@ -- -- Consequently, you may need to zonk your type before -- using this function.-tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type])+tcSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) -- Defined here to avoid module loops between Unify and TcType. tcSplitTyConApp_maybe ty = case coreFullView ty of
GHC/Core/Utils.hs view
@@ -23,9 +23,9 @@ -- * Properties of expressions exprType, coreAltType, coreAltsType, mkLamType, mkLamTypes, mkFunctionType,- exprIsDupable, exprIsTrivial, getIdFromTrivialExpr,- getIdFromTrivialExpr_maybe,- exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun,+ exprIsTrivial, getIdFromTrivialExpr, getIdFromTrivialExpr_maybe,+ trivial_expr_fold,+ exprIsDupable, exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun, exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprOkForSpecEval, exprIsWorkFree, exprIsConLike, isCheapApp, isExpandableApp, isSaturatedConApp,@@ -1046,20 +1046,37 @@ it off at source. -} +{-# INLINE trivial_expr_fold #-}+trivial_expr_fold :: (Id -> r) -> (Literal -> r) -> r -> r -> CoreExpr -> r+-- ^ The worker function for Note [exprIsTrivial] and Note [getIdFromTrivialExpr]+-- This is meant to have the code of both functions in one place and make it+-- easy to derive custom predicates.+--+-- (trivial_expr_fold k_id k_triv k_not_triv e)+-- * returns (k_id x) if `e` is a variable `x` (with trivial wrapping)+-- * returns (k_lit x) if `e` is a trivial literal `l` (with trivial wrapping)+-- * returns k_triv if `e` is a literal, type, or coercion (with trivial wrapping)+-- * returns k_not_triv otherwise+--+-- where "trivial wrapping" is+-- * Type application or abstraction+-- * Ticks other than `tickishIsCode`+-- * `case e of {}` an empty case+trivial_expr_fold k_id k_lit k_triv k_not_triv = go+ where+ go (Var v) = k_id v -- See Note [Variables are trivial]+ go (Lit l) | litIsTrivial l = k_lit l+ go (Type _) = k_triv+ go (Coercion _) = k_triv+ go (App f t) | not (isRuntimeArg t) = go f+ go (Lam b e) | not (isRuntimeVar b) = go e+ go (Tick t e) | not (tickishIsCode t) = go e -- See Note [Tick trivial]+ go (Cast e _) = go e+ go (Case e _ _ []) = go e -- See Note [Empty case is trivial]+ go _ = k_not_triv+ exprIsTrivial :: CoreExpr -> Bool--- If you modify this function, you may also--- need to modify getIdFromTrivialExpr-exprIsTrivial (Var _) = True -- See Note [Variables are trivial]-exprIsTrivial (Type _) = True-exprIsTrivial (Coercion _) = True-exprIsTrivial (Lit lit) = litIsTrivial lit-exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e-exprIsTrivial (Lam b e) = not (isRuntimeVar b) && exprIsTrivial e-exprIsTrivial (Tick t e) = not (tickishIsCode t) && exprIsTrivial e- -- See Note [Tick trivial]-exprIsTrivial (Cast e _) = exprIsTrivial e-exprIsTrivial (Case e _ _ []) = exprIsTrivial e -- See Note [Empty case is trivial]-exprIsTrivial _ = False+exprIsTrivial e = trivial_expr_fold (const True) (const True) True False e {- Note [getIdFromTrivialExpr]@@ -1079,24 +1096,13 @@ -} getIdFromTrivialExpr :: HasDebugCallStack => CoreExpr -> Id-getIdFromTrivialExpr e- = fromMaybe (pprPanic "getIdFromTrivialExpr" (ppr e))- (getIdFromTrivialExpr_maybe e)--getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id -- See Note [getIdFromTrivialExpr]--- Th equations for this should line up with those for exprIsTrivial-getIdFromTrivialExpr_maybe e- = go e+getIdFromTrivialExpr e = trivial_expr_fold id (const panic) panic panic e where- go (App f t) | not (isRuntimeArg t) = go f- go (Tick t e) | not (tickishIsCode t) = go e- go (Cast e _) = go e- go (Lam b e) | not (isRuntimeVar b) = go e- go (Case e _ _ []) = go e- go (Var v) = Just v- go _ = Nothing+ panic = pprPanic "getIdFromTrivialExpr" (ppr e) +getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id+getIdFromTrivialExpr_maybe e = trivial_expr_fold Just (const Nothing) Nothing Nothing e {- ********************************************************************* * *
GHC/CoreToStg.hs view
@@ -19,8 +19,7 @@ import GHC.Prelude import GHC.Core-import GHC.Core.Utils ( exprType, findDefault, isJoinBind- , exprIsTickedString_maybe )+import GHC.Core.Utils import GHC.Core.Opt.Arity ( manifestArity ) import GHC.Core.Type import GHC.Core.TyCon@@ -49,7 +48,7 @@ import GHC.Data.FastString import GHC.Platform ( Platform ) import GHC.Platform.Ways-import GHC.Builtin.PrimOps ( PrimCall(..), primOpWrapperId )+import GHC.Builtin.PrimOps import GHC.Utils.Outputable import GHC.Utils.Monad@@ -574,6 +573,19 @@ -- This is the guy that turns applications into A-normal form -- --------------------------------------------------------------------------- +getStgArgFromTrivialArg :: HasDebugCallStack => CoreArg -> StgArg+-- A (non-erased) trivial CoreArg corresponds to an atomic StgArg.+-- CoreArgs may not immediately look trivial, e.g., `case e of {}` or+-- `case unsafeequalityProof of UnsafeRefl -> e` might intervene.+-- Good thing we can just call `trivial_expr_fold` here.+getStgArgFromTrivialArg e+ | Just s <- exprIsTickedString_maybe e -- This case is just for backport to GHC 9.8,+ = StgLitArg (LitString s) -- where we used to treat strings as valid StgArgs+ | otherwise+ = trivial_expr_fold StgVarArg StgLitArg panic panic e+ where+ panic = pprPanic "getStgArgFromTrivialArg" (ppr e)+ coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [StgTickish]) coreToStgArgs [] = return ([], [])@@ -586,42 +598,29 @@ = do { (args', ts) <- coreToStgArgs args ; return (StgVarArg coercionTokenId : args', ts) } -coreToStgArgs (Tick t e : args)- = assert (not (tickishIsCode t)) $- do { (args', ts) <- coreToStgArgs (e : args)- ; let !t' = coreToStgTick (exprType e) t- ; return (args', t':ts) }- coreToStgArgs (arg : args) = do -- Non-type argument (stg_args, ticks) <- coreToStgArgs args- arg' <- coreToStgExpr arg- let- (aticks, arg'') = stripStgTicksTop tickishFloatable arg'- stg_arg = case arg'' of- StgApp v [] -> StgVarArg v- StgConApp con _ [] _ -> StgVarArg (dataConWorkId con)- StgOpApp (StgPrimOp op) [] _ -> StgVarArg (primOpWrapperId op)- StgLit lit -> StgLitArg lit- _ -> pprPanic "coreToStgArgs" (ppr arg $$ pprStgExpr panicStgPprOpts arg' $$ pprStgExpr panicStgPprOpts arg'')-- -- WARNING: what if we have an argument like (v `cast` co)- -- where 'co' changes the representation type?- -- (This really only happens if co is unsafe.)- -- Then all the getArgAmode stuff in CgBindery will set the- -- cg_rep of the CgIdInfo based on the type of v, rather- -- than the type of 'co'.- -- This matters particularly when the function is a primop- -- or foreign call.- -- Wanted: a better solution than this hacky warning-+ -- We know that `arg` must be trivial, but it may contain Ticks.+ -- Example from test case `decodeMyStack`:+ -- $ @... ((src<decodeMyStack.hs:18:26-28> Data.Tuple.snd) @Int @[..])+ -- Note that unfortunately the Tick is not at the top.+ -- So we'll traverse the expression twice:+ -- * Once with `stripTicksT` (which collects *all* ticks from the expression)+ -- * and another time with `getStgArgFromTrivialArg`.+ -- Since the argument is trivial, the only place the Tick can occur is+ -- somehow wrapping a variable (give or take type args, as above). platform <- getPlatform- let- arg_rep = typePrimRep (exprType arg)- stg_arg_rep = typePrimRep (stgArgType stg_arg)+ let arg_ty = exprType arg+ ticks' = map (coreToStgTick arg_ty) (stripTicksT (not . tickishIsCode) arg)+ arg' = getStgArgFromTrivialArg arg+ arg_rep = typePrimRep arg_ty+ stg_arg_rep = typePrimRep (stgArgType arg') bad_args = not (primRepsCompatible platform arg_rep stg_arg_rep) - warnPprTrace bad_args "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (ppr arg) $- return (stg_arg : stg_args, ticks ++ aticks)+ massertPpr (length ticks' <= 1) (text "More than one Tick in trivial arg:" <+> ppr arg)+ warnPprTrace bad_args "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (ppr arg) (return ())++ return (arg' : stg_args, ticks' ++ ticks) coreToStgTick :: Type -- type of the ticked expression -> CoreTickish
GHC/Data/Maybe.hs view
@@ -33,7 +33,7 @@ import Control.Exception (SomeException(..)) import Data.Maybe import Data.Foldable ( foldlM, for_ )-import GHC.Utils.Misc (HasCallStack)+import GHC.Utils.Misc (HasDebugCallStack) import Data.List.NonEmpty ( NonEmpty ) import Control.Applicative( Alternative( (<|>) ) ) @@ -66,7 +66,7 @@ go Nothing action = action go result@(Just _) _action = return result -expectJust :: HasCallStack => String -> Maybe a -> a+expectJust :: HasDebugCallStack => String -> Maybe a -> a {-# INLINE expectJust #-} expectJust _ (Just x) = x expectJust err Nothing = error ("expectJust " ++ err)
GHC/Driver/Config/Core/Opt/Simplify.hs view
@@ -80,6 +80,7 @@ initGentleSimplMode dflags = (initSimplMode dflags InitialPhase "Gentle") { -- Don't do case-of-case transformations. -- This makes full laziness work better+ -- See Note [Case-of-case and full laziness] sm_case_case = False } @@ -89,3 +90,37 @@ (True, True) -> FloatEnabled (True, False)-> FloatNestedOnly (False, _) -> FloatDisabled+++{- Note [Case-of-case and full laziness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Case-of-case can hide opportunities for let-floating (full laziness).+For example+ rec { f = \y. case (expensive x) of (a,b) -> blah }+We might hope to float the (expensive x) out of the \y-loop.+But if we inline `expensive` we might get+ \y. case (case x of I# x' -> body) of (a,b) -> blah+Now if we do case-of-case we get+ \y. case x if I# x2 ->+ case body of (a,b) -> blah++Sadly, at this point `body` mentions `x2`, so we can't float it out of the+\y-loop.++Solution: don't do case-of-case in the "gentle" simplification phase that+precedes the first float-out transformation. Implementation:++ * `sm_case_case` field in SimplMode++ * Consult `sm_case_case` (via `seCaseCase`) before doing case-of-case+ in GHC.Core.Opt.Simplify.Iteration.rebuildCall.++Wrinkles++* This applies equally to the case-of-runRW# transformation:+ case (runRW# (\s. body)) of (a,b) -> blah+ --->+ runRW# (\s. case body of (a,b) -> blah)+ Again, don't do this when `sm_case_case` is off. See #25055 for+ a motivating example.+-}
GHC/Driver/Main.hs view
@@ -2647,7 +2647,7 @@ case interp of -- always generate JS code for the JS interpreter (no bytecode!)- Interp (ExternalInterp (ExtJS i)) _ ->+ Interp (ExternalInterp (ExtJS i)) _ _ -> jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id _ -> do
GHC/Driver/Make.hs view
@@ -311,16 +311,16 @@ -- Note [Missing home modules] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Sometimes user doesn't want GHC to pick up modules, not explicitly listed--- in a command line. For example, cabal may want to enable this warning--- when building a library, so that GHC warns user about modules, not listed--- neither in `exposed-modules`, nor in `other-modules`.+-- Sometimes we don't want GHC to process modules that weren't specified as+-- explicit targets. For example, cabal may want to enable this warning+-- when building a library, so that GHC warns the user about modules listed+-- neither in `exposed-modules` nor in `other-modules`. ----- Here "home module" means a module, that doesn't come from an other package.+-- Here "home module" means a module that doesn't come from another package. -- -- For example, if GHC is invoked with modules "A" and "B" as targets, -- but "A" imports some other module "C", then GHC will issue a warning--- about module "C" not being listed in a command line.+-- about module "C" not being listed in the command line. -- -- The warning in enabled by `-Wmissing-home-modules`. See #13129 warnMissingHomeModules :: DynFlags -> [Target] -> ModuleGraph -> DriverMessages@@ -331,8 +331,6 @@ where diag_opts = initDiagOpts dflags - is_known_module mod = any (is_my_target mod) targets- -- We need to be careful to handle the case where (possibly -- path-qualified) filenames (aka 'TargetFile') rather than module -- names are being passed on the GHC command-line.@@ -341,28 +339,30 @@ -- `ghc --make -isrc-exe Main` are supposed to be equivalent. -- Note also that we can't always infer the associated module name -- directly from the filename argument. See #13727.- is_my_target mod target =- let tuid = targetUnitId target- in case targetId target of- TargetModule name- -> moduleName (ms_mod mod) == name- && tuid == ms_unitid mod- TargetFile target_file _- | Just mod_file <- ml_hs_file (ms_location mod)- ->- augmentByWorkingDirectory dflags target_file == mod_file ||+ is_known_module mod =+ (Map.lookup (moduleName (ms_mod mod)) mod_targets == Just (ms_unitid mod))+ ||+ maybe False is_file_target (ml_hs_file (ms_location mod)) - -- Don't warn on B.hs-boot if B.hs is specified (#16551)- addBootSuffix target_file == mod_file ||+ is_file_target file = Set.member (withoutExt file) file_targets - -- We can get a file target even if a module name was- -- originally specified in a command line because it can- -- be converted in guessTarget (by appending .hs/.lhs).- -- So let's convert it back and compare with module name- mkModuleName (fst $ splitExtension target_file)- == moduleName (ms_mod mod)- _ -> False+ file_targets = Set.fromList (mapMaybe file_target targets) + file_target Target {targetId} =+ case targetId of+ TargetModule _ -> Nothing+ TargetFile file _ ->+ Just (withoutExt (augmentByWorkingDirectory dflags file))++ mod_targets = Map.fromList (mod_target <$> targets)++ mod_target Target {targetUnitId, targetId} =+ case targetId of+ TargetModule name -> (name, targetUnitId)+ TargetFile file _ -> (mkModuleName (withoutExt file), targetUnitId)++ withoutExt = fst . splitExtension+ missing = map (moduleName . ms_mod) $ filter (not . is_known_module) $ (filter (\ms -> ms_unitid ms == homeUnitId_ dflags)@@ -1578,8 +1578,8 @@ let (root_errs, rootSummariesOk) = partitionEithers rootSummaries -- #17549 root_map = mkRootMap rootSummariesOk checkDuplicates root_map- (deps, pkg_deps, map0) <- loopSummaries rootSummariesOk (M.empty, Set.empty, root_map)- let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env) (hsc_all_home_unit_ids hsc_env) (Set.toList pkg_deps)+ (deps, map0) <- loopSummaries rootSummariesOk (M.empty, root_map)+ let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env) let unit_env = hsc_unit_env hsc_env let tmpfs = hsc_tmpfs hsc_env @@ -1673,19 +1673,19 @@ -- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit loopSummaries :: [ModSummary]- -> (M.Map NodeKey ModuleGraphNode, Set.Set (UnitId, UnitId),+ -> (M.Map NodeKey ModuleGraphNode, DownsweepCache)- -> IO ((M.Map NodeKey ModuleGraphNode), Set.Set (UnitId, UnitId), DownsweepCache)+ -> IO ((M.Map NodeKey ModuleGraphNode), DownsweepCache) loopSummaries [] done = return done- loopSummaries (ms:next) (done, pkgs, summarised)+ loopSummaries (ms:next) (done, summarised) | Just {} <- M.lookup k done- = loopSummaries next (done, pkgs, summarised)+ = loopSummaries next (done, summarised) -- Didn't work out what the imports mean yet, now do that. | otherwise = do- (final_deps, pkgs1, done', summarised') <- loopImports (calcDeps ms) done summarised+ (final_deps, done', summarised') <- loopImports (calcDeps ms) done summarised -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.- (_, _, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised'- loopSummaries next (M.insert k (ModuleNode final_deps ms) done'', pkgs1 `Set.union` pkgs, summarised'')+ (_, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised'+ loopSummaries next (M.insert k (ModuleNode final_deps ms) done'', summarised'') where k = NodeKey_Module (msKey ms) @@ -1705,18 +1705,17 @@ -- Visited set; the range is a list because -- the roots can have the same module names -- if allow_dup_roots is True- -> IO ([NodeKey], Set.Set (UnitId, UnitId),-+ -> IO ([NodeKey], M.Map NodeKey ModuleGraphNode, DownsweepCache) -- The result is the completed NodeMap- loopImports [] done summarised = return ([], Set.empty, done, summarised)+ loopImports [] done summarised = return ([], done, summarised) loopImports ((home_uid,mb_pkg, gwib) : ss) done summarised | Just summs <- M.lookup cache_key summarised = case summs of [Right ms] -> do let nk = NodeKey_Module (msKey ms)- (rest, pkgs, summarised', done') <- loopImports ss done summarised- return (nk: rest, pkgs, summarised', done')+ (rest, summarised', done') <- loopImports ss done summarised+ return (nk: rest, summarised', done') [Left _err] -> loopImports ss done summarised _errs -> do@@ -1728,69 +1727,77 @@ Nothing excl_mods case mb_s of NotThere -> loopImports ss done summarised- External uid -> do- (other_deps, pkgs, done', summarised') <- loopImports ss done summarised- return (other_deps, Set.insert (homeUnitId home_unit, uid) pkgs, done', summarised')+ External _ -> do+ (other_deps, done', summarised') <- loopImports ss done summarised+ return (other_deps, done', summarised') FoundInstantiation iud -> do- (other_deps, pkgs, done', summarised') <- loopImports ss done summarised- return (NodeKey_Unit iud : other_deps, pkgs, done', summarised')+ (other_deps, done', summarised') <- loopImports ss done summarised+ return (NodeKey_Unit iud : other_deps, done', summarised') FoundHomeWithError (_uid, e) -> loopImports ss done (Map.insert cache_key [(Left e)] summarised) FoundHome s -> do- (done', pkgs1, summarised') <-- loopSummaries [s] (done, Set.empty, Map.insert cache_key [Right s] summarised)- (other_deps, pkgs2, final_done, final_summarised) <- loopImports ss done' summarised'+ (done', summarised') <-+ loopSummaries [s] (done, Map.insert cache_key [Right s] summarised)+ (other_deps, final_done, final_summarised) <- loopImports ss done' summarised' -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now.- return (NodeKey_Module (msKey s) : other_deps, pkgs1 `Set.union` pkgs2, final_done, final_summarised)+ return (NodeKey_Module (msKey s) : other_deps, final_done, final_summarised) where cache_key = (home_uid, mb_pkg, unLoc <$> gwib) home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env) GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib wanted_mod = L loc mod --- This function checks then important property that if both p and q are home units+-- | This function checks then important property that if both p and q are home units -- then any dependency of p, which transitively depends on q is also a home unit.-checkHomeUnitsClosed :: UnitEnv -> Set.Set UnitId -> [(UnitId, UnitId)] -> [DriverMessages]--- Fast path, trivially closed.-checkHomeUnitsClosed ue home_id_set home_imp_ids- | Set.size home_id_set == 1 = []- | otherwise =- let res = foldMap loop home_imp_ids- -- Now check whether everything which transitively depends on a home_unit is actually a home_unit- -- These units are the ones which we need to load as home packages but failed to do for some reason,- -- it's a bug in the tool invoking GHC.- bad_unit_ids = Set.difference res home_id_set- in if Set.null bad_unit_ids- then []- else [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)]-+--+-- See Note [Multiple Home Units], section 'Closure Property'.+checkHomeUnitsClosed :: UnitEnv -> [DriverMessages]+checkHomeUnitsClosed ue+ | Set.null bad_unit_ids = []+ | otherwise = [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)] where+ home_id_set = unitEnv_keys $ ue_home_unit_graph ue+ bad_unit_ids = upwards_closure Set.\\ home_id_set rootLoc = mkGeneralSrcSpan (fsLit "<command line>")- -- TODO: This could repeat quite a bit of work but I struggled to write this function.- -- Which units transitively depend on a home unit- loop :: (UnitId, UnitId) -> Set.Set UnitId -- The units which transitively depend on a home unit- loop (from_uid, uid) =- let us = ue_findHomeUnitEnv from_uid ue in- let um = unitInfoMap (homeUnitEnv_units us) in- case lookupUniqMap um uid of- Nothing -> pprPanic "uid not found" (ppr uid)- Just ui ->- let depends = unitDepends ui- home_depends = Set.fromList depends `Set.intersection` home_id_set- other_depends = Set.fromList depends `Set.difference` home_id_set- in- -- Case 1: The unit directly depends on a home_id- if not (null home_depends)- then- let res = foldMap (loop . (from_uid,)) other_depends- in Set.insert uid res- -- Case 2: Check the rest of the dependencies, and then see if any of them depended on- else- let res = foldMap (loop . (from_uid,)) other_depends- in- if not (Set.null res)- then Set.insert uid res- else res++ graph :: Graph (Node UnitId UnitId)+ graph = graphFromEdgedVerticesUniq graphNodes++ -- downwards closure of graph+ downwards_closure+ = graphFromEdgedVerticesUniq [ DigraphNode uid uid (Set.toList deps)+ | (uid, deps) <- M.toList (allReachable graph node_key)]++ inverse_closure = transposeG downwards_closure++ upwards_closure = Set.fromList $ map node_key $ reachablesG inverse_closure [DigraphNode uid uid [] | uid <- Set.toList home_id_set]++ all_unit_direct_deps :: UniqMap UnitId (Set.Set UnitId)+ all_unit_direct_deps+ = unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue+ where+ go rest this this_uis =+ plusUniqMap_C Set.union+ (addToUniqMap_C Set.union external_depends this (Set.fromList $ this_deps))+ rest+ where+ external_depends = mapUniqMap (Set.fromList . unitDepends) (unitInfoMap this_units)+ this_units = homeUnitEnv_units this_uis+ this_deps = [ toUnitId unit | (unit,Just _) <- explicitUnits this_units]++ graphNodes :: [Node UnitId UnitId]+ graphNodes = go Set.empty home_id_set+ where+ go done todo+ = case Set.minView todo of+ Nothing -> []+ Just (uid, todo')+ | Set.member uid done -> go done todo'+ | otherwise -> case lookupUniqMap all_unit_direct_deps uid of+ Nothing -> pprPanic "uid not found" (ppr (uid, all_unit_direct_deps))+ Just depends ->+ let todo'' = (depends Set.\\ done) `Set.union` todo'+ in DigraphNode uid uid (Set.toList depends) : go (Set.insert uid done) todo'' -- | Update the every ModSummary that is depended on -- by a module that needs template haskell. We enable codegen to
GHC/Driver/Pipeline/Execute.hs view
@@ -999,7 +999,11 @@ attrs :: String attrs = intercalate "," $ mattr- ++ ["+sse42" | isSse4_2Enabled dflags ]+ ++ ["+sse4.2" | isSse4_2Enabled dflags ]+ ++ ["+popcnt" | isSse4_2Enabled dflags ]+ -- LLVM gates POPCNT instructions behind the popcnt flag,+ -- while the GHC NCG (as well as GCC, Clang) gates it+ -- behind SSE4.2 instead. ++ ["+sse2" | isSse2Enabled platform ] ++ ["+sse" | isSseEnabled platform ] ++ ["+avx512f" | isAvx512fEnabled dflags ]@@ -1075,14 +1079,18 @@ The command used for object linking is set using the -pgmlm and -optlm command-line options. -Sadly, the LLD linker that we use on Windows does not support the `-r` flag-needed to support object merging (see #21068). For this reason on Windows we do-not support GHCi objects. To deal with foreign stubs we build a static archive-of all of a module's object files instead merging them. Consequently, we can-end up producing `.o` files which are in fact static archives. However,-toolchains generally don't have a problem with this as they use file headers,-not the filename, to determine the nature of inputs.+However, `ld -r` is broken in some cases: + * The LLD linker that we use on Windows does not support the `-r`+ flag needed to support object merging (see #21068). For this reason+ on Windows we do not support GHCi objects.++In these cases, we bundle a module's own object file with its foreign+stub's object file, instead of merging them. Consequently, we can end+up producing `.o` files which are in fact static archives. This can+only work if `ar -L` is supported, so the archive `.o` files can be+properly added to the final static library.+ Note that this has somewhat non-obvious consequences when producing initializers and finalizers. See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini for details.@@ -1107,7 +1115,7 @@ -- | See Note [Object merging]. joinObjectFiles :: HscEnv -> [FilePath] -> FilePath -> IO () joinObjectFiles hsc_env o_files output_fn- | can_merge_objs && not dashLSupported = do+ | can_merge_objs = do let toolSettings' = toolSettings dflags ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings' ld_r args = GHC.SysTools.runMergeObjects (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) (
GHC/Driver/Plugins.hs view
@@ -405,12 +405,12 @@ loadExternalPluginLib path = do -- load library loadDLL path >>= \case- Just errmsg -> pprPanic "loadExternalPluginLib"- (vcat [ text "Can't load plugin library"- , text " Library path: " <> text path- , text " Error : " <> text errmsg- ])- Nothing -> do+ Left errmsg -> pprPanic "loadExternalPluginLib"+ (vcat [ text "Can't load plugin library"+ , text " Library path: " <> text path+ , text " Error : " <> text errmsg+ ])+ Right _ -> do -- resolve objects resolveObjs >>= \case True -> return ()
GHC/HsToCore/Foreign/C.hs view
@@ -401,17 +401,11 @@ Int -- total size of arguments ) mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc- = ( header_bits+ =+ ( header_bits , CStub body [] [] , type_string,- sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args- -- NB. the calculation here isn't strictly speaking correct.- -- We have a primitive Haskell type (eg. Int#, Double#), and- -- we want to know the size, when passed on the C stack, of- -- the associated C type (eg. HsInt, HsDouble). We don't have- -- this information to hand, but we know what GHC's conventions- -- are for passing around the primitive Haskell types, so we- -- use that instead. I hope the two coincide --SDM+ aug_arg_size ) where platform = targetPlatform dflags@@ -450,6 +444,19 @@ | isNothing maybe_target = stable_ptr_arg : insertRetAddr platform cc arg_info | otherwise = arg_info + aug_arg_size = sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info]+ -- NB. the calculation here isn't strictly speaking correct.+ -- We have a primitive Haskell type (eg. Int#, Double#), and+ -- we want to know the size, when passed on the C stack, of+ -- the associated C type (eg. HsInt, HsDouble). We don't have+ -- this information to hand, but we know what GHC's conventions+ -- are for passing around the primitive Haskell types, so we+ -- use that instead. I hope the two coincide --SDM+ -- AK: This seems just wrong, the code here uses widthInBytes, but when+ -- we pass args on the haskell stack we always extend to multiples of 8+ -- to my knowledge. Not sure if it matters though so I won't touch this+ -- for now.+ stable_ptr_arg = (text "the_stableptr", text "StgStablePtr", undefined, typeCmmType platform (mkStablePtrPrimTy alphaTy))@@ -605,8 +612,11 @@ -> [(SDoc, SDoc, Type, CmmType)] go 6 args = ret_addr_arg platform : args go n (arg@(_,_,_,rep):args)- | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args- | otherwise = arg : go n args+ -- Int type fitting into int register+ | (isBitsType rep && typeWidth rep <= W64 || isGcPtrType rep)+ = arg : go (n+1) args+ | otherwise+ = arg : go n args go _ [] = [] in go 0 args _ ->
GHC/Iface/Recomp/Flags.hs view
@@ -70,7 +70,10 @@ -- Other flags which affect code generation codegen = map (`gopt` dflags) (EnumSet.toList codeGenFlags) - flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, codegen, debugLevel, callerCcFilters))+ -- Did we include core for all bindings?+ fat_iface = gopt Opt_WriteIfSimplifiedCore dflags++ flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, codegen, debugLevel, callerCcFilters, fat_iface)) in -- pprTrace "flags" (ppr flags) $ computeFingerprint nameio flags
GHC/Iface/Tidy.hs view
@@ -615,8 +615,11 @@ getTyConImplicitBinds :: TyCon -> [CoreBind] getTyConImplicitBinds tc- | isNewTyCon tc = [] -- See Note [Compulsory newtype unfolding] in GHC.Types.Id.Make- | otherwise = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc))+ | isDataTyCon tc = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc))+ | otherwise = []+ -- The 'otherwise' includes family TyCons of course, but also (less obviously)+ -- * Newtypes: see Note [Compulsory newtype unfolding] in GHC.Types.Id.Make+ -- * type data: we don't want any code for type-only stuff (#24620) getClassImplicitBinds :: Class -> [CoreBind] getClassImplicitBinds cls
GHC/Linker/Loader.hs view
@@ -56,6 +56,7 @@ import GHC.Runtime.Interpreter import GHCi.RemoteTypes import GHC.Iface.Load+import GHCi.Message (LoadedDLL) import GHC.ByteCode.Linker import GHC.ByteCode.Asm@@ -145,7 +146,7 @@ -- -- The linker's symbol table is populated with RTS symbols using an -- explicit list. See rts/Linker.c for details.- where init_pkgs = unitUDFM rtsUnitId (LoadedPkgInfo rtsUnitId [] [] emptyUniqDSet)+ where init_pkgs = unitUDFM rtsUnitId (LoadedPkgInfo rtsUnitId [] [] [] emptyUniqDSet) extendLoadedEnv :: Interp -> [(Name,ForeignHValue)] -> IO () extendLoadedEnv interp new_bindings =@@ -194,8 +195,8 @@ -> SrcSpan -> [Module] -> IO (LoaderState, SuccessFlag, [Linkable], PkgsLoaded) -- ^ returns the set of linkables required+-- When called, the loader state must have been initialized (see `initLoaderState`) loadDependencies interp hsc_env pls span needed_mods = do--- initLoaderState (hsc_dflags hsc_env) dl let opts = initLinkDepsOpts hsc_env -- Find what packages and linkables are required@@ -485,25 +486,25 @@ DLL dll_unadorned -> do maybe_errstr <- loadDLL interp (platformSOName platform dll_unadorned) case maybe_errstr of- Nothing -> maybePutStrLn logger "done"- Just mm | platformOS platform /= OSDarwin ->+ Right _ -> maybePutStrLn logger "done"+ Left mm | platformOS platform /= OSDarwin -> preloadFailed mm lib_paths lib_spec- Just mm | otherwise -> do+ Left mm | otherwise -> do -- As a backup, on Darwin, try to also load a .so file -- since (apparently) some things install that way - see -- ticket #8770. let libfile = ("lib" ++ dll_unadorned) <.> "so" err2 <- loadDLL interp libfile case err2 of- Nothing -> maybePutStrLn logger "done"- Just _ -> preloadFailed mm lib_paths lib_spec+ Right _ -> maybePutStrLn logger "done"+ Left _ -> preloadFailed mm lib_paths lib_spec return pls DLLPath dll_path -> do do maybe_errstr <- loadDLL interp dll_path case maybe_errstr of- Nothing -> maybePutStrLn logger "done"- Just mm -> preloadFailed mm lib_paths lib_spec+ Right _ -> maybePutStrLn logger "done"+ Left mm -> preloadFailed mm lib_paths lib_spec return pls Framework framework ->@@ -588,7 +589,7 @@ let le = linker_env pls nobreakarray = error "no break array" bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)]- resolved <- linkBCO interp le bco_ix nobreakarray root_ul_bco+ resolved <- linkBCO interp (pkgs_loaded pls) le bco_ix nobreakarray root_ul_bco [root_hvref] <- createBCOs interp [resolved] fhv <- mkFinalizedHValue interp root_hvref return (pls, fhv)@@ -651,7 +652,7 @@ , addr_env = plusNameEnv (addr_env le) bc_strs } -- Link the necessary packages and linkables- new_bindings <- linkSomeBCOs interp le2 [cbc]+ new_bindings <- linkSomeBCOs interp (pkgs_loaded pls) le2 [cbc] nms_fhvs <- makeForeignNamedHValueRefs interp new_bindings let ce2 = extendClosureEnv (closure_env le2) nms_fhvs !pls2 = pls { linker_env = le2 { closure_env = ce2 } }@@ -832,8 +833,8 @@ changeTempFilesLifetime tmpfs TFL_GhcSession [soFile] m <- loadDLL interp soFile case m of- Nothing -> return $! pls { temp_sos = (libPath, libName) : temp_sos }- Just err -> linkFail msg err+ Right _ -> return $! pls { temp_sos = (libPath, libName) : temp_sos }+ Left err -> linkFail msg err where msg = "GHC.Linker.Loader.dynLoadObjs: Loading temp shared object failed" @@ -873,7 +874,7 @@ ae2 = foldr plusNameEnv (addr_env le1) (map bc_strs cbcs) le2 = le1 { itbl_env = ie2, addr_env = ae2 } - names_and_refs <- linkSomeBCOs interp le2 cbcs+ names_and_refs <- linkSomeBCOs interp (pkgs_loaded pls) le2 cbcs -- We only want to add the external ones to the ClosureEnv let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs@@ -888,6 +889,7 @@ -- Link a bunch of BCOs and return references to their values linkSomeBCOs :: Interp+ -> PkgsLoaded -> LinkerEnv -> [CompiledByteCode] -> IO [(Name,HValueRef)]@@ -895,7 +897,7 @@ -- the incoming unlinked BCOs. Each gives the -- value of the corresponding unlinked BCO -linkSomeBCOs interp le mods = foldr fun do_link mods []+linkSomeBCOs interp pkgs_loaded le mods = foldr fun do_link mods [] where fun CompiledByteCode{..} inner accum = case bc_breaks of@@ -908,7 +910,7 @@ let flat = [ (breakarray, bco) | (breakarray, bcos) <- mods, bco <- bcos ] names = map (unlinkedBCOName . snd) flat bco_ix = mkNameEnv (zip names [0..])- resolved <- sequence [ linkBCO interp le bco_ix breakarray bco+ resolved <- sequence [ linkBCO interp pkgs_loaded le bco_ix breakarray bco | (breakarray, bco) <- flat ] hvrefs <- createBCOs interp resolved return (zip names hvrefs)@@ -1071,18 +1073,18 @@ -- Link dependents first ; pkgs' <- link pkgs deps -- Now link the package itself- ; (hs_cls, extra_cls) <- loadPackage interp hsc_env pkg_cfg+ ; (hs_cls, extra_cls, loaded_dlls) <- loadPackage interp hsc_env pkg_cfg ; let trans_deps = unionManyUniqDSets [ addOneToUniqDSet (loaded_pkg_trans_deps loaded_pkg_info) dep_pkg | dep_pkg <- deps , Just loaded_pkg_info <- pure (lookupUDFM pkgs' dep_pkg) ]- ; return (addToUDFM pkgs' new_pkg (LoadedPkgInfo new_pkg hs_cls extra_cls trans_deps)) }+ ; return (addToUDFM pkgs' new_pkg (LoadedPkgInfo new_pkg hs_cls extra_cls loaded_dlls trans_deps)) } | otherwise = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg))) -loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ([LibrarySpec], [LibrarySpec])+loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ([LibrarySpec], [LibrarySpec], [RemotePtr LoadedDLL]) loadPackage interp hsc_env pkg = do let dflags = hsc_dflags hsc_env@@ -1124,7 +1126,9 @@ let classifieds = hs_classifieds ++ extra_classifieds -- Complication: all the .so's must be loaded before any of the .o's.- let known_dlls = [ dll | DLLPath dll <- classifieds ]+ let known_hs_dlls = [ dll | DLLPath dll <- hs_classifieds ]+ known_extra_dlls = [ dll | DLLPath dll <- extra_classifieds ]+ known_dlls = known_hs_dlls ++ known_extra_dlls #if defined(CAN_LOAD_DLL) dlls = [ dll | DLL dll <- classifieds ] #endif@@ -1145,10 +1149,13 @@ loadFrameworks interp platform pkg -- See Note [Crash early load_dyn and locateLib] -- Crash early if can't load any of `known_dlls`- mapM_ (load_dyn interp hsc_env True) known_dlls+ mapM_ (load_dyn interp hsc_env True) known_extra_dlls+ loaded_dlls <- mapMaybeM (load_dyn interp hsc_env True) known_hs_dlls -- For remaining `dlls` crash early only when there is surely -- no package's DLL around ... (not is_dyn) mapM_ (load_dyn interp hsc_env (not is_dyn) . platformSOName platform) dlls+#else+ let loaded_dlls = [] #endif -- After loading all the DLLs, we can load the static objects. -- Ordering isn't important here, because we do one final link@@ -1168,7 +1175,7 @@ if succeeded ok then do maybePutStrLn logger "done."- return (hs_classifieds, extra_classifieds)+ return (hs_classifieds, extra_classifieds, loaded_dlls) else let errmsg = text "unable to load unit `" <> pprUnitInfoForUser pkg <> text "'" in throwGhcExceptionIO (InstallationError (showSDoc dflags errmsg))@@ -1221,19 +1228,20 @@ -- can be passed directly to loadDLL. They are either fully-qualified -- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so"). In the latter case, -- loadDLL is going to search the system paths to find the library.-load_dyn :: Interp -> HscEnv -> Bool -> FilePath -> IO ()+load_dyn :: Interp -> HscEnv -> Bool -> FilePath -> IO (Maybe (RemotePtr LoadedDLL)) load_dyn interp hsc_env crash_early dll = do r <- loadDLL interp dll case r of- Nothing -> return ()- Just err ->+ Right loaded_dll -> pure (Just loaded_dll)+ Left err -> if crash_early then cmdLineErrorIO err- else+ else do when (diag_wopt Opt_WarnMissedExtraSharedLib diag_opts) $ logMsg logger (mkMCDiagnostic diag_opts (WarningWithFlag Opt_WarnMissedExtraSharedLib) Nothing) noSrcSpan $ withPprStyle defaultUserStyle (note err)+ pure Nothing where diag_opts = initDiagOpts (hsc_dflags hsc_env) logger = hsc_logger hsc_env
GHC/Linker/MacOS.hs view
@@ -172,6 +172,6 @@ findLoadDLL (p:ps) errs = do { dll <- loadDLL interp (p </> fwk_file) ; case dll of- Nothing -> return Nothing- Just err -> findLoadDLL ps ((p ++ ": " ++ err):errs)+ Right _ -> return Nothing+ Left err -> findLoadDLL ps ((p ++ ": " ++ err):errs) }
GHC/Linker/Types.hs view
@@ -40,7 +40,8 @@ import GHC.Unit ( UnitId, Module ) import GHC.ByteCode.Types ( ItblEnv, AddrEnv, CompiledByteCode ) import GHC.Fingerprint.Type ( Fingerprint )-import GHCi.RemoteTypes ( ForeignHValue )+import GHCi.RemoteTypes ( ForeignHValue, RemotePtr )+import GHCi.Message ( LoadedDLL ) import GHC.Types.Var ( Id ) import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnvList, filterNameEnv )@@ -75,6 +76,53 @@ The LinkerEnv maps Names to actual closures (for interpreted code only), for use during linking.++Note [Looking up symbols in the relevant objects]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In #23415, we determined that a lot of time (>10s, or even up to >35s!) was+being spent on dynamically loading symbols before actually interpreting code+when `:main` was run in GHCi. The root cause was that for each symbol we wanted+to lookup, we would traverse the list of loaded objects and try find the symbol+in each of them with dlsym (i.e. looking up a symbol was, worst case, linear in+the amount of loaded objects).++To drastically improve load time (from +-38 seconds down to +-2s), we now:++1. For every of the native objects loaded for a given unit, store the handles returned by `dlopen`.+ - In `pkgs_loaded` of the `LoaderState`, which maps `UnitId`s to+ `LoadedPkgInfo`s, where the handles live in its field `loaded_pkg_hs_dlls`.++2. When looking up a Name (e.g. `lookupHsSymbol`), find that name's `UnitId` in+ the `pkgs_loaded` mapping,++3. And only look for the symbol (with `dlsym`) on the /handles relevant to that+ unit/, rather than in every loaded object.++Note [Symbols may not be found in pkgs_loaded]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Currently the `pkgs_loaded` mapping only contains the dynamic objects+associated with loaded units. Symbols defined in a static object (e.g. from a+statically-linked Haskell library) are found via the generic `lookupSymbol`+function call by `lookupHsSymbol` when the symbol is not found in any of the+dynamic objects of `pkgs_loaded`.++The rationale here is two-fold:++ * we have only observed major link-time issues in dynamic linking; lookups in+ the RTS linker's static symbol table seem to be fast enough++ * allowing symbol lookups restricted to a single ObjectCode would require the+ maintenance of a symbol table per `ObjectCode`, which would introduce time and+ space overhead++This fallback is further needed because we don't look in the haskell objects+loaded for the home units (see the call to `loadModuleLinkables` in+`loadDependencies`, as opposed to the call to `loadPackages'` in the same+function which updates `pkgs_loaded`). We should ultimately keep track of the+objects loaded (probably in `objs_loaded`, for which `LinkableSet` is a bit+unsatisfactory, see a suggestion in 51c5c4eb1f2a33e4dc88e6a37b7b7c135234ce9b)+and be able to lookup symbols specifically in them too (similarly to+`lookupSymbolInDLL`). -} newtype Loader = Loader { loader_state :: MVar (Maybe LoaderState) }@@ -146,11 +194,13 @@ { loaded_pkg_uid :: !UnitId , loaded_pkg_hs_objs :: ![LibrarySpec] , loaded_pkg_non_hs_objs :: ![LibrarySpec]+ , loaded_pkg_hs_dlls :: ![RemotePtr LoadedDLL]+ -- ^ See Note [Looking up symbols in the relevant objects] , loaded_pkg_trans_deps :: UniqDSet UnitId } instance Outputable LoadedPkgInfo where- ppr (LoadedPkgInfo uid hs_objs non_hs_objs trans_deps) =+ ppr (LoadedPkgInfo uid hs_objs non_hs_objs _ trans_deps) = vcat [ppr uid , ppr hs_objs , ppr non_hs_objs@@ -159,10 +209,10 @@ -- | Information we can use to dynamically link modules into the compiler data Linkable = LM {- linkableTime :: !UTCTime, -- ^ Time at which this linkable was built+ linkableTime :: !UTCTime, -- ^ Time at which this linkable was built -- (i.e. when the bytecodes were produced, -- or the mod date on the files)- linkableModule :: !Module, -- ^ The linkable module itself+ linkableModule :: !Module, -- ^ The linkable module itself linkableUnlinked :: [Unlinked] -- ^ Those files and chunks of code we have yet to link. --
GHC/Parser/HaddockLex.hs view
@@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}-{-# LINE 1 "_build/source-dist/ghc-9.8.2-src/ghc-9.8.2/compiler/GHC/Parser/HaddockLex.x" #-}+{-# LINE 1 "_build/source-dist/ghc-9.8.3-src/ghc-9.8.3/compiler/GHC/Parser/HaddockLex.x" #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -funbox-strict-fields #-}@@ -109,7 +109,7 @@ , (0,alex_action_1) ] -{-# LINE 86 "_build/source-dist/ghc-9.8.2-src/ghc-9.8.2/compiler/GHC/Parser/HaddockLex.x" #-}+{-# LINE 86 "_build/source-dist/ghc-9.8.3-src/ghc-9.8.3/compiler/GHC/Parser/HaddockLex.x" #-} data AlexInput = AlexInput { alexInput_position :: !RealSrcLoc , alexInput_string :: !ByteString
GHC/Parser/Lexer.hs view
@@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}-{-# LINE 43 "_build/source-dist/ghc-9.8.2-src/ghc-9.8.2/compiler/GHC/Parser/Lexer.x" #-}+{-# LINE 43 "_build/source-dist/ghc-9.8.3-src/ghc-9.8.3/compiler/GHC/Parser/Lexer.x" #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-}@@ -789,7 +789,7 @@ , (0,alex_action_101) ] -{-# LINE 794 "_build/source-dist/ghc-9.8.2-src/ghc-9.8.2/compiler/GHC/Parser/Lexer.x" #-}+{-# LINE 794 "_build/source-dist/ghc-9.8.3-src/ghc-9.8.3/compiler/GHC/Parser/Lexer.x" #-} -- Operator whitespace occurrence. See Note [Whitespace-sensitive operator parsing]. data OpWs = OpWsPrefix -- a !b
GHC/Rename/Module.hs view
@@ -1970,6 +1970,8 @@ is never used (invariant (I1)), so it barely makes sense to talk about the worker. A `type data` constructor only shows up in types, where it appears as a TyCon, specifically a PromotedDataCon -- no Id in sight.+ See #24620 for an example of what happens if you accidentally include+ a wrapper. See `wrapped_reqd` in GHC.Types.Id.Make.mkDataConRep` for the place where this check is implemented.
GHC/Runtime/Eval.hs view
@@ -626,8 +626,10 @@ -- saved/restored, but not the linker state. See #1743, test break026. mkNewId :: OccName -> Type -> Id -> IO Id mkNewId occ ty old_id- = do { name <- newInteractiveBinder hsc_env occ (getSrcSpan old_id)- ; return (Id.mkVanillaGlobalWithInfo name ty (idInfo old_id)) }+ = do { name <- newInteractiveBinder hsc_env (mkVarOccFS (occNameFS occ)) (getSrcSpan old_id)+ -- NB: use variable namespace.+ -- Don't use record field namespaces, lest we cause #25109.+ ; return $ Id.mkVanillaGlobalWithInfo name ty (idInfo old_id) } newTyVars :: UniqSupply -> [TcTyVar] -> Subst -- Similarly, clone the type variables mentioned in the types
GHC/Runtime/Interpreter.hs view
@@ -37,6 +37,7 @@ -- * The object-code linker , initObjLinker , lookupSymbol+ , lookupSymbolInDLL , lookupClosure , loadDLL , loadArchive@@ -158,22 +159,22 @@ - implementation of Template Haskell (GHCi.TH) - a few other things needed to run interpreted code -- top-level iserv directory, containing the codefor the external- server. This is a fairly simple wrapper, most of the functionality+- top-level iserv directory, containing the code for the external+ server. This is a fairly simple wrapper, most of the functionality is provided by modules in libraries/ghci. - This module which provides the interface to the server used by the rest of GHC. -GHC works with and without -fexternal-interpreter. With the flag, all-interpreted code is run by the iserv binary. Without the flag,+GHC works with and without -fexternal-interpreter. With the flag, all+interpreted code is run by the iserv binary. Without the flag, interpreted code is run in the same process as GHC. Things that do not work with -fexternal-interpreter ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ dynCompileExpr cannot work, because we have no way to run code of an-unknown type in the remote process. This API fails with an error+unknown type in the remote process. This API fails with an error message if it is used with -fexternal-interpreter. Other Notes on Remote GHCi@@ -462,7 +463,7 @@ -- making cross-process LookupSymbol calls, so I added a GHC-side -- cache which sped things up quite a lot. We have to be careful -- to purge this cache when unloading code though.- cache <- readMVar (instLookupSymbolCache inst)+ cache <- readMVar (interpLookupSymbolCache interp) case lookupUFM cache str of Just p -> return (Just p) Nothing -> do@@ -473,35 +474,72 @@ Just r -> do let p = fromRemotePtr r cache' = addToUFM cache str p- modifyMVar_ (instLookupSymbolCache inst) (const (pure cache'))+ modifyMVar_ (interpLookupSymbolCache interp) (const (pure cache')) return (Just p) ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str) +lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> FastString -> IO (Maybe (Ptr ()))+lookupSymbolInDLL interp dll str = withSymbolCache interp str $+ case interpInstance interp of+#if defined(HAVE_INTERNAL_INTERPRETER)+ InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (unpackFS str))+#endif+ ExternalInterp ext -> case ext of+ ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do+ uninterruptibleMask_ $+ sendMessage inst (LookupSymbolInDLL dll (unpackFS str))+ ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)+ lookupClosure :: Interp -> String -> IO (Maybe HValueRef) lookupClosure interp str = interpCmd interp (LookupClosure str) +-- | 'withSymbolCache' tries to find a symbol in the 'interpLookupSymbolCache'+-- which maps symbols to the address where they are loaded.+-- When there's a cache hit we simply return the cached address, when there is+-- a miss we run the action which determines the symbol's address and populate+-- the cache with the answer.+withSymbolCache :: Interp+ -> FastString+ -- ^ The symbol we are looking up in the cache+ -> IO (Maybe (Ptr ()))+ -- ^ An action which determines the address of the symbol we+ -- are looking up in the cache, which is run if there is a+ -- cache miss. The result will be cached.+ -> IO (Maybe (Ptr ()))+withSymbolCache interp str determine_addr = do++ -- Profiling of GHCi showed a lot of time and allocation spent+ -- making cross-process LookupSymbol calls, so I added a GHC-side+ -- cache which sped things up quite a lot. We have to be careful+ -- to purge this cache when unloading code though.+ --+ -- The analysis in #23415 further showed this cache should also benefit the+ -- internal interpreter's loading times, and needn't be used by the external+ -- interpreter only.+ cache <- readMVar (interpLookupSymbolCache interp)+ case lookupUFM cache str of+ Just p -> return (Just p)+ Nothing -> do++ maddr <- determine_addr+ case maddr of+ Nothing -> return Nothing+ Just p -> do+ let upd_cache cache' = addToUFM cache' str p+ modifyMVar_ (interpLookupSymbolCache interp) (pure . upd_cache)+ return (Just p)+ purgeLookupSymbolCache :: Interp -> IO ()-purgeLookupSymbolCache interp = case interpInstance interp of-#if defined(HAVE_INTERNAL_INTERPRETER)- InternalInterp -> pure ()-#endif- ExternalInterp ext -> withExtInterpMaybe ext $ \case- Nothing -> pure () -- interpreter stopped, nothing to do- Just inst -> modifyMVar_ (instLookupSymbolCache inst) (const (pure emptyUFM))+purgeLookupSymbolCache interp = modifyMVar_ (interpLookupSymbolCache interp) (const (pure emptyUFM)) -- | loadDLL loads a dynamic library using the OS's native linker -- (i.e. dlopen() on Unix, LoadLibrary() on Windows). It takes either -- an absolute pathname to the file, or a relative filename -- (e.g. "libfoo.so" or "foo.dll"). In the latter case, loadDLL -- searches the standard locations for the appropriate library.------ Returns:------ Nothing => success--- Just err_msg => failure-loadDLL :: Interp -> String -> IO (Maybe String)+loadDLL :: Interp -> String -> IO (Either String (RemotePtr LoadedDLL)) loadDLL interp str = interpCmd interp (LoadDLL str) loadArchive :: Interp -> String -> IO ()@@ -560,11 +598,9 @@ } pending_frees <- newMVar []- lookup_cache <- newMVar emptyUFM let inst = ExtInterpInstance { instProcess = process , instPendingFrees = pending_frees- , instLookupSymbolCache = lookup_cache , instExtra = () } pure inst
GHC/Runtime/Interpreter/JS.hs view
@@ -41,7 +41,6 @@ import GHC.Utils.Error (logInfo) import GHC.Utils.Outputable (text) import GHC.Data.FastString-import GHC.Types.Unique.FM import Control.Concurrent import Control.Monad@@ -178,11 +177,9 @@ } pending_frees <- newMVar []- lookup_cache <- newMVar emptyUFM let inst = ExtInterpInstance { instProcess = proc , instPendingFrees = pending_frees- , instLookupSymbolCache = lookup_cache , instExtra = extra }
GHC/Runtime/Interpreter/Types.hs view
@@ -51,6 +51,9 @@ , interpLoader :: !Loader -- ^ Interpreter loader++ , interpLookupSymbolCache :: !(MVar (UniqFM FastString (Ptr ())))+ -- ^ LookupSymbol cache } data InterpInstance@@ -107,9 +110,6 @@ -- ^ Values that need to be freed before the next command is sent. -- Finalizers for ForeignRefs can append values to this list -- asynchronously.-- , instLookupSymbolCache :: !(MVar (UniqFM FastString (Ptr ())))- -- ^ LookupSymbol cache , instExtra :: !c -- ^ Instance specific extra fields
GHC/Runtime/Utils.hs view
@@ -29,7 +29,7 @@ c__close :: CInt -> IO CInt foreign import ccall unsafe "io.h _get_osfhandle"- _get_osfhandle :: CInt -> IO CInt+ _get_osfhandle :: CInt -> IO CIntPtr runWithPipesPOSIX :: (CreateProcess -> IO ProcessHandle) -> FilePath -> [String] -> [String] -> IO (ProcessHandle, Handle, Handle)
GHC/Settings/IO.hs view
@@ -16,9 +16,11 @@ import GHC.Utils.Fingerprint import GHC.Platform import GHC.Utils.Panic+import GHC.ResponseFile import GHC.Settings import GHC.SysTools.BaseDir +import Data.Char import Control.Monad.Trans.Except import Control.Monad.IO.Class import qualified Data.Map as Map@@ -72,9 +74,13 @@ -- just partially applying those functions and throwing 'Left's; they're -- written in a very portable style to keep ghc-boot light. let getSetting key = either pgmError pure $- getRawFilePathSetting top_dir settingsFile mySettings key+ -- Escape the 'top_dir', to make sure we don't accidentally introduce an+ -- unescaped space+ getRawFilePathSetting (escapeArg top_dir) settingsFile mySettings key getToolSetting :: String -> ExceptT SettingsError m String- getToolSetting key = expandToolDir useInplaceMinGW mtool_dir <$> getSetting key+ -- Escape the 'mtool_dir', to make sure we don't accidentally introduce+ -- an unescaped space+ getToolSetting key = expandToolDir useInplaceMinGW (fmap escapeArg mtool_dir) <$> getSetting key targetPlatformString <- getSetting "target platform string" cc_prog <- getToolSetting "C compiler command" cxx_prog <- getToolSetting "C++ compiler command"@@ -89,9 +95,9 @@ let unreg_cc_args = if platformUnregisterised platform then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"] else []- cpp_args = map Option (words cpp_args_str)- cc_args = words cc_args_str ++ unreg_cc_args- cxx_args = words cxx_args_str+ cpp_args = map Option (unescapeArgs cpp_args_str)+ cc_args = unescapeArgs cc_args_str ++ unreg_cc_args+ cxx_args = unescapeArgs cxx_args_str -- The extra flags we need to pass gcc when we invoke it to compile .hc code. --@@ -138,12 +144,12 @@ let as_prog = cc_prog as_args = map Option cc_args ld_prog = cc_prog- ld_args = map Option (cc_args ++ words cc_link_args_str)+ ld_args = map Option (cc_args ++ unescapeArgs cc_link_args_str) ld_r_prog <- getToolSetting "Merge objects command" ld_r_args <- getToolSetting "Merge objects flags" let ld_r | null ld_r_prog = Nothing- | otherwise = Just (ld_r_prog, map Option $ words ld_r_args)+ | otherwise = Just (ld_r_prog, map Option $ unescapeArgs ld_r_args) llvmTarget <- getSetting "LLVM target" @@ -265,3 +271,19 @@ , platformHasLibm = targetHasLibm , platform_constants = Nothing -- will be filled later when loading (or building) the RTS unit }++-- ----------------------------------------------------------------------------+-- Escape Args helpers+-- ----------------------------------------------------------------------------++-- | Just like 'GHC.ResponseFile.escapeArg', but it is not exposed from base.+escapeArg :: String -> String+escapeArg = reverse . foldl' escape []++escape :: String -> Char -> String+escape cs c+ | isSpace c+ || '\\' == c+ || '\'' == c+ || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result+ | otherwise = c:cs
GHC/Stg/Subst.hs view
@@ -55,7 +55,7 @@ -- | Substitutes an occurrence of an identifier for its counterpart recorded -- in the 'Subst'.-lookupIdSubst :: HasCallStack => Id -> Subst -> Id+lookupIdSubst :: HasDebugCallStack => Id -> Subst -> Id lookupIdSubst id (Subst in_scope env) | not (isLocalId id) = id | Just id' <- lookupVarEnv env id = id'@@ -65,7 +65,7 @@ -- | Substitutes an occurrence of an identifier for its counterpart recorded -- in the 'Subst'. Does not generate a debug warning if the identifier to -- to substitute wasn't in scope.-noWarnLookupIdSubst :: HasCallStack => Id -> Subst -> Id+noWarnLookupIdSubst :: HasDebugCallStack => Id -> Subst -> Id noWarnLookupIdSubst id (Subst in_scope env) | not (isLocalId id) = id | Just id' <- lookupVarEnv env id = id'
GHC/StgToCmm/Prim.hs view
@@ -2074,8 +2074,8 @@ -> CmmType -- ^ index type -> AlignmentSpec alignmentFromTypes ty idx_ty- | typeWidth ty < typeWidth idx_ty = NaturallyAligned- | otherwise = Unaligned+ | typeWidth ty <= typeWidth idx_ty = NaturallyAligned+ | otherwise = Unaligned doIndexOffAddrOp :: Maybe MachOp -> CmmType
GHC/StgToCmm/Ticky.hs view
@@ -809,7 +809,7 @@ bumpTickyAllocd :: CLabel -> Int -> FCode () bumpTickyAllocd lbl bytes = do platform <- getPlatform- bumpTickyLitBy (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_entry_count (platformConstants platform))) bytes+ bumpTickyLitBy (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_allocd (platformConstants platform))) bytes bumpTickyTagSkip :: CLabel -> FCode () bumpTickyTagSkip lbl = do
GHC/StgToJS/Apply.hs view
@@ -44,7 +44,6 @@ import GHC.StgToJS.Stack import GHC.StgToJS.Ids -import GHC.Types.Literal import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.CostCentre@@ -58,7 +57,6 @@ import GHC.Core.DataCon import GHC.Core.Type hiding (typeSize) -import GHC.Utils.Encoding import GHC.Utils.Misc import GHC.Utils.Monad import GHC.Utils.Panic@@ -97,22 +95,6 @@ -> [StgArg] -> G (JStat, ExprResult) genApp ctx i args-- -- Case: unpackCStringAppend# "some string"# str- --- -- Generates h$appendToHsStringA(str, "some string"), which has a faster- -- decoding loop.- | [StgLitArg (LitString bs), x] <- args- , [top] <- concatMap typex_expr (ctxTarget ctx)- , getUnique i == unpackCStringAppendIdKey- , d <- utf8DecodeByteString bs- = do- prof <- csProf <$> getSettings- let profArg = if prof then [jCafCCS] else []- a <- genArg x- return ( top |= app "h$appendToHsStringA" (toJExpr d : a ++ profArg)- , ExprInline Nothing- ) -- let-no-escape | Just n <- ctxLneBindingStackSize ctx i
GHC/StgToJS/Expr.hs view
@@ -57,11 +57,13 @@ import GHC.Types.Id import GHC.Types.Unique.FM import GHC.Types.RepType+import GHC.Types.Literal import GHC.Stg.Syntax import GHC.Stg.Utils import GHC.Builtin.PrimOps+import GHC.Builtin.Names import GHC.Core import GHC.Core.TyCon@@ -70,6 +72,7 @@ import GHC.Core.Type hiding (typeSize) import GHC.Utils.Misc+import GHC.Utils.Encoding import GHC.Utils.Monad import GHC.Utils.Panic import GHC.Utils.Outputable (ppr, renderWithContext, defaultSDocContext)@@ -556,7 +559,37 @@ -> LiveVars -> G (JStat, ExprResult) genCase ctx bnd e at alts l- | snd (isInlineExpr (ctxEvaluatedIds ctx) e) = do+ -- For: unpackCStringAppend# "some string"# str+ -- Generate: h$appendToHsStringA(str, "some string")+ --+ -- The latter has a faster decoding loop.+ --+ -- Since #23270 and 7e0c8b3bab30, literals strings aren't STG atoms and we+ -- need to match the following instead:+ --+ -- case "some string"# of b {+ -- DEFAULT -> unpackCStringAppend# b str+ -- }+ --+ -- Wrinkle: it doesn't kick in when literals are floated out to the top level.+ --+ | StgLit (LitString bs) <- e+ , [GenStgAlt DEFAULT _ rhs] <- alts+ , StgApp i args <- rhs+ , getUnique i == unpackCStringAppendIdKey+ , [StgVarArg b',x] <- args+ , bnd == b'+ , d <- utf8DecodeByteString bs+ , [top] <- concatMap typex_expr (ctxTarget ctx)+ = do+ prof <- csProf <$> getSettings+ let profArg = if prof then [jCafCCS] else []+ a <- genArg x+ return ( top |= app "h$appendToHsStringA" (toJExpr d : a ++ profArg)+ , ExprInline Nothing+ )++ | snd $ isInlineExpr (ctxEvaluatedIds ctx) e = do bndi <- identsForId bnd let ctx' = ctxSetTop bnd $ ctxSetTarget (assocIdExprs bnd (map toJExpr bndi))
GHC/StgToJS/Literal.hs view
@@ -20,6 +20,7 @@ import GHC.Data.FastString import GHC.Types.Literal import GHC.Types.Basic+import GHC.Types.RepType import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Outputable@@ -66,7 +67,28 @@ | otherwise -> return [ toJExpr (TxtI (mkRawSymbol True name)) , ValExpr (JInt 0) ]- LitRubbish {} -> return [ null_ ]+ LitRubbish _ rr_ty ->+ -- Generate appropriate rubbish literals, otherwise it might trip up the+ -- code generator when a primop is applied to a rubbish literal (see #24664)+ let reps = runtimeRepPrimRep (text "GHC.StgToJS.Literal.genLit") rr_ty+ rub = \case+ BoxedRep _ -> [ null_ ]+ AddrRep -> [ null_, ValExpr (JInt 0) ]+ WordRep -> [ ValExpr (JInt 0) ]+ Word8Rep -> [ ValExpr (JInt 0) ]+ Word16Rep -> [ ValExpr (JInt 0) ]+ Word32Rep -> [ ValExpr (JInt 0) ]+ Word64Rep -> [ ValExpr (JInt 0), ValExpr (JInt 0) ]+ IntRep -> [ ValExpr (JInt 0) ]+ Int8Rep -> [ ValExpr (JInt 0) ]+ Int16Rep -> [ ValExpr (JInt 0) ]+ Int32Rep -> [ ValExpr (JInt 0) ]+ Int64Rep -> [ ValExpr (JInt 0), ValExpr (JInt 0) ]+ DoubleRep -> [ ValExpr (JInt 0) ]+ FloatRep -> [ ValExpr (JInt 0) ]+ VoidRep -> panic "GHC.StgToJS.Literal.genLit: LitRubbish(VoidRep)"+ VecRep _ _ -> panic "GHC.StgToJS.Literal.genLit: VecRep unsupported"+ in return (concatMap rub reps) -- | generate a literal for the static init tables genStaticLit :: Literal -> G [StaticLit]@@ -92,7 +114,25 @@ LitDouble r -> return [ DoubleLit . SaneDouble . r2d $ r ] LitLabel name _size fod -> return [ LabelLit (fod == IsFunction) (mkRawSymbol True name) , IntLit 0 ]- l -> pprPanic "genStaticLit" (ppr l)+ LitRubbish _ rep ->+ let prim_reps = runtimeRepPrimRep (text "GHC.StgToJS.Literal.genStaticLit") rep+ in case expectOnly "GHC.StgToJS.Literal.genStaticLit" prim_reps of -- Note [Post-unarisation invariants]+ BoxedRep _ -> pure [ NullLit ]+ AddrRep -> pure [ NullLit, IntLit 0 ]+ IntRep -> pure [ IntLit 0 ]+ Int8Rep -> pure [ IntLit 0 ]+ Int16Rep -> pure [ IntLit 0 ]+ Int32Rep -> pure [ IntLit 0 ]+ Int64Rep -> pure [ IntLit 0, IntLit 0 ]+ WordRep -> pure [ IntLit 0 ]+ Word8Rep -> pure [ IntLit 0 ]+ Word16Rep -> pure [ IntLit 0 ]+ Word32Rep -> pure [ IntLit 0 ]+ Word64Rep -> pure [ IntLit 0, IntLit 0 ]+ FloatRep -> pure [ DoubleLit (SaneDouble 0) ]+ DoubleRep -> pure [ DoubleLit (SaneDouble 0) ]+ VoidRep -> panic "GHC.StgToJS.Literal.getStaticLit: LitRubbish(VoidRep)"+ VecRep {} -> pprPanic "GHC.StgToJS.Literal.genStaticLit: LitRubbish(VecRep) isn't supported" (ppr rep) -- make an unsigned 32 bit number from this unsigned one, lower 32 bits toU32Expr :: Integer -> JExpr
GHC/SysTools/Cpp.hs view
@@ -203,11 +203,17 @@ -- | Find out path to @ghcversion.h@ file getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath getGhcVersionPathName dflags unit_env = do- candidates <- case ghcVersionFile dflags of- Just path -> return [path]- Nothing -> do- ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env [rtsUnitId])- return ((</> "ghcversion.h") <$> collectIncludeDirs ps)+ let candidates = case ghcVersionFile dflags of+ -- the user has provided an explicit `ghcversion.h` file to use.+ Just path -> [path]+ -- otherwise, try to find it in the rts' include-dirs.+ -- Note: only in the RTS include-dirs! not all preload units less we may+ -- use a wrong file. See #25106 where a globally installed+ -- /usr/include/ghcversion.h file was used instead of the one provided+ -- by the rts.+ Nothing -> case lookupUnitId (ue_units unit_env) rtsUnitId of+ Nothing -> []+ Just info -> (</> "ghcversion.h") <$> collectIncludeDirs [info] found <- filterM doesFileExist candidates case found of
GHC/Tc/Deriv/Generate.hs view
@@ -2466,7 +2466,7 @@ ] -- | Lookup `Type` in an association list.-assoc_ty_id :: HasCallStack => String -- The class involved+assoc_ty_id :: HasDebugCallStack => String -- The class involved -> [(Type,a)] -- The table -> Type -- The type -> a -- The result of the lookup
GHC/Tc/Deriv/Utils.hs view
@@ -643,7 +643,7 @@ , sps_type_or_kind = t_or_k }) -substPredSpec :: HasCallStack => Subst -> PredSpec -> PredSpec+substPredSpec :: HasDebugCallStack => Subst -> PredSpec -> PredSpec substPredSpec subst ps = case ps of SimplePredSpec { sps_pred = pred
GHC/Tc/Errors.hs view
@@ -469,6 +469,8 @@ flav = ctFlavour ct ; (suppress, m_evdest) <- case ctEvidence ct of+ -- For this `suppress` stuff+ -- see Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint CtGiven {} -> return (False, Nothing) CtWanted { ctev_rewriters = rewriters, ctev_dest = dest } -> do { rewriters' <- zonkRewriterSet rewriters
GHC/Tc/Gen/HsType.hs view
@@ -2551,9 +2551,11 @@ ; traceTc "kcCheckDeclHeader_sig {" $ vcat [ text "sig_kind:" <+> ppr sig_kind , text "sig_tcbs:" <+> ppr sig_tcbs- , text "sig_res_kind:" <+> ppr sig_res_kind ]+ , text "sig_res_kind:" <+> ppr sig_res_kind+ , text "implict_nms:" <+> ppr implicit_nms+ , text "hs_tv_bndrs:" <+> ppr hs_tv_bndrs ] - ; (tclvl, wanted, (implicit_tvs, (skol_tcbs, (extra_tcbs, tycon_res_kind))))+ ; (tclvl, wanted, (implicit_tvs, (skol_tcbs, skol_scoped_tvs, (extra_tcbs, tycon_res_kind)))) <- pushLevelAndSolveEqualitiesX "kcCheckDeclHeader_sig" $ -- #16687 bindImplicitTKBndrs_Q_Tv implicit_nms $ -- Q means don't clone matchUpSigWithDecl name sig_tcbs sig_res_kind hs_tv_bndrs $ \ excess_sig_tcbs sig_res_kind ->@@ -2605,9 +2607,18 @@ -- Here p and q both map to the same kind variable k. We don't allow this -- so we must check that they are distinct. A similar thing happens -- in GHC.Tc.TyCl.swizzleTcTyConBinders during inference.+ --+ -- With visible dependent quantification, one of the binders involved+ -- may be explicit. Consider #24604+ -- type UF :: forall zk -> zk -> Constraint+ -- class UF kk (xb :: k)+ -- Here `k` and `kk` both denote the same variable; but only `k` is implicit+ -- Hence we need to add skol_scoped_tvs ; implicit_tvs <- liftZonkM $ zonkTcTyVarsToTcTyVars implicit_tvs ; let implicit_prs = implicit_nms `zip` implicit_tvs- ; checkForDuplicateScopedTyVars implicit_prs+ dup_chk_prs = implicit_prs ++ mkTyVarNamePairs skol_scoped_tvs+ ; unless (null implicit_nms) $ -- No need if no implicit tyvars+ checkForDuplicateScopedTyVars dup_chk_prs ; checkForDisconnectedScopedTyVars flav all_tcbs implicit_prs -- Swizzle the Names so that the TyCon uses the user-declared implicit names@@ -2676,6 +2687,7 @@ -> ([TcTyConBinder] -> TcKind -> TcM a) -- All user-written binders are in scope -- Argument is excess TyConBinders and tail kind -> TcM ( [TcTyConBinder] -- Skolemised binders, with TcTyVars+ , [TcTyVar] -- Skolem tyvars brought into lexical scope by this matching-up , a ) -- See Note [Matching a kind signature with a declaration] -- Invariant: Length of returned TyConBinders + length of excess TyConBinders@@ -2686,7 +2698,7 @@ go subst tcbs [] = do { let (subst', tcbs') = substTyConBindersX subst tcbs ; res <- thing_inside tcbs' (substTy subst' sig_res_kind)- ; return ([], res) }+ ; return ([], [], res) } go _ [] hs_bndrs = failWithTc (TcRnTooManyBinders sig_res_kind hs_bndrs)@@ -2702,17 +2714,22 @@ -- that come from the type declaration, not the kind signature subst' = extendTCvSubstWithClone subst tv tv' ; tc_hs_bndr (unLoc hs_bndr) (tyVarKind tv')- ; (tcbs', res) <- tcExtendTyVarEnv [tv'] $- go subst' tcbs' hs_bndrs'- ; return (Bndr tv' vis : tcbs', res) }+ ; traceTc "musd1" (ppr tcb $$ ppr hs_bndr $$ ppr tv')+ ; (tcbs', tvs, res) <- tcExtendTyVarEnv [tv'] $+ go subst' tcbs' hs_bndrs'+ ; return (Bndr tv' vis : tcbs', tv':tvs, res) }+ -- We do a tcExtendTyVarEnv [tv'], so we return tv' in+ -- the list of lexically-scoped skolem type variables | skippable (binderFlag tcb) = -- Invisible TyConBinder, so do not consume one of the hs_bndrs do { let (subst', tcb') = substTyConBinderX subst tcb- ; (tcbs', res) <- go subst' tcbs' hs_bndrs+ ; traceTc "musd2" (ppr tcb $$ ppr hs_bndr $$ ppr tcb')+ ; (tcbs', tvs, res) <- go subst' tcbs' hs_bndrs -- NB: pass on hs_bndrs unchanged; we do not consume a -- HsTyVarBndr for an invisible TyConBinder- ; return (tcb' : tcbs', res) }+ ; return (tcb' : tcbs', tvs, res) }+ -- Return `tvs`; no new lexically-scoped TyVars brought into scope | otherwise = -- At this point we conclude that:@@ -2726,14 +2743,19 @@ = return () tc_hs_bndr (KindedTyVar _ _ (L _ hs_nm) lhs_kind) expected_kind = do { sig_kind <- tcLHsKindSig (TyVarBndrKindCtxt hs_nm) lhs_kind+ ; traceTc "musd3:unifying" (ppr sig_kind $$ ppr expected_kind) ; discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig] unifyKind (Just (NameThing hs_nm)) sig_kind expected_kind } -- See GHC Proposal #425, section "Kind checking", -- where zippable and skippable are defined.+ -- In particular: we match up if+ -- (a) HsBndr looks like @k, and TyCon binder is forall k. (NamedTCB Specified)+ -- (b) HsBndr looks like a, and TyCon binder is forall k -> (NamedTCB Required)+ -- or k -> (AnonTCB) zippable :: TyConBndrVis -> HsBndrVis GhcRn -> Bool- zippable vis HsBndrRequired = isVisibleTcbVis vis- zippable vis (HsBndrInvisible _) = isInvisSpecTcbVis vis+ zippable vis (HsBndrInvisible _) = isInvisSpecTcbVis vis -- (a)+ zippable vis HsBndrRequired = isVisibleTcbVis vis -- (b) -- See GHC Proposal #425, section "Kind checking", -- where zippable and skippable are defined.@@ -3026,15 +3048,7 @@ checkForDuplicateScopedTyVars :: [(Name,TcTyVar)] -> TcM () -- Check for duplicates--- E.g. data SameKind (a::k) (b::k)--- data T (a::k1) (b::k2) c = MkT (SameKind a b) c--- Here k1 and k2 start as TyVarTvs, and get unified with each other--- If this happens, things get very confused later, so fail fast------ In the CUSK case k1 and k2 are skolems so they won't unify;--- but in the inference case (see generaliseTcTyCon),--- and the type-sig case (see kcCheckDeclHeader_sig), they are--- TcTyVars, so we must check.+-- See Note [Aliasing in type and class declarations] checkForDuplicateScopedTyVars scoped_prs = unless (null err_prs) $ do { mapM_ report_dup err_prs; failM }@@ -3054,8 +3068,43 @@ addErrTc $ TcRnDifferentNamesForTyVar n1 n2 -{- Note [Disconnected type variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Aliasing in type and class declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+ data SameKind (a::k) (b::k)+ data T1 (a::k1) (b::k2) c = MkT (SameKind a b) c+We do not allow this, because `k1` and `k2` would both stand for the same type+variable -- they are both aliases for `k`.++Other examples+ data T2 (a::k1) = MkT2 (SameKind a Int) -- k1 stands for Type+ data T3 @k1 @k2 (a::k1) (b::k2) = MkT (SameKind a b) -- k1 and k2 are aliases++ type UF :: forall zk. zk -> Constraint+ class UF @kk (xb :: k) where -- kk and k are aliases+ op :: (xs::kk) -> Bool++See #24604 for an example that crashed GHC.++There is a design choice here. It would be possible to allow implicit type variables+like `k1` and `k2` in T1's declartion to stand for /abitrary kinds/. This is in fact+the rule we use in /terms/ pattern signatures:+ f :: [Int] -> Int+ f ((x::a) : xs) = ...+Here `a` stands for `Int`. But in type /signatures/ we make a different choice:+ f1 :: forall (a::k1) (b::k2). SameKind a b -> blah+ f2 :: forall (a::k). SameKind a Int -> blah++Here f1's signature is rejected because `k1` and `k2` are aliased; and f2's is+rejected because `k` stands for `Int`.++Our current choice is that type and class declarations behave more like signatures;+we do not allow aliasing. That is what `checkForDuplicateScopedTyVars` checks.+See !12328 for some design discussion.+++Note [Disconnected type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This note applies when kind-checking the header of a type/class decl that has a separate, standalone kind signature. See #24083. @@ -3501,7 +3550,7 @@ | SMDSkolemTv SkolemInfo -smVanilla :: HasCallStack => SkolemMode+smVanilla :: HasDebugCallStack => SkolemMode smVanilla = SM { sm_clone = panic "sm_clone" -- We always override this , sm_parent = False , sm_tvtv = pprPanic "sm_tvtv" callStackDoc -- We always override this
GHC/Tc/Solver/Monad.hs view
@@ -1197,6 +1197,9 @@ -- Getters and setters of GHC.Tc.Utils.Env fields -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +getUnifiedRef :: TcS (IORef Int)+getUnifiedRef = TcS (return . tcs_unified)+ -- Getter of inerts and worklist getInertSetRef :: TcS (IORef InertSet) getInertSetRef = TcS (return . tcs_inerts)@@ -2001,7 +2004,8 @@ -- unified the process; the (Bag Ct) are the deferred constraints. wrapUnifierTcS ev role do_unifications- = do { (cos, unified, rewriters, cts) <- wrapTcS $+ = do { unif_count_ref <- getUnifiedRef+ ; (cos, unified, rewriters, cts) <- wrapTcS $ do { defer_ref <- TcM.newTcRef emptyBag ; unified_ref <- TcM.newTcRef [] ; rewriters <- TcM.zonkRewriterSet (ctEvRewriters ev)@@ -2015,6 +2019,13 @@ ; cts <- TcM.readTcRef defer_ref ; unified <- TcM.readTcRef unified_ref+++ -- Don't forget to update the count of variables+ -- unified, lest we forget to iterate (#24146)+ ; unless (null unified) $+ TcM.updTcRef unif_count_ref (+ (length unified))+ ; return (cos, unified, rewriters, cts) } -- Emit the deferred constraints
GHC/Tc/Types/Constraint.hs view
@@ -83,7 +83,7 @@ ctEvExpr, ctEvTerm, ctEvCoercion, ctEvEvId, ctEvRewriters, ctEvUnique, tcEvDestUnique, mkKindEqLoc, toKindLoc, toInvisibleLoc, mkGivenLoc,- ctEvRole, setCtEvPredType, setCtEvLoc, arisesFromGivens,+ ctEvRole, setCtEvPredType, setCtEvLoc, tyCoVarsOfCtEvList, tyCoVarsOfCtEv, tyCoVarsOfCtEvsList, -- RewriterSet@@ -1312,25 +1312,51 @@ insolubleWC :: WantedConstraints -> Bool insolubleWC (WC { wc_impl = implics, wc_simple = simples, wc_errors = errors }) = anyBag insolubleWantedCt simples+ -- insolubleWantedCt: wanteds only: see Note [Given insolubles] || anyBag insolubleImplic implics || anyBag is_insoluble errors-- where+ where is_insoluble (DE_Hole hole) = isOutOfScopeHole hole -- See Note [Insoluble holes] is_insoluble (DE_NotConcrete {}) = True insolubleWantedCt :: Ct -> Bool -- Definitely insoluble, in particular /excluding/ type-hole constraints -- Namely:--- a) an insoluble constraint as per 'insolubleCt', i.e. either+-- a) an insoluble constraint as per 'insolubleIrredCt', i.e. either -- - an insoluble equality constraint (e.g. Int ~ Bool), or -- - a custom type error constraint, TypeError msg :: Constraint -- b) that does not arise from a Given or a Wanted/Wanted fundep interaction+-- See Note [Insoluble Wanteds]+insolubleWantedCt ct+ | CIrredCan ir_ct <- ct+ -- CIrredCan: see (IW1) in Note [Insoluble Wanteds]+ , IrredCt { ir_ev = ev } <- ir_ct+ , CtWanted { ctev_loc = loc, ctev_rewriters = rewriters } <- ev+ -- It's a Wanted+ , insolubleIrredCt ir_ct+ -- It's insoluble+ , isEmptyRewriterSet rewriters+ -- It has no rewriters; see (IW2) in Note [Insoluble Wanteds]+ , not (isGivenLoc loc)+ -- isGivenLoc: see (IW3) in Note [Insoluble Wanteds]+ , not (isWantedWantedFunDepOrigin (ctLocOrigin loc))+ -- origin check: see (IW4) in Note [Insoluble Wanteds]+ = True++ | otherwise+ = False++-- | Returns True of constraints that are definitely insoluble,+-- as well as TypeError constraints.+-- Can return 'True' for Given constraints, unlike 'insolubleWantedCt'. ----- See Note [Given insolubles].-insolubleWantedCt ct = insolubleCt ct &&- not (arisesFromGivens ct) &&- not (isWantedWantedFunDepOrigin (ctOrigin ct))+-- The function is tuned for application /after/ constraint solving+-- i.e. assuming canonicalisation has been done+-- That's why it looks only for IrredCt; all insoluble constraints+-- are put into CIrredCan+insolubleCt :: Ct -> Bool+insolubleCt (CIrredCan ir_ct) = insolubleIrredCt ir_ct+insolubleCt _ = False insolubleIrredCt :: IrredCt -> Bool -- Returns True of Irred constraints that are /definitely/ insoluble@@ -1360,18 +1386,6 @@ -- > Assert 'True _errMsg = () -- > Assert _check errMsg = errMsg --- | Returns True of constraints that are definitely insoluble,--- as well as TypeError constraints.--- Can return 'True' for Given constraints, unlike 'insolubleWantedCt'.------ The function is tuned for application /after/ constraint solving--- i.e. assuming canonicalisation has been done--- That's why it looks only for IrredCt; all insoluble constraints--- are put into CIrredCan-insolubleCt :: Ct -> Bool-insolubleCt (CIrredCan ir_ct) = insolubleIrredCt ir_ct-insolubleCt _ = False- -- | Does this hole represent an "out of scope" error? -- See Note [Insoluble holes] isOutOfScopeHole :: Hole -> Bool@@ -1415,6 +1429,31 @@ Bottom line: insolubleWC (called in GHC.Tc.Solver.setImplicationStatus) should ignore givens even if they are insoluble. +Note [Insoluble Wanteds]+~~~~~~~~~~~~~~~~~~~~~~~~+insolubleWantedCt returns True of a Wanted constraint that definitely+can't be solved. But not quite all such constraints; see wrinkles.++(IW1) insolubleWantedCt is tuned for application /after/ constraint+ solving i.e. assuming canonicalisation has been done. That's why+ it looks only for IrredCt; all insoluble constraints are put into+ CIrredCan++(IW2) We only treat it as insoluble if it has an empty rewriter set. (See Note+ [Wanteds rewrite Wanteds].) Otherwise #25325 happens: a Wanted constraint A+ that is /not/ insoluble rewrites some other Wanted constraint B, so B has A+ in its rewriter set. Now B looks insoluble. The danger is that we'll+ suppress reporting B because of its empty rewriter set; and suppress+ reporting A because there is an insoluble B lying around. (This suppression+ happens in GHC.Tc.Errors.mkErrorItem.) Solution: don't treat B as insoluble.++(IW3) If the Wanted arises from a Given (how can that happen?), don't+ treat it as a Wanted insoluble (obviously).++(IW4) If the Wanted came from a Wanted/Wanted fundep interaction, don't+ treat the constraint as insoluble. See Note [Suppressing confusing errors]+ in GHC.Tc.Errors+ Note [Insoluble holes] ~~~~~~~~~~~~~~~~~~~~~~ Hole constraints that ARE NOT treated as truly insoluble:@@ -2055,9 +2094,6 @@ setCtEvLoc :: CtEvidence -> CtLoc -> CtEvidence setCtEvLoc ctev loc = ctev { ctev_loc = loc }--arisesFromGivens :: Ct -> Bool-arisesFromGivens ct = isGivenCt ct || isGivenLoc (ctLoc ct) -- | Set the type of CtEvidence. --
GHC/Tc/Types/Origin.hs view
@@ -67,6 +67,7 @@ import GHC.Utils.Panic import GHC.Stack import GHC.Utils.Monad+import GHC.Utils.Misc( HasDebugCallStack ) import GHC.Types.Unique import GHC.Types.Unique.Supply @@ -311,10 +312,10 @@ -- -- We're hoping to be able to get rid of this entirely, but for the moment -- it's still needed.-unkSkol :: HasCallStack => SkolemInfo+unkSkol :: HasDebugCallStack => SkolemInfo unkSkol = SkolemInfo (mkUniqueGrimily 0) unkSkolAnon -unkSkolAnon :: HasCallStack => SkolemInfoAnon+unkSkolAnon :: HasDebugCallStack => SkolemInfoAnon unkSkolAnon = UnkSkol callStack -- | Wrap up the origin of a skolem type variable with a new 'Unique',@@ -864,7 +865,7 @@ = ctoHerald <+> pprCtO simple_origin -- | Short one-liners-pprCtO :: HasCallStack => CtOrigin -> SDoc+pprCtO :: HasDebugCallStack => CtOrigin -> SDoc pprCtO (OccurrenceOf name) = hsep [text "a use of", quotes (ppr name)] pprCtO (OccurrenceOfRecSel name) = hsep [text "a use of", quotes (ppr name)] pprCtO AppOrigin = text "an application"
GHC/Tc/Types/Origin.hs-boot view
@@ -1,6 +1,6 @@ module GHC.Tc.Types.Origin where -import GHC.Stack ( HasCallStack )+import GHC.Utils.Misc ( HasDebugCallStack ) data SkolemInfoAnon data SkolemInfo@@ -11,4 +11,4 @@ data ClsInstOrQC = IsClsInst | IsQC CtOrigin -unkSkol :: HasCallStack => SkolemInfo+unkSkol :: HasDebugCallStack => SkolemInfo
GHC/Tc/Utils/TcType.hs view
@@ -580,7 +580,7 @@ , mtv_ref :: IORef MetaDetails , mtv_tclvl :: TcLevel } -- See Note [TcLevel invariants] -vanillaSkolemTvUnk :: HasCallStack => TcTyVarDetails+vanillaSkolemTvUnk :: HasDebugCallStack => TcTyVarDetails vanillaSkolemTvUnk = SkolemTv unkSkol topTcLevel False instance Outputable TcTyVarDetails where
GHC/Tc/Utils/TcType.hs-boot view
@@ -2,13 +2,13 @@ import GHC.Utils.Outputable( SDoc ) import GHC.Prelude ( Bool ) import {-# SOURCE #-} GHC.Types.Var ( TcTyVar )-import GHC.Stack+import GHC.Utils.Misc( HasDebugCallStack ) data MetaDetails data TcTyVarDetails pprTcTyVarDetails :: TcTyVarDetails -> SDoc-vanillaSkolemTvUnk :: HasCallStack => TcTyVarDetails+vanillaSkolemTvUnk :: HasDebugCallStack => TcTyVarDetails isMetaTyVar :: TcTyVar -> Bool isTyConableTyVar :: TcTyVar -> Bool isConcreteTyVar :: TcTyVar -> Bool
GHC/ThToHs.hs view
@@ -1476,7 +1476,8 @@ ; return $ ListPat noAnn ps'} cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t- ; return $ SigPat noAnn p' (mkHsPatSigType noAnn t') }+ ; let pp = parenthesizePat sigPrec p'+ ; return $ SigPat noAnn pp (mkHsPatSigType noAnn t') } cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p ; return $ ViewPat noAnn e' p'}
GHC/Types/Id.hs view
@@ -296,26 +296,28 @@ mkGlobalId = Var.mkGlobalVar -- | Make a global 'Id' without any extra information at all-mkVanillaGlobal :: Name -> Type -> Id+mkVanillaGlobal :: HasDebugCallStack => Name -> Type -> Id mkVanillaGlobal name ty = mkVanillaGlobalWithInfo name ty vanillaIdInfo -- | Make a global 'Id' with no global information but some generic 'IdInfo'-mkVanillaGlobalWithInfo :: Name -> Type -> IdInfo -> Id-mkVanillaGlobalWithInfo = mkGlobalId VanillaId-+mkVanillaGlobalWithInfo :: HasDebugCallStack => Name -> Type -> IdInfo -> Id+mkVanillaGlobalWithInfo nm =+ assertPpr (not $ isFieldNameSpace $ nameNameSpace nm)+ (text "mkVanillaGlobalWithInfo called on record field:" <+> ppr nm) $+ mkGlobalId VanillaId nm -- | For an explanation of global vs. local 'Id's, see "GHC.Types.Var#globalvslocal" mkLocalId :: HasDebugCallStack => Name -> Mult -> Type -> Id mkLocalId name w ty = mkLocalIdWithInfo name w (assert (not (isCoVarType ty)) ty) vanillaIdInfo -- | Make a local CoVar-mkLocalCoVar :: Name -> Type -> CoVar+mkLocalCoVar :: HasDebugCallStack => Name -> Type -> CoVar mkLocalCoVar name ty = assert (isCoVarType ty) $ Var.mkLocalVar CoVarId name ManyTy ty vanillaIdInfo -- | Like 'mkLocalId', but checks the type to see if it should make a covar-mkLocalIdOrCoVar :: Name -> Mult -> Type -> Id+mkLocalIdOrCoVar :: HasDebugCallStack => Name -> Mult -> Type -> Id mkLocalIdOrCoVar name w ty -- We should assert (eqType w Many) in the isCoVarType case. -- However, currently this assertion does not hold.@@ -339,7 +341,10 @@ -- Note [Free type variables] mkExportedVanillaId :: Name -> Type -> Id-mkExportedVanillaId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo+mkExportedVanillaId name ty =+ assertPpr (not $ isFieldNameSpace $ nameNameSpace name)+ (text "mkExportedVanillaId called on record field:" <+> ppr name) $+ Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo -- Note [Free type variables]
GHC/Types/Id/Make.hs view
@@ -899,15 +899,25 @@ -- needs a wrapper. This wrapper is injected into the program later in the -- CoreTidy pass. See Note [Injecting implicit bindings] in GHC.Iface.Tidy, -- along with the accompanying implementation in getTyConImplicitBinds.- wrapper_reqd =- (not new_tycon+ wrapper_reqd+ | isTypeDataTyCon tycon+ -- `type data` declarations never have data-constructor wrappers+ -- Their data constructors only live at the type level, in the+ -- form of PromotedDataCon, and therefore do not need wrappers.+ -- See wrinkle (W0) in Note [Type data declarations] in GHC.Rename.Module.+ = False++ | otherwise+ = (not new_tycon -- (Most) newtypes have only a worker, with the exception -- of some newtypes written with GADT syntax. -- See dataConUserTyVarsNeedWrapper below. && (any isBanged (ev_ibangs ++ arg_ibangs))) -- Some forcing/unboxing (includes eq_spec)+ || isFamInstTyCon tycon -- Cast result- || (dataConUserTyVarsNeedWrapper data_con++ || dataConUserTyVarsNeedWrapper data_con -- If the data type was written with GADT syntax and -- orders the type variables differently from what the -- worker expects, it needs a data con wrapper to reorder@@ -916,19 +926,7 @@ -- -- NB: All GADTs return true from this function, but there -- is one exception that we must check below.- && not (isTypeDataTyCon tycon))- -- An exception to this rule is `type data` declarations.- -- Their data constructors only live at the type level and- -- therefore do not need wrappers.- -- See Note [Type data declarations] in GHC.Rename.Module.- --- -- Note that the other checks in this definition will- -- return False for `type data` declarations, as:- --- -- - They cannot be newtypes- -- - They cannot have strict fields- -- - They cannot be data family instances- -- - They cannot have datatype contexts+ || not (null stupid_theta) -- If the data constructor has a datatype context, -- we need a wrapper in order to drop the stupid arguments.
GHC/Unit/Types.hs view
@@ -101,9 +101,9 @@ import GHC.Utils.Misc import GHC.Settings.Config (cProjectUnitId) -import Control.DeepSeq+import Control.DeepSeq (NFData(..)) import Data.Data-import Data.List (sortBy )+import Data.List (sortBy) import Data.Function import Data.Bifunctor import qualified Data.ByteString as BS
GHC/Utils/Binary.hs view
@@ -249,15 +249,18 @@ seekBin :: BinHandle -> Bin a -> IO () seekBin h@(BinMem _ ix_r sz_r _) (BinPtr !p) = do sz <- readFastMutInt sz_r- if (p >= sz)+ if (p > sz) then do expandBin h p; writeFastMutInt ix_r p else writeFastMutInt ix_r p --- | SeekBin but without calling expandBin+-- | 'seekBinNoExpand' moves the index pointer to the location pointed to+-- by 'Bin a'.+-- This operation may 'panic', if the pointer location is out of bounds of the+-- buffer of 'BinHandle'. seekBinNoExpand :: BinHandle -> Bin a -> IO () seekBinNoExpand (BinMem _ ix_r sz_r _) (BinPtr !p) = do sz <- readFastMutInt sz_r- if (p >= sz)+ if (p > sz) then panic "seekBinNoExpand: seek out of range" else writeFastMutInt ix_r p
GHC/Utils/Lexeme.hs view
@@ -227,10 +227,11 @@ , "module", "newtype", "of", "then", "type", "where" , "_" ] --- | All reserved operators. Taken from section 2.4 of the 2010 Report.+-- | All reserved operators. Taken from section 2.4 of the 2010 Report,+-- excluding @\@@ and @~@ that are allowed by GHC (see GHC Proposal #229). reservedOps :: Set.Set String reservedOps = Set.fromList [ "..", ":", "::", "=", "\\", "|", "<-", "->"- , "@", "~", "=>" ]+ , "=>" ] -- | Does this string contain only dashes and has at least 2 of them? isDashes :: String -> Bool
GHC/Utils/Misc.hs view
@@ -485,7 +485,7 @@ -- | Extract the single element of a list and panic with the given message if -- there are more elements or the list was empty. -- Like 'expectJust', but for lists.-expectOnly :: HasCallStack => String -> [a] -> a+expectOnly :: HasDebugCallStack => String -> [a] -> a {-# INLINE expectOnly #-} #if defined(DEBUG) expectOnly _ [a] = a@@ -513,7 +513,7 @@ changeLast (x:xs) x' = x : changeLast xs x' -- | Like @expectJust msg . nonEmpty@; a better alternative to 'NE.fromList'.-expectNonEmpty :: HasCallStack => String -> [a] -> NonEmpty a+expectNonEmpty :: HasDebugCallStack => String -> [a] -> NonEmpty a {-# INLINE expectNonEmpty #-} expectNonEmpty _ (x:xs) = x:|xs expectNonEmpty msg [] = expectNonEmptyPanic msg
ghc.cabal view
@@ -3,7 +3,7 @@ -- ./configure. Make sure you are editing ghc.cabal.in, not ghc.cabal. Name: ghc-Version: 9.8.2+Version: 9.8.3 License: BSD-3-Clause License-File: LICENSE Author: The GHC Team@@ -110,9 +110,9 @@ exceptions == 0.10.*, semaphore-compat, stm,- ghc-boot == 9.8.2,- ghc-heap == 9.8.2,- ghci == 9.8.2+ ghc-boot == 9.8.3,+ ghc-heap == 9.8.3,+ ghci == 9.8.3 if os(windows) Build-Depends: Win32 >= 2.3 && < 2.14