May 2025 - ghc-commits

[Git][ghc/ghc][wip/bytecode-serialize-pre] 8 commits: compiler: do not allocate strings in bytecode assembler
by Cheng Shao (＠TerrorJack) 14 May '25

14 May '25

Cheng Shao pushed to branch wip/bytecode-serialize-pre at Glasgow Haskell Compiler / GHC Commits: 55e22336 by Cheng Shao at 2025-05-14T01:17:16+00:00 compiler: do not allocate strings in bytecode assembler This patch refactors the compiler to avoid allocating iserv buffers for BCONPtrStr at assemble-time. Now BCONPtrStr ByteStrings are recorded as a part of CompiledByteCode, and actual allocation only happens at link-time. This refactoring is necessary for adding bytecode serialization functionality, as explained by the revised comments in this commit. ------------------------- Metric Increase: MultiLayerModulesDefsGhciReload ------------------------- - - - - - 739d2f38 by Cheng Shao at 2025-05-14T01:17:26+00:00 compiler: make bc_strs serializable This commit makes the bc_strs field in CompiledByteCode serializable; similar to previous commit, we preserve the ByteString directly and defer the actual allocation to link-time, as mentioned in updated comment. - - - - - 6a2710ff by Cheng Shao at 2025-05-14T01:17:27+00:00 compiler: make bc_itbls serializable This commit makes bc_itbls in CompiledByteCode serializable. A dedicated ConInfoTable datatype has been added in ghci which is the recipe for dynamically making a datacon's info table, containing the payload of the MkConInfoTable iserv message. - - - - - 553c5fd5 by Cheng Shao at 2025-05-14T01:17:27+00:00 compiler: remove FFIInfo bookkeeping in BCO This commit removes the bc_ffis field from CompiledByteCode completely, as well as all the related bookkeeping logic in GHC.StgToByteCode. bc_ffis is actually *unused* in the rest of GHC codebase! It is merely a list of FFIInfo, which is just a remote pointer of the libffi ffi_cif struct; once we allocate the ffi_cif struct and put its pointer in a CCALL instruction, we'll never free it anyway. So there is no point of bookkeeping. - - - - - 75ab80d0 by Cheng Shao at 2025-05-14T01:17:27+00:00 compiler: make FFIInfo serializable in BCO This commit makes all the FFIInfo needed in CCALL instructions serializable. Previously, when doing STG to BCO lowering, we would allocate a libffi ffi_cif struct and keep its remote pointer as FFIInfo; but actually we can just keep the type signature as FFIInfo and defer the actual allocation to link-time. - - - - - a9c42238 by Cheng Shao at 2025-05-14T01:17:27+00:00 ghci: remove redundant NewBreakModule message This commit removes the redundant NewBreakModule message from ghci: it just allocates two strings! This functionality can be implemented with existing MallocStrings in one iserv call. - - - - - bad310cb by Cheng Shao at 2025-05-14T01:17:27+00:00 compiler: make breakpoint module name and unit id serializable This commit makes breakpoint module name and unit id serializable, in BRK_FUN instructions as well as ModBreaks. We can simply keep the module name and unit ids, and defer the buffer allocation to link time. - - - - - 981efb4a by Cheng Shao at 2025-05-14T01:17:27+00:00 compiler: remove unused newModule This commit removes the now unused newModule function from GHC. - - - - - 13 changed files: - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/InfoTable.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/HsToCore/Breakpoints.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/StgToByteCode.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - testsuite/tests/bytecode/T22376/all.T - testsuite/tests/perf/should_run/ByteCodeAsm.hs Changes: ===================================== compiler/GHC/ByteCode/Asm.hs ===================================== @@ -29,7 +29,6 @@ import GHC.ByteCode.Instr import GHC.ByteCode.InfoTable import GHC.ByteCode.Types import GHCi.RemoteTypes -import GHC.Runtime.Interpreter import GHC.Runtime.Heap.Layout ( fromStgWord, StgWord ) import GHC.Types.Name @@ -38,11 +37,13 @@ import GHC.Types.Literal import GHC.Types.Unique.DSet import GHC.Types.SptEntry import GHC.Types.Unique.FM +import GHC.Unit.Types import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Core.TyCon +import GHC.Data.FastString import GHC.Data.SizedSeq import GHC.Data.SmallArray @@ -52,6 +53,7 @@ import GHC.Cmm.Reg ( GlobalArgRegs(..) ) import GHC.Cmm.CallConv ( allArgRegsCover ) import GHC.Platform import GHC.Platform.Profile +import Language.Haskell.Syntax.Module.Name import Control.Monad import qualified Control.Monad.Trans.State.Strict as MTL @@ -65,6 +67,7 @@ import Data.Array.Base ( unsafeWrite ) #endif import Foreign hiding (shiftL, shiftR) +import Data.ByteString (ByteString) import Data.Char (ord) import Data.Maybe (fromMaybe) import GHC.Float (castFloatToWord32, castDoubleToWord64) @@ -104,24 +107,21 @@ bcoFreeNames bco -- Top level assembler fn. assembleBCOs - :: Interp - -> Profile + :: Profile -> FlatBag (ProtoBCO Name) -> [TyCon] - -> AddrEnv + -> [(Name, ByteString)] -> Maybe ModBreaks -> [SptEntry] -> IO CompiledByteCode -assembleBCOs interp profile proto_bcos tycons top_strs modbreaks spt_entries = do +assembleBCOs profile proto_bcos tycons top_strs modbreaks spt_entries = do -- TODO: the profile should be bundled with the interpreter: the rts ways are -- fixed for an interpreter - itblenv <- mkITbls interp profile tycons + let itbls = mkITbls profile tycons bcos <- mapM (assembleBCO (profilePlatform profile)) proto_bcos - bcos' <- mallocStrings interp bcos return CompiledByteCode - { bc_bcos = bcos' - , bc_itbls = itblenv - , bc_ffis = concatMap protoBCOFFIs proto_bcos + { bc_bcos = bcos + , bc_itbls = itbls , bc_strs = top_strs , bc_breaks = modbreaks , bc_spt_entries = spt_entries @@ -137,50 +137,17 @@ assembleBCOs interp profile proto_bcos tycons top_strs modbreaks spt_entries = d -- memory for them, and bake the resulting addresses into the instruction stream -- in the form of BCONPtrWord arguments. -- --- Since we do this when assembling, we only allocate the memory when we compile --- the module, not each time we relink it. However, we do want to take care to --- malloc the memory all in one go, since that is more efficient with --- -fexternal-interpreter, especially when compiling in parallel. +-- We used to allocate remote buffers for BCONPtrStr ByteStrings when +-- assembling, but this gets in the way of bytecode serialization: we +-- want the ability to serialize and reload assembled bytecode, so +-- it's better to preserve BCONPtrStr as-is, and only perform the +-- actual allocation at link-time. -- -- Note that, as with top-level string literal bindings, this memory is never -- freed, so it just leaks if the BCO is unloaded. See Note [Generating code for -- top-level string literal bindings] in GHC.StgToByteCode for some discussion -- about why. -- -mallocStrings :: Interp -> FlatBag UnlinkedBCO -> IO (FlatBag UnlinkedBCO) -mallocStrings interp ulbcos = do - let bytestrings = reverse (MTL.execState (mapM_ collect ulbcos) []) - ptrs <- interpCmd interp (MallocStrings bytestrings) - return (MTL.evalState (mapM splice ulbcos) ptrs) - where - splice bco@UnlinkedBCO{..} = do - lits <- mapM spliceLit unlinkedBCOLits - ptrs <- mapM splicePtr unlinkedBCOPtrs - return bco { unlinkedBCOLits = lits, unlinkedBCOPtrs = ptrs } - - spliceLit (BCONPtrStr _) = do - rptrs <- MTL.get - case rptrs of - (RemotePtr p : rest) -> do - MTL.put rest - return (BCONPtrWord (fromIntegral p)) - _ -> panic "mallocStrings:spliceLit" - spliceLit other = return other - - splicePtr (BCOPtrBCO bco) = BCOPtrBCO <$> splice bco - splicePtr other = return other - - collect UnlinkedBCO{..} = do - mapM_ collectLit unlinkedBCOLits - mapM_ collectPtr unlinkedBCOPtrs - - collectLit (BCONPtrStr bs) = do - strs <- MTL.get - MTL.put (bs:strs) - collectLit _ = return () - - collectPtr (BCOPtrBCO bco) = collect bco - collectPtr _ = return () data RunAsmReader = RunAsmReader { isn_array :: {-# UNPACK #-} !(Array.IOUArray Int Word16) , ptr_array :: {-# UNPACK #-} !(SmallMutableArrayIO BCOPtr) @@ -729,15 +696,15 @@ assembleI platform i = case i of ENTER -> emit_ bci_ENTER [] RETURN rep -> emit_ (return_non_tuple rep) [] RETURN_TUPLE -> emit_ bci_RETURN_T [] - CCALL off m_addr i -> do np <- addr m_addr + CCALL off ffi i -> do np <- lit1 $ BCONPtrFFIInfo ffi emit_ bci_CCALL [wOp off, Op np, SmallOp i] PRIMCALL -> emit_ bci_PRIMCALL [] BRK_FUN arr tick_mod tick_mod_id tickx info_mod info_mod_id infox cc -> do p1 <- ptr (BCOPtrBreakArray arr) - tick_addr <- addr tick_mod - tick_unitid_addr <- addr tick_mod_id - info_addr <- addr info_mod - info_unitid_addr <- addr info_mod_id + tick_addr <- lit1 $ BCONPtrStr $ bytesFS $ moduleNameFS tick_mod + info_addr <- lit1 $ BCONPtrStr $ bytesFS $ moduleNameFS info_mod + tick_unitid_addr <- lit1 $ BCONPtrStr $ bytesFS $ unitIdFS tick_mod_id + info_unitid_addr <- lit1 $ BCONPtrStr $ bytesFS $ unitIdFS info_mod_id np <- addr cc emit_ bci_BRK_FUN [ Op p1 , Op tick_addr, Op info_addr ===================================== compiler/GHC/ByteCode/InfoTable.hs ===================================== @@ -13,11 +13,9 @@ import GHC.Prelude import GHC.Platform import GHC.Platform.Profile -import GHC.ByteCode.Types -import GHC.Runtime.Interpreter +import GHCi.Message import GHC.Types.Name ( Name, getName ) -import GHC.Types.Name.Env import GHC.Types.RepType import GHC.Core.DataCon ( DataCon, dataConRepArgTys, dataConIdentity ) @@ -35,33 +33,38 @@ import GHC.Utils.Panic -} -- Make info tables for the data decls in this module -mkITbls :: Interp -> Profile -> [TyCon] -> IO ItblEnv -mkITbls interp profile tcs = - foldr plusNameEnv emptyNameEnv <$> - mapM mkITbl (filter isDataTyCon tcs) +mkITbls :: Profile -> [TyCon] -> [(Name, ConInfoTable)] +mkITbls profile tcs = concatMap mkITbl (filter isDataTyCon tcs) where - mkITbl :: TyCon -> IO ItblEnv + mkITbl :: TyCon -> [(Name, ConInfoTable)] mkITbl tc | dcs `lengthIs` n -- paranoia; this is an assertion. - = make_constr_itbls interp profile dcs + = make_constr_itbls profile dcs where dcs = tyConDataCons tc n = tyConFamilySize tc mkITbl _ = panic "mkITbl" -mkItblEnv :: [(Name,ItblPtr)] -> ItblEnv -mkItblEnv pairs = mkNameEnv [(n, (n,p)) | (n,p) <- pairs] - -- Assumes constructors are numbered from zero, not one -make_constr_itbls :: Interp -> Profile -> [DataCon] -> IO ItblEnv -make_constr_itbls interp profile cons = +make_constr_itbls :: Profile -> [DataCon] -> [(Name, ConInfoTable)] +make_constr_itbls profile cons = -- TODO: the profile should be bundled with the interpreter: the rts ways are -- fixed for an interpreter - mkItblEnv <$> mapM (uncurry mk_itbl) (zip cons [0..]) - where - mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr) - mk_itbl dcon conNo = do - let rep_args = [ prim_rep + map (uncurry mk_itbl) (zip cons [0..]) + where + mk_itbl :: DataCon -> Int -> (Name, ConInfoTable) + mk_itbl dcon conNo = + ( getName dcon, + ConInfoTable + tables_next_to_code + ptrs' + nptrs_really + conNo + (tagForCon platform dcon) + descr + ) + where + rep_args = [ prim_rep | arg <- dataConRepArgTys dcon , prim_rep <- typePrimRep (scaledThing arg) ] @@ -79,7 +82,3 @@ make_constr_itbls interp profile cons = platform = profilePlatform profile constants = platformConstants platform tables_next_to_code = platformTablesNextToCode platform - - r <- interpCmd interp (MkConInfoTable tables_next_to_code ptrs' nptrs_really - conNo (tagForCon platform dcon) descr) - return (getName dcon, ItblPtr r) ===================================== compiler/GHC/ByteCode/Instr.hs ===================================== @@ -15,7 +15,6 @@ import GHC.Prelude import GHC.ByteCode.Types import GHCi.RemoteTypes -import GHCi.FFI (C_ffi_cif) import GHC.StgToCmm.Layout ( ArgRep(..) ) import GHC.Utils.Outputable import GHC.Types.Name @@ -51,9 +50,7 @@ data ProtoBCO a protoBCOBitmapSize :: Word, protoBCOArity :: Int, -- what the BCO came from, for debugging only - protoBCOExpr :: Either [CgStgAlt] CgStgRhs, - -- malloc'd pointers - protoBCOFFIs :: [FFIInfo] + protoBCOExpr :: Either [CgStgAlt] CgStgRhs } -- | A local block label (e.g. identifying a case alternative). @@ -209,7 +206,7 @@ data BCInstr -- For doing calls to C (via glue code generated by libffi) | CCALL !WordOff -- stack frame size - (RemotePtr C_ffi_cif) -- addr of the glue code + !FFIInfo -- libffi ffi_cif function prototype !Word16 -- flags. -- -- 0x1: call is interruptible @@ -233,11 +230,11 @@ data BCInstr -- Breakpoints | BRK_FUN (ForeignRef BreakArray) - (RemotePtr ModuleName) -- breakpoint tick module - (RemotePtr UnitId) -- breakpoint tick module unit id + !ModuleName -- breakpoint tick module + !UnitId -- breakpoint tick module unit id !Word16 -- breakpoint tick index - (RemotePtr ModuleName) -- breakpoint info module - (RemotePtr UnitId) -- breakpoint info module unit id + !ModuleName -- breakpoint info module + !UnitId -- breakpoint info module unit id !Word16 -- breakpoint info index (RemotePtr CostCentre) @@ -266,10 +263,9 @@ instance Outputable a => Outputable (ProtoBCO a) where , protoBCOBitmap = bitmap , protoBCOBitmapSize = bsize , protoBCOArity = arity - , protoBCOExpr = origin - , protoBCOFFIs = ffis }) + , protoBCOExpr = origin }) = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity - <+> text (show ffis) <> colon) + <> colon) $$ nest 3 (case origin of Left alts -> vcat (zipWith (<+>) (char '{' : repeat (char ';')) @@ -393,9 +389,9 @@ instance Outputable BCInstr where ppr (TESTEQ_P i lab) = text "TESTEQ_P" <+> ppr i <+> text "__" <> ppr lab ppr CASEFAIL = text "CASEFAIL" ppr (JMP lab) = text "JMP" <+> ppr lab - ppr (CCALL off marshal_addr flags) = text "CCALL " <+> ppr off + ppr (CCALL off ffi flags) = text "CCALL " <+> ppr off <+> text "marshal code at" - <+> text (show marshal_addr) + <+> text (show ffi) <+> (case flags of 0x1 -> text "(interruptible)" 0x2 -> text "(unsafe)" ===================================== compiler/GHC/ByteCode/Linker.hs ===================================== @@ -3,6 +3,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} -- -- (c) The University of Glasgow 2002-2006 @@ -83,9 +84,12 @@ lookupLiteral interp pkgs_loaded le ptr = case ptr of BCONPtrAddr nm -> do Ptr a# <- lookupAddr interp pkgs_loaded (addr_env le) nm return (W# (int2Word# (addr2Int# a#))) - BCONPtrStr _ -> - -- should be eliminated during assembleBCOs - panic "lookupLiteral: BCONPtrStr" + BCONPtrStr bs -> do + RemotePtr p <- fmap head $ interpCmd interp $ MallocStrings [bs] + pure $ fromIntegral p + BCONPtrFFIInfo (FFIInfo {..}) -> do + RemotePtr p <- interpCmd interp $ PrepFFI ffiInfoArgs ffiInfoRet + pure $ fromIntegral p lookupStaticPtr :: Interp -> FastString -> IO (Ptr ()) lookupStaticPtr interp addr_of_label_string = do ===================================== compiler/GHC/ByteCode/Types.hs ===================================== @@ -35,6 +35,7 @@ import GHC.Builtin.PrimOps import GHC.Types.SptEntry import GHC.Types.SrcLoc import GHCi.BreakArray +import GHCi.Message import GHCi.RemoteTypes import GHCi.FFI import Control.DeepSeq @@ -49,8 +50,8 @@ import qualified GHC.Exts.Heap as Heap import GHC.Stack.CCS import GHC.Cmm.Expr ( GlobalRegSet, emptyRegSet, regSetToList ) import GHC.Iface.Syntax -import Language.Haskell.Syntax.Module.Name (ModuleName) -import GHC.Unit.Types (UnitId) +import Language.Haskell.Syntax.Module.Name (ModuleName, mkModuleNameFS) +import GHC.Unit.Types (UnitId(..)) -- ----------------------------------------------------------------------------- -- Compiled Byte Code @@ -59,13 +60,10 @@ data CompiledByteCode = CompiledByteCode { bc_bcos :: FlatBag UnlinkedBCO -- ^ Bunch of interpretable bindings - , bc_itbls :: ItblEnv + , bc_itbls :: [(Name, ConInfoTable)] -- ^ Mapping from DataCons to their info tables - , bc_ffis :: [FFIInfo] - -- ^ ffi blocks we allocated - - , bc_strs :: AddrEnv + , bc_strs :: [(Name, ByteString)] -- ^ top-level strings (heap allocated) , bc_breaks :: Maybe ModBreaks @@ -76,9 +74,10 @@ data CompiledByteCode = CompiledByteCode -- BCOs. See Note [Grand plan for static forms] in -- "GHC.Iface.Tidy.StaticPtrTable". } - -- ToDo: we're not tracking strings that we malloc'd -newtype FFIInfo = FFIInfo (RemotePtr C_ffi_cif) - deriving (Show, NFData) + +-- | A libffi ffi_cif function prototype. +data FFIInfo = FFIInfo { ffiInfoArgs :: ![FFIType], ffiInfoRet :: !FFIType } + deriving (Show) instance Outputable CompiledByteCode where ppr CompiledByteCode{..} = ppr $ elemsFlatBag bc_bcos @@ -88,9 +87,8 @@ instance Outputable CompiledByteCode where seqCompiledByteCode :: CompiledByteCode -> () seqCompiledByteCode CompiledByteCode{..} = rnf bc_bcos `seq` - seqEltsNameEnv rnf bc_itbls `seq` - rnf bc_ffis `seq` - seqEltsNameEnv rnf bc_strs `seq` + rnf bc_itbls `seq` + rnf bc_strs `seq` rnf (fmap seqModBreaks bc_breaks) newtype ByteOff = ByteOff Int @@ -200,10 +198,11 @@ data BCONPtr -- | A reference to a top-level string literal; see -- Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode. | BCONPtrAddr !Name - -- | Only used internally in the assembler in an intermediate representation; - -- should never appear in a fully-assembled UnlinkedBCO. + -- | A top-level string literal. -- Also see Note [Allocating string literals] in GHC.ByteCode.Asm. | BCONPtrStr !ByteString + -- | A libffi ffi_cif function prototype. + | BCONPtrFFIInfo !FFIInfo instance NFData BCONPtr where rnf x = x `seq` () @@ -263,9 +262,9 @@ data ModBreaks -- ^ Array pointing to cost centre for each breakpoint , modBreaks_breakInfo :: IntMap CgBreakInfo -- ^ info about each breakpoint from the bytecode generator - , modBreaks_module :: RemotePtr ModuleName + , modBreaks_module :: !ModuleName -- ^ info about the module in which we are setting the breakpoint - , modBreaks_module_unitid :: RemotePtr UnitId + , modBreaks_module_unitid :: !UnitId -- ^ The 'UnitId' of the 'ModuleName' } @@ -290,8 +289,8 @@ emptyModBreaks = ModBreaks , modBreaks_decls = array (0,-1) [] , modBreaks_ccs = array (0,-1) [] , modBreaks_breakInfo = IntMap.empty - , modBreaks_module = toRemotePtr nullPtr - , modBreaks_module_unitid = toRemotePtr nullPtr + , modBreaks_module = mkModuleNameFS nilFS + , modBreaks_module_unitid = UnitId nilFS } {- ===================================== compiler/GHC/HsToCore/Breakpoints.hs ===================================== @@ -34,7 +34,6 @@ mkModBreaks interp mod extendedMixEntries breakArray <- GHCi.newBreakArray interp count ccs <- mkCCSArray interp mod count entries - (mod_ptr, mod_id_ptr) <- GHCi.newModule interp mod let locsTicks = listArray (0,count-1) [ tick_loc t | t <- entries ] varsTicks = listArray (0,count-1) [ tick_ids t | t <- entries ] @@ -45,8 +44,8 @@ mkModBreaks interp mod extendedMixEntries , modBreaks_vars = varsTicks , modBreaks_decls = declsTicks , modBreaks_ccs = ccs - , modBreaks_module = mod_ptr - , modBreaks_module_unitid = mod_id_ptr + , modBreaks_module = moduleName mod + , modBreaks_module_unitid = toUnitId $ moduleUnit mod } mkCCSArray ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -54,7 +54,7 @@ import GHC.Tc.Utils.Monad import GHC.Runtime.Interpreter import GHCi.RemoteTypes import GHC.Iface.Load -import GHCi.Message (LoadedDLL) +import GHCi.Message (ConInfoTable(..), LoadedDLL) import GHC.ByteCode.Linker import GHC.ByteCode.Asm @@ -95,6 +95,7 @@ import GHC.Linker.Types -- Standard libraries import Control.Monad +import Data.ByteString (ByteString) import qualified Data.Set as Set import Data.Char (isSpace) import qualified Data.Foldable as Foldable @@ -688,8 +689,10 @@ loadDecls interp hsc_env span linkable = do else do -- Link the expression itself let le = linker_env pls - le2 = le { itbl_env = foldl' (\acc cbc -> plusNameEnv acc (bc_itbls cbc)) (itbl_env le) cbcs - , addr_env = foldl' (\acc cbc -> plusNameEnv acc (bc_strs cbc)) (addr_env le) cbcs } + le2_itbl_env <- linkITbls interp (itbl_env le) (concat $ map bc_itbls cbcs) + le2_addr_env <- foldlM (\env cbc -> allocateTopStrings interp (bc_strs cbc) env) (addr_env le) cbcs + let le2 = le { itbl_env = le2_itbl_env + , addr_env = le2_addr_env } -- Link the necessary packages and linkables new_bindings <- linkSomeBCOs interp (pkgs_loaded pls) le2 cbcs @@ -911,9 +914,9 @@ dynLinkBCOs interp pls bcos = do le1 = linker_env pls - ie2 = foldr plusNameEnv (itbl_env le1) (map bc_itbls cbcs) - ae2 = foldr plusNameEnv (addr_env le1) (map bc_strs cbcs) - le2 = le1 { itbl_env = ie2, addr_env = ae2 } + ie2 <- linkITbls interp (itbl_env le1) (concatMap bc_itbls cbcs) + ae2 <- foldlM (\env cbc -> allocateTopStrings interp (bc_strs cbc) env) (addr_env le1) cbcs + let le2 = le1 { itbl_env = ie2, addr_env = ae2 } names_and_refs <- linkSomeBCOs interp (pkgs_loaded pls) le2 cbcs @@ -958,6 +961,11 @@ makeForeignNamedHValueRefs makeForeignNamedHValueRefs interp bindings = mapM (\(n, hvref) -> (n,) <$> mkFinalizedHValue interp hvref) bindings +linkITbls :: Interp -> ItblEnv -> [(Name, ConInfoTable)] -> IO ItblEnv +linkITbls interp = foldlM $ \env (nm, itbl) -> do + r <- interpCmd interp $ MkConInfoTable itbl + evaluate $ extendNameEnv env nm (nm, ItblPtr r) + {- ********************************************************************** Unload some object modules @@ -1614,3 +1622,13 @@ maybePutStr logger s = maybePutSDoc logger (text s) maybePutStrLn :: Logger -> String -> IO () maybePutStrLn logger s = maybePutSDoc logger (text s <> text "\n") + +-- | see Note [Generating code for top-level string literal bindings] +allocateTopStrings :: + Interp -> [(Name, ByteString)] -> AddrEnv -> IO AddrEnv +allocateTopStrings interp topStrings prev_env = do + let (bndrs, strings) = unzip topStrings + ptrs <- interpCmd interp $ MallocStrings strings + evaluate $ extendNameEnvList prev_env (zipWith mk_entry bndrs ptrs) + where + mk_entry nm ptr = (nm, (nm, AddrPtr ptr)) ===================================== compiler/GHC/Runtime/Interpreter.hs ===================================== @@ -21,7 +21,6 @@ module GHC.Runtime.Interpreter , mkCostCentres , costCentreStackInfo , newBreakArray - , newModule , storeBreakpoint , breakpointStatus , getBreakpointVar @@ -376,14 +375,6 @@ newBreakArray interp size = do breakArray <- interpCmd interp (NewBreakArray size) mkFinalizedHValue interp breakArray -newModule :: Interp -> Module -> IO (RemotePtr ModuleName, RemotePtr UnitId) -newModule interp mod = do - let - mod_name = moduleNameString $ moduleName mod - mod_id = fastStringToShortByteString $ unitIdFS $ toUnitId $ moduleUnit mod - (mod_ptr, mod_id_ptr) <- interpCmd interp (NewBreakModule mod_name mod_id) - pure (castRemotePtr mod_ptr, castRemotePtr mod_id_ptr) - storeBreakpoint :: Interp -> ForeignRef BreakArray -> Int -> Int -> IO () storeBreakpoint interp ref ix cnt = do -- #19157 withForeignRef ref $ \breakarray -> ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -67,7 +67,6 @@ import GHC.Data.Bitmap import GHC.Data.FlatBag as FlatBag import GHC.Data.OrdList import GHC.Data.Maybe -import GHC.Types.Name.Env (mkNameEnv) import GHC.Types.Tickish import GHC.Types.SptEntry @@ -82,7 +81,6 @@ import GHC.Unit.Home.PackageTable (lookupHpt) import Data.Array import Data.Coerce (coerce) -import Data.ByteString (ByteString) #if MIN_VERSION_rts(1,0,3) import qualified Data.ByteString.Char8 as BS #endif @@ -118,19 +116,15 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks spt_entries bnd <- binds case bnd of StgTopLifted bnd -> [Right bnd] - StgTopStringLit b str -> [Left (b, str)] + StgTopStringLit b str -> [Left (getName b, str)] flattenBind (StgNonRec b e) = [(b,e)] flattenBind (StgRec bs) = bs - stringPtrs <- allocateTopStrings interp strings (BcM_State{..}, proto_bcos) <- runBc hsc_env this_mod mb_modBreaks $ do let flattened_binds = concatMap flattenBind (reverse lifted_binds) FlatBag.fromList (fromIntegral $ length flattened_binds) <$> mapM schemeTopBind flattened_binds - when (notNull ffis) - (panic "GHC.StgToByteCode.byteCodeGen: missing final emitBc?") - putDumpFileMaybe logger Opt_D_dump_BCOs "Proto-BCOs" FormatByteCode (vcat (intersperse (char ' ') (map ppr $ elemsFlatBag proto_bcos))) @@ -138,7 +132,7 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks spt_entries let mod_breaks = case modBreaks of Nothing -> Nothing Just mb -> Just mb{ modBreaks_breakInfo = breakInfo } - cbc <- assembleBCOs interp profile proto_bcos tycs stringPtrs mod_breaks spt_entries + cbc <- assembleBCOs profile proto_bcos tycs strings mod_breaks spt_entries -- Squash space leaks in the CompiledByteCode. This is really -- important, because when loading a set of modules into GHCi @@ -152,22 +146,8 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks spt_entries where dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env - interp = hscInterp hsc_env profile = targetProfile dflags --- | see Note [Generating code for top-level string literal bindings] -allocateTopStrings - :: Interp - -> [(Id, ByteString)] - -> IO AddrEnv -allocateTopStrings interp topStrings = do - let !(bndrs, strings) = unzip topStrings - ptrs <- interpCmd interp $ MallocStrings strings - return $ mkNameEnv (zipWith mk_entry bndrs ptrs) - where - mk_entry bndr ptr = let nm = getName bndr - in (nm, (nm, AddrPtr ptr)) - {- Note [Generating code for top-level string literal bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As described in Note [Compilation plan for top-level string literals] @@ -178,9 +158,9 @@ the bytecode compiler: (1) compiling the bindings themselves, and we deal with them: 1. Top-level string literal bindings are separated from the rest of - the module. Memory for them is allocated immediately, via - interpCmd, in allocateTopStrings, and the resulting AddrEnv is - recorded in the bc_strs field of the CompiledByteCode result. + the module. Memory is not allocated until bytecode link-time, the + bc_strs field of the CompiledByteCode result records [(Name, ByteString)] + directly. 2. When we encounter a reference to a top-level string literal, we generate a PUSH_ADDR pseudo-instruction, which is assembled to @@ -254,17 +234,15 @@ mkProtoBCO -> WordOff -- ^ bitmap size -> [StgWord] -- ^ bitmap -> Bool -- ^ True <=> is a return point, rather than a function - -> [FFIInfo] -> ProtoBCO Name -mkProtoBCO platform _add_bco_name nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis +mkProtoBCO platform _add_bco_name nm instrs_ordlist origin arity bitmap_size bitmap is_ret = ProtoBCO { protoBCOName = nm, protoBCOInstrs = maybe_add_bco_name $ maybe_add_stack_check peep_d, protoBCOBitmap = bitmap, protoBCOBitmapSize = fromIntegral bitmap_size, protoBCOArity = arity, - protoBCOExpr = origin, - protoBCOFFIs = ffis + protoBCOExpr = origin } where #if MIN_VERSION_rts(1,0,3) @@ -334,7 +312,7 @@ schemeTopBind (id, rhs) -- by just re-using the single top-level definition. So -- for the worker itself, we must allocate it directly. -- ioToBc (putStrLn $ "top level BCO") - emitBc (mkProtoBCO platform add_bco_name + pure (mkProtoBCO platform add_bco_name (getName id) (toOL [PACK data_con 0, RETURN P]) (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) @@ -399,7 +377,7 @@ schemeR_wrk fvs nm original_body (args, body) bitmap = mkBitmap platform bits body_code <- schemeER_wrk sum_szsb_args p_init body - emitBc (mkProtoBCO platform add_bco_name nm body_code (Right original_body) + pure (mkProtoBCO platform add_bco_name nm body_code (Right original_body) arity bitmap_size bitmap False{-not alts-}) -- | Introduce break instructions for ticked expressions. @@ -478,7 +456,7 @@ break_info hsc_env mod current_mod current_mod_breaks where check_mod_ptr mb | mod_ptr <- modBreaks_module mb - , fromRemotePtr mod_ptr /= nullPtr + , not $ nullFS $ moduleNameFS mod_ptr = Just mb | otherwise = Nothing @@ -546,7 +524,7 @@ returnUnliftedReps d s szb reps = do -- otherwise use RETURN_TUPLE with a tuple descriptor nv_reps -> do let (call_info, args_offsets) = layoutNativeCall profile NativeTupleReturn 0 id nv_reps - tuple_bco <- emitBc (tupleBCO platform call_info args_offsets) + tuple_bco = tupleBCO platform call_info args_offsets return $ PUSH_UBX (mkNativeCallInfoLit platform call_info) 1 `consOL` PUSH_BCO tuple_bco `consOL` unitOL RETURN_TUPLE @@ -1097,16 +1075,15 @@ doCase d s p scrut bndr alts scrut_code <- schemeE (d + ret_frame_size_b + save_ccs_size_b) (d + ret_frame_size_b + save_ccs_size_b) p scrut - alt_bco' <- emitBc alt_bco if ubx_tuple_frame - then do tuple_bco <- emitBc (tupleBCO platform call_info args_offsets) - return (PUSH_ALTS_TUPLE alt_bco' call_info tuple_bco + then do let tuple_bco = tupleBCO platform call_info args_offsets + return (PUSH_ALTS_TUPLE alt_bco call_info tuple_bco `consOL` scrut_code) else let scrut_rep = case non_void_arg_reps of [] -> V [rep] -> rep _ -> panic "schemeE(StgCase).push_alts" - in return (PUSH_ALTS alt_bco' scrut_rep `consOL` scrut_code) + in return (PUSH_ALTS alt_bco scrut_rep `consOL` scrut_code) -- ----------------------------------------------------------------------------- @@ -1398,7 +1375,7 @@ Note [unboxed tuple bytecodes and tuple_BCO] -} -tupleBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name +tupleBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> ProtoBCO Name tupleBCO platform args_info args = mkProtoBCO platform Nothing invented_name body_code (Left []) 0{-no arity-} bitmap_size bitmap False{-is alts-} @@ -1419,7 +1396,7 @@ tupleBCO platform args_info args = body_code = mkSlideW 0 1 -- pop frame header `snocOL` RETURN_TUPLE -- and add it again -primCallBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name +primCallBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> ProtoBCO Name primCallBCO platform args_info args = mkProtoBCO platform Nothing invented_name body_code (Left []) 0{-no arity-} bitmap_size bitmap False{-is alts-} @@ -1528,7 +1505,7 @@ generatePrimCall d s p target _mb_unit _result_ty args massert (off == dd + szb) go (dd + szb) (push:pushes) cs push_args <- go d [] shifted_args_offsets - args_bco <- emitBc (primCallBCO platform args_info prim_args_offsets) + let args_bco = primCallBCO platform args_info prim_args_offsets return $ mconcat push_args `appOL` (push_target `consOL` push_info `consOL` @@ -1706,13 +1683,10 @@ generateCCall d0 s p (CCallSpec target _ safety) result_ty args let ffires = primRepToFFIType platform r_rep ffiargs = map (primRepToFFIType platform) a_reps - interp <- hscInterp <$> getHscEnv - token <- ioToBc $ interpCmd interp (PrepFFI ffiargs ffires) - recordFFIBc token let -- do the call - do_call = unitOL (CCALL stk_offset token flags) + do_call = unitOL (CCALL stk_offset (FFIInfo ffiargs ffires) flags) where flags = case safety of PlaySafe -> 0x0 PlayInterruptible -> 0x1 @@ -2311,8 +2285,6 @@ data BcM_State { bcm_hsc_env :: HscEnv , thisModule :: Module -- current module (for breakpoints) , nextlabel :: Word32 -- for generating local labels - , ffis :: [FFIInfo] -- ffi info blocks, to free later - -- Should be free()d when it is GCd , modBreaks :: Maybe ModBreaks -- info about breakpoints , breakInfo :: IntMap CgBreakInfo -- ^ Info at breakpoint occurrence. @@ -2333,7 +2305,7 @@ runBc :: HscEnv -> Module -> Maybe ModBreaks -> BcM r -> IO (BcM_State, r) runBc hsc_env this_mod modBreaks (BcM m) - = m (BcM_State hsc_env this_mod 0 [] modBreaks IntMap.empty 0) + = m (BcM_State hsc_env this_mod 0 modBreaks IntMap.empty 0) thenBc :: BcM a -> (a -> BcM b) -> BcM b thenBc (BcM expr) cont = BcM $ \st0 -> do @@ -2376,14 +2348,6 @@ shouldAddBcoName = do then Just <$> getCurrentModule else return Nothing -emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name) -emitBc bco - = BcM $ \st -> return (st{ffis=[]}, bco (ffis st)) - -recordFFIBc :: RemotePtr C_ffi_cif -> BcM () -recordFFIBc a - = BcM $ \st -> return (st{ffis = FFIInfo a : ffis st}, ()) - getLabelBc :: BcM LocalLabel getLabelBc = BcM $ \st -> do let nl = nextlabel st ===================================== libraries/ghci/GHCi/Message.hs ===================================== @@ -11,6 +11,7 @@ -- module GHCi.Message ( Message(..), Msg(..) + , ConInfoTable(..) , THMessage(..), THMsg(..) , QResult(..) , EvalStatus_(..), EvalStatus, EvalResult(..), EvalOpts(..), EvalExpr(..) @@ -41,6 +42,7 @@ import GHC.ForeignSrcLang import GHC.Fingerprint import GHC.Conc (pseq, par) import Control.Concurrent +import Control.DeepSeq import Control.Exception #if MIN_VERSION_base(4,20,0) import Control.Exception.Context @@ -117,12 +119,7 @@ data Message a where -- | Create an info table for a constructor MkConInfoTable - :: Bool -- TABLES_NEXT_TO_CODE - -> Int -- ptr words - -> Int -- non-ptr words - -> Int -- constr tag - -> Int -- pointer tag - -> ByteString -- constructor desccription + :: !ConInfoTable -> Message (RemotePtr Heap.StgInfoTable) -- | Evaluate a statement @@ -244,16 +241,23 @@ data Message a where :: RemoteRef (ResumeContext ()) -> Message (EvalStatus ()) - -- | Allocate a string for a breakpoint module name. - -- This uses an empty dummy type because @ModuleName@ isn't available here. - NewBreakModule - :: String -- ^ @ModuleName@ - -> BS.ShortByteString -- ^ @UnitId@ for the given @ModuleName@ - -> Message (RemotePtr BreakModule, RemotePtr BreakUnitId) +deriving instance Show (Message a) +-- | Used to dynamically create a data constructor's info table at +-- run-time. +data ConInfoTable = ConInfoTable { + conItblTablesNextToCode :: !Bool, -- ^ TABLES_NEXT_TO_CODE + conItblPtrs :: !Int, -- ^ ptr words + conItblNPtrs :: !Int, -- ^ non-ptr words + conItblConTag :: !Int, -- ^ constr tag + conItblPtrTag :: !Int, -- ^ pointer tag + conItblDescr :: !ByteString -- ^ constructor desccription +} + deriving (Generic, Show) -deriving instance Show (Message a) +instance Binary ConInfoTable +instance NFData ConInfoTable -- | Template Haskell return values data QResult a @@ -568,7 +572,7 @@ getMessage = do 15 -> Msg <$> MallocStrings <$> get 16 -> Msg <$> (PrepFFI <$> get <*> get) 17 -> Msg <$> FreeFFI <$> get - 18 -> Msg <$> (MkConInfoTable <$> get <*> get <*> get <*> get <*> get <*> get) + 18 -> Msg <$> MkConInfoTable <$> get 19 -> Msg <$> (EvalStmt <$> get <*> get) 20 -> Msg <$> (ResumeStmt <$> get <*> get) 21 -> Msg <$> (AbandonStmt <$> get) @@ -589,9 +593,8 @@ getMessage = do 36 -> Msg <$> (Seq <$> get) 37 -> Msg <$> return RtsRevertCAFs 38 -> Msg <$> (ResumeSeq <$> get) - 39 -> Msg <$> (NewBreakModule <$> get <*> get) - 40 -> Msg <$> (LookupSymbolInDLL <$> get <*> get) - 41 -> Msg <$> (WhereFrom <$> get) + 39 -> Msg <$> (LookupSymbolInDLL <$> get <*> get) + 40 -> Msg <$> (WhereFrom <$> get) _ -> error $ "Unknown Message code " ++ (show b) putMessage :: Message a -> Put @@ -615,7 +618,7 @@ putMessage m = case m of MallocStrings bss -> putWord8 15 >> put bss PrepFFI args res -> putWord8 16 >> put args >> put res FreeFFI p -> putWord8 17 >> put p - MkConInfoTable tc p n t pt d -> putWord8 18 >> put tc >> put p >> put n >> put t >> put pt >> put d + MkConInfoTable itbl -> putWord8 18 >> put itbl EvalStmt opts val -> putWord8 19 >> put opts >> put val ResumeStmt opts val -> putWord8 20 >> put opts >> put val AbandonStmt val -> putWord8 21 >> put val @@ -636,9 +639,8 @@ putMessage m = case m of Seq a -> putWord8 36 >> put a RtsRevertCAFs -> putWord8 37 ResumeSeq a -> putWord8 38 >> put a - NewBreakModule name unitid -> putWord8 39 >> put name >> put unitid - LookupSymbolInDLL dll str -> putWord8 40 >> put dll >> put str - WhereFrom a -> putWord8 41 >> put a + LookupSymbolInDLL dll str -> putWord8 39 >> put dll >> put str + WhereFrom a -> putWord8 40 >> put a {- Note [Parallelize CreateBCOs serialization] ===================================== libraries/ghci/GHCi/Run.hs ===================================== @@ -74,7 +74,7 @@ run m = case m of UnloadObj str -> unloadObj str AddLibrarySearchPath str -> toRemotePtr <$> addLibrarySearchPath str RemoveLibrarySearchPath ptr -> removeLibrarySearchPath (fromRemotePtr ptr) - MkConInfoTable tc ptrs nptrs tag ptrtag desc -> + MkConInfoTable (ConInfoTable tc ptrs nptrs tag ptrtag desc) -> toRemotePtr <$> mkConInfoTable tc ptrs nptrs tag ptrtag desc ResolveObjs -> resolveObjs FindSystemLibrary str -> findSystemLibrary str @@ -96,10 +96,6 @@ run m = case m of MkCostCentres mod ccs -> mkCostCentres mod ccs CostCentreStackInfo ptr -> ccsToStrings (fromRemotePtr ptr) NewBreakArray sz -> mkRemoteRef =<< newBreakArray sz - NewBreakModule name unitid -> do - namePtr <- newModuleName name - uidPtr <- newUnitId unitid - pure (namePtr, uidPtr) SetupBreakpoint ref ix cnt -> do arr <- localRef ref; _ <- setupBreakpoint arr ix cnt @@ -440,13 +436,6 @@ mkString0 bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do pokeElemOff (ptr :: Ptr CChar) len 0 return (castRemotePtr (toRemotePtr ptr)) -mkShortByteString0 :: BS.ShortByteString -> IO (RemotePtr ()) -mkShortByteString0 bs = BS.useAsCStringLen bs $ \(cstr,len) -> do - ptr <- mallocBytes (len+1) - copyBytes ptr cstr len - pokeElemOff (ptr :: Ptr CChar) len 0 - return (castRemotePtr (toRemotePtr ptr)) - mkCostCentres :: String -> [(String,String)] -> IO [RemotePtr CostCentre] #if defined(PROFILING) mkCostCentres mod ccs = do @@ -464,14 +453,6 @@ foreign import ccall unsafe "mkCostCentre" mkCostCentres _ _ = return [] #endif -newModuleName :: String -> IO (RemotePtr BreakModule) -newModuleName name = - castRemotePtr . toRemotePtr <$> newCString name - -newUnitId :: BS.ShortByteString -> IO (RemotePtr BreakUnitId) -newUnitId name = - castRemotePtr <$> mkShortByteString0 name - getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue) getIdValFromApStack apStack (I# stackDepth) = do case getApStackVal# apStack stackDepth of ===================================== testsuite/tests/bytecode/T22376/all.T ===================================== @@ -1,2 +1,2 @@ -test('T22376', [req_interp, extra_files(['A.hs', 'B.hs'])], multimod_compile_and_run, +test('T22376', [extra_files(['A.hs', 'B.hs'])], multimod_compile_and_run, ['T22376', '-O1 -fwrite-if-simplified-core -fbyte-code-and-object-code -fprefer-byte-code']) ===================================== testsuite/tests/perf/should_run/ByteCodeAsm.hs ===================================== @@ -49,11 +49,11 @@ instrs = [ STKCHECK 1234 ++ [ PUSH_G appAName | _ <- [0..100] ] ++ [ PUSH_BCO fake_proto2 ] -fake_proto = ProtoBCO appAName instrs [] 0 0 (Left []) [] +fake_proto = ProtoBCO appAName instrs [] 0 0 (Left []) instrs2 = [ STKCHECK 77, UNPACK 4, SLIDE 0 4, ENTER ] -fake_proto2 = ProtoBCO appAName instrs2 [] 0 0 (Left []) [] +fake_proto2 = ProtoBCO appAName instrs2 [] 0 0 (Left []) main :: IO () main = do View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3d08b572dfe99ea851f0c506b19c29… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3d08b572dfe99ea851f0c506b19c29… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T23109a] Better mkDupableContWithDmds
by Simon Peyton Jones (＠simonpj) 13 May '25

13 May '25

Simon Peyton Jones pushed to branch wip/T23109a at Glasgow Haskell Compiler / GHC Commits: 93ba6582 by Simon Peyton Jones at 2025-05-13T16:49:08-04:00 Better mkDupableContWithDmds ...adding DupContFlag - - - - - 1 changed file: - compiler/GHC/Core/Opt/Simplify/Iteration.hs Changes: ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -57,7 +57,7 @@ import GHC.Types.Var ( isTyCoVar ) import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) import GHC.Builtin.Names( runRWKey, seqHashKey ) -import GHC.Data.Maybe ( isJust, orElse, mapMaybe ) +import GHC.Data.Maybe ( isNothing, orElse, mapMaybe ) import GHC.Data.FastString import GHC.Unit.Module ( moduleName ) import GHC.Utils.Outputable @@ -3860,19 +3860,23 @@ altsWouldDup (alt:alts) is_bot_alt (Alt _ _ rhs) = exprIsDeadEnd rhs ------------------------- +data DupContFlag = DupAppsOnly + | DupSelectToo + mkDupableCont :: SimplEnv -> SimplCont -> SimplM ( SimplFloats -- Incoming SimplEnv augmented with -- extra let/join-floats and in-scope variables , SimplCont) -- dup_cont: duplicable continuation mkDupableCont env cont - = mkDupableContWithDmds (zapSubstEnv env) (repeat topDmd) cont + = mkDupableContWithDmds (zapSubstEnv env) DupSelectToo (repeat topDmd) cont mkDupableContWithDmds - :: SimplEnvIS -> [Demand] -- Demands on arguments; always infinite + :: SimplEnvIS -> DupContFlag + -> [Demand] -- Demands on arguments; always infinite -> SimplCont -> SimplM ( SimplFloats, SimplCont) -mkDupableContWithDmds env _ cont +mkDupableContWithDmds env _ _ cont -- Check the invariant | assertPpr (checkSimplEnvIS env) (pprBadSimplEnvIS env) False = pprPanic "mkDupableContWithDmds" empty @@ -3880,20 +3884,63 @@ mkDupableContWithDmds env _ cont | contIsDupable cont = return (emptyFloats env, cont) -mkDupableContWithDmds _ _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn +mkDupableContWithDmds _ _ _ (Stop {}) + = panic "mkDupableCont" -- Handled by previous contIsDupable eqn -mkDupableContWithDmds env dmds (CastIt { sc_co = co, sc_opt = opt, sc_cont = cont }) - = do { (floats, cont') <- mkDupableContWithDmds env dmds cont +mkDupableContWithDmds env df dmds + (CastIt { sc_co = co, sc_opt = opt, sc_cont = cont }) + = do { (floats, cont') <- mkDupableContWithDmds env df dmds cont ; return (floats, CastIt { sc_co = optOutCoercion env co opt , sc_opt = True, sc_cont = cont' }) } -- optOutCoercion: see Note [Avoid re-simplifying coercions] -- Duplicating ticks for now, not sure if this is good or not -mkDupableContWithDmds env dmds (TickIt t cont) - = do { (floats, cont') <- mkDupableContWithDmds env dmds cont +mkDupableContWithDmds env df dmds + (TickIt t cont) + = do { (floats, cont') <- mkDupableContWithDmds env df dmds cont ; return (floats, TickIt t cont') } -mkDupableContWithDmds env _ +mkDupableContWithDmds env df dmds + (ApplyToTy { sc_cont = cont, sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) + = do { (floats, cont') <- mkDupableContWithDmds env df dmds cont + ; return (floats, ApplyToTy { sc_cont = cont' + , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) } + +mkDupableContWithDmds env df dmds + (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se + , sc_cont = cont, sc_hole_ty = hole_ty }) + = -- e.g. [...hole...] (...arg...) + -- ==> + -- let a = ...arg... + -- in [...hole...] a + -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable + do { let dmd:|cont_dmds = expectNonEmpty dmds + ; (floats1, cont') <- mkDupableContWithDmds env df cont_dmds cont + ; let env' = env `setInScopeFromF` floats1 + ; (_, se', arg') <- simplLazyArg env' dup hole_ty Nothing se arg + + -- Make the argument duplicable. Danger: if arg is small and we let-bind + -- it, then postInlineUnconditionally will just inline it again, perhaps + -- taking an extra Simplifier iteration (e.g. in test T21839c). So make + -- a `let` only if `couldBeSmallEnoughToInline` says that it is big enough + ; let uf_opts = seUnfoldingOpts env + ; (let_floats2, arg'') + <- if couldBeSmallEnoughToInline uf_opts (unfoldingUseThreshold uf_opts) arg' + then return (emptyLetFloats, arg') + else makeTrivial env NotTopLevel dmd (fsLit "karg") arg' + + ; let all_floats = floats1 `addLetFloats` let_floats2 + ; return ( all_floats + , ApplyToVal { sc_arg = arg'' + , sc_env = se' `setInScopeFromF` all_floats + -- Ensure that sc_env includes the free vars of + -- arg'' in its in-scope set, even if makeTrivial + -- has turned arg'' into a fresh variable + -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils + , sc_dup = OkToDup, sc_cont = cont' + , sc_hole_ty = hole_ty }) } + +mkDupableContWithDmds env _ _ (StrictBind { sc_bndr = bndr, sc_body = body, sc_from = from_what , sc_env = se, sc_cont = cont}) -- See Note [Duplicating StrictBind] @@ -3910,42 +3957,30 @@ mkDupableContWithDmds env _ ; mkDupableStrictBind env bndr' join_body res_ty } -mkDupableContWithDmds env _ +mkDupableContWithDmds env DupSelectToo _ (StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty }) -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable - | isJust (isDataConId_maybe (ai_fun fun)) + | isNothing (isDataConId_maybe (ai_fun fun)) -- isDataConId: see point (DJ4) of Note [Duplicating join points] - = -- Use Plan B of Note [Duplicating StrictArg] - -- K[ f a b <> ] --> join j x = K[ f a b x ] - -- j <> - do { let rhs_ty = contResultType cont - (m,arg_ty,_) = splitFunTy fun_ty - ; arg_bndr <- newId (fsLit "arg") m arg_ty - ; let env' = env `addNewInScopeIds` [arg_bndr] - ; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (Var arg_bndr) fun_ty) cont - ; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty } - - | otherwise = -- Use Plan C of Note [Duplicating StrictArg] - -- K[ f a b <> ] --> join j x = K[ x ] - -- K1[ f a b <> ] + -- StrictArg (f a b <>) : ApplyTo e1 : ApplyTo e2: K + -- --> join j x = rebuild x K + -- let x1 = e2; x2 = e2 + -- StrictArg (f a b <>) : ApplyTo x1 : ApplyTo x2 : StrictArg (j <>) : Stop -- where K1 = j <> - do { let rhs_ty = contResultType cont - (m,_,res_ty) = splitFunTy fun_ty - ; (floats, cont') <- - if contIsTrivial cont - then return (emptyFloats env, cont) - else do { arg_bndr <- newId (fsLit "arg") m res_ty - ; let env' = env `addNewInScopeIds` [arg_bndr] - ; rhs' <- simplExprC env' (Var arg_bndr) cont - ; mkDupableStrictBind env' arg_bndr rhs' rhs_ty } + do { let _ :| dmds = expectNonEmpty $ ai_dmds fun ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg env) (ai_args fun) + ; (floats, cont') <- mkDupableContWithDmds env DupAppsOnly dmds cont + -- Use the demands from the function to add the right + -- demand info on any bindings we make for further args + ; return ( foldl' addLetFloats floats floats_s , StrictArg { sc_fun = fun { ai_args = args' } , sc_cont = cont', sc_dup = OkToDup, sc_fun_ty = fun_ty }) } + {- -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable | isNothing (isDataConId_maybe (ai_fun fun)) @@ -3991,47 +4026,7 @@ mkDupableContWithDmds env _ -} -} -mkDupableContWithDmds env dmds - (ApplyToTy { sc_cont = cont, sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) - = do { (floats, cont') <- mkDupableContWithDmds env dmds cont - ; return (floats, ApplyToTy { sc_cont = cont' - , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) } - -mkDupableContWithDmds env dmds - (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se - , sc_cont = cont, sc_hole_ty = hole_ty }) - = -- e.g. [...hole...] (...arg...) - -- ==> - -- let a = ...arg... - -- in [...hole...] a - -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable - do { let dmd:|cont_dmds = expectNonEmpty dmds - ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont - ; let env' = env `setInScopeFromF` floats1 - ; (_, se', arg') <- simplLazyArg env' dup hole_ty Nothing se arg - - -- Make the argument duplicable. Danger: if arg is small and we let-bind - -- it, then postInlineUnconditionally will just inline it again, perhaps - -- taking an extra Simplifier iteration (e.g. in test T21839c). So make - -- a `let` only if `couldBeSmallEnoughToInline` says that it is big enough - ; let uf_opts = seUnfoldingOpts env - ; (let_floats2, arg'') - <- if couldBeSmallEnoughToInline uf_opts (unfoldingUseThreshold uf_opts) arg' - then return (emptyLetFloats, arg') - else makeTrivial env NotTopLevel dmd (fsLit "karg") arg' - - ; let all_floats = floats1 `addLetFloats` let_floats2 - ; return ( all_floats - , ApplyToVal { sc_arg = arg'' - , sc_env = se' `setInScopeFromF` all_floats - -- Ensure that sc_env includes the free vars of - -- arg'' in its in-scope set, even if makeTrivial - -- has turned arg'' into a fresh variable - -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils - , sc_dup = OkToDup, sc_cont = cont' - , sc_hole_ty = hole_ty }) } - -mkDupableContWithDmds env _ +mkDupableContWithDmds env _ _ (Select { sc_bndr = case_bndr, sc_alts = alts, sc_env = se, sc_cont = cont }) = -- e.g. (case [...hole...] of { pi -> ei }) -- ===> @@ -4074,6 +4069,17 @@ mkDupableContWithDmds env _ -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils , sc_cont = mkBoringStop (contResultType cont) } ) } +mkDupableContWithDmds env _ _ cont + = -- Use Plan B of Note [Duplicating StrictArg] + -- K --> join j x = K[ x ] + -- j <> + do { let arg_ty = contHoleType cont + rhs_ty = contResultType cont + ; arg_bndr <- newId (fsLit "arg") ManyTy arg_ty + ; let env' = env `addNewInScopeIds` [arg_bndr] + ; (floats, join_rhs) <- simplOutId env' arg_bndr cont + ; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty } + mkDupableStrictBind :: SimplEnv -> OutId -> OutExpr -> OutType -> SimplM (SimplFloats, SimplCont) -- mkDupableStrictBind env arg body rhs_ty View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/93ba6582e803468fe73a2042a7018b5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/93ba6582e803468fe73a2042a7018b5… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 15 commits: Add LoongArch NCG support
by Marge Bot (＠marge-bot) 13 May '25

13 May '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: c69da4f2 by Peng Fan at 2025-05-13T16:31:50-04:00 Add LoongArch NCG support Not supported before. - - - - - 16ecd4a2 by Lin Runze at 2025-05-13T16:31:50-04:00 ci: Add LoongArch64 cross-compile CI for testing - - - - - 1ca4e3fe by Cheng Shao at 2025-05-13T16:31:51-04:00 compiler: do not allocate strings in bytecode assembler This patch refactors the compiler to avoid allocating iserv buffers for BCONPtrStr at assemble-time. Now BCONPtrStr ByteStrings are recorded as a part of CompiledByteCode, and actual allocation only happens at link-time. This refactoring is necessary for adding bytecode serialization functionality, as explained by the revised comments in this commit. - - - - - b5603435 by Cheng Shao at 2025-05-13T16:31:51-04:00 compiler: make bc_strs serializable This commit makes the bc_strs field in CompiledByteCode serializable; similar to previous commit, we preserve the ByteString directly and defer the actual allocation to link-time, as mentioned in updated comment. - - - - - b74bd345 by Cheng Shao at 2025-05-13T16:31:51-04:00 compiler: make bc_itbls serializable This commit makes bc_itbls in CompiledByteCode serializable. A dedicated ConInfoTable datatype has been added in ghci which is the recipe for dynamically making a datacon's info table, containing the payload of the MkConInfoTable iserv message. - - - - - 43ce278b by Cheng Shao at 2025-05-13T16:31:51-04:00 compiler: remove FFIInfo bookkeeping in BCO This commit removes the bc_ffis field from CompiledByteCode completely, as well as all the related bookkeeping logic in GHC.StgToByteCode. bc_ffis is actually *unused* in the rest of GHC codebase! It is merely a list of FFIInfo, which is just a remote pointer of the libffi ffi_cif struct; once we allocate the ffi_cif struct and put its pointer in a CCALL instruction, we'll never free it anyway. So there is no point of bookkeeping. - - - - - e1e27174 by Cheng Shao at 2025-05-13T16:31:51-04:00 compiler: make FFIInfo serializable in BCO This commit makes all the FFIInfo needed in CCALL instructions serializable. Previously, when doing STG to BCO lowering, we would allocate a libffi ffi_cif struct and keep its remote pointer as FFIInfo; but actually we can just keep the type signature as FFIInfo and defer the actual allocation to link-time. - - - - - 969f72b9 by Cheng Shao at 2025-05-13T16:31:51-04:00 ghci: remove redundant NewBreakModule message This commit removes the redundant NewBreakModule message from ghci: it just allocates two strings! This functionality can be implemented with existing MallocStrings in one iserv call. - - - - - e244f28d by Cheng Shao at 2025-05-13T16:31:51-04:00 compiler: make breakpoint module name and unit id serializable This commit makes breakpoint module name and unit id serializable, in BRK_FUN instructions as well as ModBreaks. We can simply keep the module name and unit ids, and defer the buffer allocation to link time. - - - - - 339c0ce6 by Cheng Shao at 2025-05-13T16:31:51-04:00 compiler: remove unused newModule This commit removes the now unused newModule function from GHC. - - - - - 6c1e7d7f by Ben Gamari at 2025-05-13T16:31:52-04:00 rts/linker: Don't fail due to RTLD_NOW In !12264 we started using the NativeObj machinery introduced some time ago for loading of shared objects. One of the side-effects of this change is shared objects are now loaded eagerly (i.e. with `RTLD_NOW`). This is needed by NativeObj to ensure full visibility of the mappings of the loaded object, which is in turn needed for safe shared object unloading. Unfortunately, this change subtly regressed, causing compilation failures in some programs. Specifically, shared objects which refer to undefined symbols (e.g. which may be usually provided by either the executable image or libraries loaded via `dlopen`) will fail to load with eager binding. This is problematic as GHC loads all package dependencies while, e.g., evaluating TemplateHaskell splices. This results in compilation failures in programs depending upon (but not using at compile-time) packages with undefined symbol references. To mitigate this NativeObj now first attempts to load an object via eager binding, reverting to lazy binding (and disabling unloading) on failure. See Note [Don't fail due to RTLD_NOW]. Fixes #25943. - - - - - 79bf6bb7 by Sylvain Henry at 2025-05-13T16:31:59-04:00 Deprecate GHC.JS.Prim.Internal.Build (#23432) Deprecated as per CLC proposal 329 (https://github.com/haskell/core-libraries-committee/issues/329) - - - - - e8471164 by Cheng Shao at 2025-05-13T16:32:00-04:00 libffi: update to 3.4.8 Bumps libffi submodule. - - - - - eeb961ea by Matthew Pickering at 2025-05-13T16:32:00-04:00 Remove leftover trace - - - - - acd9d42a by Cheng Shao at 2025-05-13T16:32:01-04:00 Revert "ci: re-enable chrome for wasm ghci browser tests" This reverts commit fee9b351fa5a35d5778d1252789eacaaf5663ae8. Unfortunately the chrome test jobs may still timeout on certain runners (e.g. OpenCape) for unknown reasons. - - - - - 48 changed files: - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml - compiler/CodeGen.Platform.h - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/InfoTable.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Cmm/CLabel.hs - compiler/GHC/CmmToAsm.hs - compiler/GHC/CmmToAsm/Dwarf/Constants.hs - + compiler/GHC/CmmToAsm/LA64.hs - + compiler/GHC/CmmToAsm/LA64/CodeGen.hs - + compiler/GHC/CmmToAsm/LA64/Cond.hs - + compiler/GHC/CmmToAsm/LA64/Instr.hs - + compiler/GHC/CmmToAsm/LA64/Ppr.hs - + compiler/GHC/CmmToAsm/LA64/RegInfo.hs - + compiler/GHC/CmmToAsm/LA64/Regs.hs - compiler/GHC/CmmToAsm/PIC.hs - compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs - compiler/GHC/CmmToAsm/Reg/Linear.hs - compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs - + compiler/GHC/CmmToAsm/Reg/Linear/LA64.hs - compiler/GHC/CmmToAsm/Reg/Target.hs - compiler/GHC/Driver/Backend.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/HsToCore/Breakpoints.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Platform/LoongArch64.hs → compiler/GHC/Platform/LA64.hs - compiler/GHC/Platform/Regs.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/Unit/Module/Graph.hs - compiler/ghc.cabal.in - hadrian/bindist/config.mk.in - hadrian/src/Oracles/Setting.hs - hadrian/src/Settings/Builders/RunTest.hs - libffi-tarballs - libraries/base/changelog.md - libraries/base/src/GHC/JS/Prim/Internal/Build.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - rts/linker/LoadNativeObjPosix.c - testsuite/tests/bytecode/T22376/all.T - testsuite/tests/perf/should_run/ByteCodeAsm.hs - testsuite/tests/rts/all.T - utils/ghc-toolchain/exe/Main.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cc.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/98c125c419c85d41e13d0fc8943d89… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/98c125c419c85d41e13d0fc8943d89… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T25886] 2 commits: base: Fix RestructuredText-isms in changelog
by Ben Gamari (＠bgamari) 13 May '25

13 May '25

Ben Gamari pushed to branch wip/T25886 at Glasgow Haskell Compiler / GHC Commits: f6dba0d4 by Ben Gamari at 2025-05-13T11:33:53-04:00 base: Fix RestructuredText-isms in changelog - - - - - bb234637 by Ben Gamari at 2025-05-13T11:33:57-04:00 base: Note strictness changes made in 4.16.0.0 Addresses #25886. - - - - - 1 changed file: - libraries/base/changelog.md Changes: ===================================== libraries/base/changelog.md ===================================== @@ -308,29 +308,29 @@ * Re-export the `IsList` typeclass from the new `GHC.IsList` module. - * There's a new special function ``withDict`` in ``GHC.Exts``: :: + * There's a new special function `withDict` in `GHC.Exts`: :: withDict :: forall {rr :: RuntimeRep} cls meth (r :: TYPE rr). WithDict cls meth => meth -> (cls => r) -> r - where ``cls`` must be a class containing exactly one method, whose type - must be ``meth``. + where `cls` must be a class containing exactly one method, whose type + must be `meth`. - This function converts ``meth`` to a type class dictionary. - It removes the need for ``unsafeCoerce`` in implementation of reflection + This function converts `meth` to a type class dictionary. + It removes the need for `unsafeCoerce` in implementation of reflection libraries. It should be used with care, because it can introduce incoherent instances. - For example, the ``withTypeable`` function from the - ``Type.Reflection`` module can now be defined as: :: + For example, the `withTypeable` function from the + `Type.Reflection` module can now be defined as: :: withTypeable :: forall k (a :: k) rep (r :: TYPE rep). () => TypeRep a -> (Typeable a => r) -> r withTypeable rep k = withDict @(Typeable a) rep k Note that the explicit type application is required, as the call to - ``withDict`` would be ambiguous otherwise. + `withDict` would be ambiguous otherwise. - This replaces the old ``GHC.Exts.magicDict``, which required + This replaces the old `GHC.Exts.magicDict`, which required an intermediate data type and was less reliable. * `Data.Word.Word64` and `Data.Int.Int64` are now always represented by @@ -348,17 +348,17 @@ * Shipped with GHC 9.2.4 - * winio: make consoleReadNonBlocking not wait for any events at all. + * winio: make `consoleReadNonBlocking` not wait for any events at all. - * winio: Add support to console handles to handleToHANDLE + * winio: Add support to console handles to `handleToHANDLE` ## 4.16.2.0 *May 2022* * Shipped with GHC 9.2.2 - * Export GHC.Event.Internal on Windows (#21245) + * Export `GHC.Event.Internal` on Windows (#21245) - # Documentation Fixes + * Documentation Fixes ## 4.16.1.0 *Feb 2022* @@ -427,10 +427,17 @@ - Newtypes `And`, `Ior`, `Xor` and `Iff` which wrap their argument, and whose `Semigroup` instances are defined using `(.&.)`, `(.|.)`, `xor` - and ```\x y -> complement (x `xor` y)```, respectively. + and `\x y -> complement (x `xor` y)`, respectively. - `oneBits :: FiniteBits a => a`, `oneBits = complement zeroBits`. + * Various folding operations in `GHC.List` are now implemented via strict + folds: + - `sum` + - `product` + - `maximum` + - `minimum` + ## 4.15.0.0 *Feb 2021* * Shipped with GHC 9.0.1 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2981cdeb3f3e3c2a52ef7d81aca1c4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2981cdeb3f3e3c2a52ef7d81aca1c4… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/T25886
by Ben Gamari (＠bgamari) 13 May '25

13 May '25

Ben Gamari pushed new branch wip/T25886 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T25886 You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][ghc-9.12] base: Fix changelog header
by Ben Gamari (＠bgamari) 13 May '25

13 May '25

Ben Gamari pushed to branch ghc-9.12 at Glasgow Haskell Compiler / GHC Commits: e2a6fc9b by Ben Gamari at 2025-05-13T11:25:27-04:00 base: Fix changelog header - - - - - 1 changed file: - libraries/base/changelog.md Changes: ===================================== libraries/base/changelog.md ===================================== @@ -1,6 +1,6 @@ # Changelog for [`base` package](http://hackage.haskell.org/package/base) -## 4.21.0.0 December 2024 +## 4.21.0.0 *December 2024* * Shipped with GHC 9.12.1 * Introduce `Data.Bounded` module exporting the `Bounded` typeclass (finishing [CLC proposal #208](https://github.com/haskell/core-libraries-committee/issues/208)) * Deprecate export of `Bounded` class from `Data.Enum` ([CLC proposal #208](https://github.com/haskell/core-libraries-committee/issues/208)) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e2a6fc9b398b3220c9fedbbb0cd555d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e2a6fc9b398b3220c9fedbbb0cd555d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][ghc-9.12] hadrian: fix bootstrap with 9.12.1
by Ben Gamari (＠bgamari) 13 May '25

13 May '25

Ben Gamari pushed to branch ghc-9.12 at Glasgow Haskell Compiler / GHC Commits: d67c8a9c by Cheng Shao at 2025-05-13T11:21:07-04:00 hadrian: fix bootstrap with 9.12.1 This patch bumps hadrian index-state to fix bootstrap with 9.12.1. (cherry picked from commit e16eae6548743870e77c2c93527bab1d24cff81c) - - - - - 2 changed files: - .gitlab/ci.sh - hadrian/cabal.project Changes: ===================================== .gitlab/ci.sh ===================================== @@ -8,7 +8,7 @@ set -Eeuo pipefail # Configuration: # N.B. You may want to also update the index-state in hadrian/cabal.project. -HACKAGE_INDEX_STATE="2024-10-30T22:56:00Z" +HACKAGE_INDEX_STATE="2025-01-27T17:45:32Z" MIN_HAPPY_VERSION="1.20" MIN_ALEX_VERSION="3.2.6" ===================================== hadrian/cabal.project ===================================== @@ -4,7 +4,7 @@ packages: ./ -- This essentially freezes the build plan for hadrian -- It would be wise to keep this up to date with the state set in .gitlab/ci.sh. -index-state: 2024-10-30T22:56:00Z +index-state: 2025-01-27T17:45:32Z -- unordered-containers-0.2.20-r1 requires template-haskell < 2.22 -- ghc-9.10 has template-haskell-2.22.0.0 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d67c8a9c09275e67086dd00c63afbb4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d67c8a9c09275e67086dd00c63afbb4… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/improve-implicit-lifting-error] Improve error messages when implicit lifting fails
by Matthew Pickering (＠mpickering) 13 May '25

13 May '25

Matthew Pickering pushed to branch wip/improve-implicit-lifting-error at Glasgow Haskell Compiler / GHC Commits: fe034312 by Matthew Pickering at 2025-05-13T16:17:34+01:00 Improve error messages when implicit lifting fails This patch concerns programs which automatically try to fix level errors by inserting `Lift`. For example: ``` foo x = [| x |] ~> foo x = [| $(lift x) |] ``` Before, there were two problems with the message. 1. (#26031), the location of the error was reported as the whole quotation. 2. (#26035), the message just mentions there is no Lift instance, but gives no indicate why the user program needed a Lift instance in the first place. This problem is especially bad when you disable `ImplicitStagePersistence`, so you just end up with a confusing "No instance for" message rather than an error message about levels This patch fixes both these issues. Firstly, `PendingRnSplice` differentiates between a user-written splice and an implicit lift. Then, the Lift instance is precisely requested with a specific origin in the typechecker. If the instance fails to be solved, the message is reported using the `TcRnBadlyLevelled` constructor (like a normal level error). Fixes #26031, #26035 - - - - - 17 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Types/ThLevelIndex.hs - + testsuite/tests/quotes/LiftErrMsg.hs - + testsuite/tests/quotes/LiftErrMsg.stderr - + testsuite/tests/quotes/LiftErrMsgDefer.hs - + testsuite/tests/quotes/LiftErrMsgDefer.stderr - testsuite/tests/quotes/all.T - testsuite/tests/th/TH_Lift.stderr Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -55,6 +55,7 @@ import GHC.Types.SourceText import GHC.Types.SrcLoc import GHC.Types.Tickish (CoreTickish) import GHC.Types.Unique.Set (UniqSet) +import GHC.Types.ThLevelIndex import GHC.Core.ConLike ( conLikeName, ConLike ) import GHC.Unit.Module (ModuleName) import GHC.Utils.Misc @@ -78,7 +79,7 @@ import Data.Foldable ( toList ) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Void (Void) - +import qualified Data.Set as S {- ********************************************************************* * * Expressions proper @@ -2252,8 +2253,12 @@ data UntypedSpliceFlavour deriving Data -- | Pending Renamer Splice +-- There are two types of pending splices: +-- 1. A splice explicitly written by the user, e.g. `[| $(foo) |]` +-- 2. A cross-stage reference which we will attempt to fix by using Lift. data PendingRnSplice = PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr GhcRn) + | PendingImplicitLift (S.Set ThLevelIndex) ThLevelIndex (Maybe GlobalRdrElt) (LIdOccP GhcRn) -- | Pending Type-checker Splice data PendingTcSplice @@ -2346,6 +2351,7 @@ thTyBrackets pp_body = text "[||" <+> pp_body <+> text "||]" instance Outputable PendingRnSplice where ppr (PendingRnSplice _ n e) = pprPendingSplice n e + ppr (PendingImplicitLift _bound _used _gre n) = text "implicit lift:" <+> ppr n instance Outputable PendingTcSplice where ppr (PendingTcSplice n e) = pprPendingSplice n e ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -2027,6 +2027,7 @@ instance ToHie (HsQuote GhcRn) where instance ToHie PendingRnSplice where toHie (PendingRnSplice _ _ e) = toHie e + toHie (PendingImplicitLift _bound _used _gre l) = toHie @(LHsExpr GhcRn) (L (l2l (getLoc l)) (HsVar noExtField l)) instance ToHie PendingTcSplice where toHie (PendingTcSplice _ e) = toHie e ===================================== compiler/GHC/Rename/Expr.hs ===================================== @@ -328,7 +328,7 @@ rnExpr (HsVar _ (L l v)) -- matching GRE and add a name clash error -- (see lookupGlobalOccRn_overloaded, called by lookupExprOccRn). -> do { let sel_name = flSelector $ recFieldLabel fld_info - ; unless (isExact v || isOrig v) $ checkThLocalNameWithLift sel_name + ; unless (isExact v || isOrig v) $ checkThLocalNameWithLift (L (l2l l) (WithUserRdr v sel_name)) ; return (XExpr (HsRecSelRn (FieldOcc v (L l sel_name))), unitFV sel_name) } | nm == nilDataConName @@ -339,8 +339,9 @@ rnExpr (HsVar _ (L l v)) -> rnExpr (ExplicitList noAnn []) | otherwise - -> do { unless (isExact v || isOrig v) (checkThLocalNameWithLift nm) - ; return (HsVar noExtField (L (l2l l) (WithUserRdr v nm)), unitFV nm) } + -> do { let res_name = L (l2l l) (WithUserRdr v nm) + ; unless (isExact v || isOrig v) (checkThLocalNameWithLift res_name) + ; return (HsVar noExtField res_name, unitFV nm) } }}} ===================================== compiler/GHC/Rename/Splice.hs ===================================== @@ -51,7 +51,7 @@ import GHC.Data.FastString import GHC.Utils.Logger import GHC.Utils.Panic import GHC.Driver.Hooks -import GHC.Builtin.Names.TH ( decsQTyConName, expQTyConName, liftName +import GHC.Builtin.Names.TH ( decsQTyConName, expQTyConName , patQTyConName, quoteDecName, quoteExpName , quotePatName, quoteTypeName, typeQTyConName) @@ -184,7 +184,8 @@ rnUntypedBracket e br_body rn_utbracket :: HsQuote GhcPs -> RnM (HsQuote GhcRn, FreeVars) rn_utbracket (VarBr _ flg rdr_name) = do { name <- lookupOccRn (if flg then WL_Term else WL_Type) (unLoc rdr_name) - ; if flg then checkThLocalNameNoLift name else checkThLocalTyName name + ; let res_name = L (l2l (locA rdr_name)) (WithUserRdr (unLoc rdr_name) name) + ; if flg then checkThLocalNameNoLift res_name else checkThLocalTyName name ; check_namespace flg name ; return (VarBr noExtField flg (noLocA name), unitFV name) } @@ -423,9 +424,10 @@ rnUntypedSplice (HsUntypedSpliceExpr annCo expr) rnUntypedSplice (HsQuasiQuote ext quoter quote) = do { -- Rename the quoter; akin to the HsVar case of rnExpr ; quoter' <- lookupOccRn WL_TermVariable quoter + ; let res_name = noLocA (WithUserRdr quoter quoter') ; this_mod <- getModule ; when (nameIsLocalOrFrom this_mod quoter') $ - checkThLocalNameNoLift quoter' + checkThLocalNameNoLift res_name ; return (HsQuasiQuote ext quoter' quote, unitFV quoter') } @@ -932,17 +934,17 @@ checkThLocalTyName name -- | Check whether we are allowed to use a Name in this context (for TH purposes) -- In the case of a level incorrect program, attempt to fix it by using -- a Lift constraint. -checkThLocalNameWithLift :: Name -> RnM () +checkThLocalNameWithLift :: LIdOccP GhcRn -> RnM () checkThLocalNameWithLift = checkThLocalName True -- | Check whether we are allowed to use a Name in this context (for TH purposes) -- In the case of a level incorrect program, do not attempt to fix it by using -- a Lift constraint. -checkThLocalNameNoLift :: Name -> RnM () +checkThLocalNameNoLift :: LIdOccP GhcRn -> RnM () checkThLocalNameNoLift = checkThLocalName False -checkThLocalName :: Bool -> Name -> RnM () -checkThLocalName allow_lifting name +checkThLocalName :: Bool -> LIdOccP GhcRn -> RnM () +checkThLocalName allow_lifting name_var | isUnboundName name -- Do not report two errors for = return () -- $(not_in_scope args) @@ -964,7 +966,9 @@ checkThLocalName allow_lifting name ; dflags <- getDynFlags ; env <- getGlobalRdrEnv ; let mgre = lookupGRE_Name env name - ; checkCrossLevelLifting dflags (LevelCheckSplice name mgre) top_lvl is_local allow_lifting bind_lvl use_lvl use_lvl_idx name } } } + ; checkCrossLevelLifting dflags (LevelCheckSplice name mgre) top_lvl is_local allow_lifting bind_lvl use_lvl use_lvl_idx name_var } } } + where + name = getName name_var -------------------------------------- checkCrossLevelLifting :: DynFlags @@ -975,8 +979,8 @@ checkCrossLevelLifting :: DynFlags -> Set.Set ThLevelIndex -> ThLevel -> ThLevelIndex - -> Name -> TcM () -checkCrossLevelLifting dflags reason top_lvl is_local allow_lifting bind_lvl use_lvl use_lvl_idx name + -> LIdOccP GhcRn -> TcM () +checkCrossLevelLifting dflags reason top_lvl is_local allow_lifting bind_lvl use_lvl use_lvl_idx name_var -- 1. If name is in-scope, at the correct level. | use_lvl_idx `Set.member` bind_lvl = return () -- 2. Name is imported with -XImplicitStagePersistence @@ -993,52 +997,26 @@ checkCrossLevelLifting dflags reason top_lvl is_local allow_lifting bind_lvl use , any (use_lvl_idx >=) (Set.toList bind_lvl) , allow_lifting = do - dflags <- getDynFlags - check_cross_level_lifting dflags top_lvl name ps_var + let mgre = case reason of + LevelCheckSplice _ gre -> gre + _ -> Nothing + let pend_splice = PendingImplicitLift bind_lvl use_lvl_idx mgre name_var + -- Warning for implicit lift (#17804) + addDetailedDiagnostic (TcRnImplicitLift name) + + -- Update the pending splices + ps <- readMutVar ps_var + writeMutVar ps_var (pend_splice : ps) -- 5. For a typed bracket, these checks happen again later on (checkThLocalId) -- In the future we should do all the level checks here. | Brack _ RnPendingTyped <- use_lvl -- Lift for typed brackets is inserted later. , any (use_lvl_idx >=) (Set.toList bind_lvl) = return () -- Otherwise, we have a level error, report. - | otherwise = addErrTc (TcRnBadlyLevelled reason bind_lvl use_lvl_idx) - -check_cross_level_lifting :: DynFlags -> TopLevelFlag -> Name -> TcRef [PendingRnSplice] -> TcM () -check_cross_level_lifting dflags top_lvl name ps_var - | isTopLevel top_lvl - , xopt LangExt.ImplicitStagePersistence dflags - -- Top-level identifiers in this module, - -- (which have External Names) - -- are just like the imported case: - -- no need for the 'lifting' treatment - -- E.g. this is fine: - -- f x = x - -- g y = [| f 3 |] - = when (isExternalName name) (keepAlive name) - -- See Note [Keeping things alive for Template Haskell] + | otherwise = addErrTc (TcRnBadlyLevelled reason bind_lvl use_lvl_idx Nothing ErrorWithoutFlag) + where + name = getName name_var - | otherwise - = -- Nested identifiers, such as 'x' in - -- E.g. \x -> [| h x |] - -- We must behave as if the reference to x was - -- h $(lift x) - -- We use 'x' itself as the SplicePointName, used by - -- the desugarer to stitch it all back together. - -- If 'x' occurs many times we may get many identical - -- bindings of the same SplicePointName, but that doesn't - -- matter, although it's a mite untidy. - do { traceRn "checkCrossLevelLifting" (ppr name) - - -- Construct the (lift x) expression - ; let lift_expr = nlHsApp (nlHsVar liftName) (nlHsVar name) - pend_splice = PendingRnSplice UntypedExpSplice name lift_expr - - -- Warning for implicit lift (#17804) - ; addDetailedDiagnostic (TcRnImplicitLift name) - - -- Update the pending splices - ; ps <- readMutVar ps_var - ; writeMutVar ps_var (pend_splice : ps) } checkCrossLevelLiftingTy :: DynFlags -> TopLevelFlag -> Set.Set ThLevelIndex -> ThLevel -> ThLevelIndex -> Name -> TcM () checkCrossLevelLiftingTy dflags top_lvl bind_lvl _use_lvl use_lvl_idx name ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -610,6 +610,7 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics report1 = [ ("custom_error", is_user_type_error, True, mkUserTypeErrorReporter) -- (Handles TypeError and Unsatisfiable) + , ("implicit lifting", is_implicit_lifting, True, mkImplicitLiftingReporter) , given_eq_spec , ("insoluble2", utterly_wrong, True, mkGroupReporter mkEqErr) , ("skolem eq1", very_wrong, True, mkSkolReporter) @@ -671,6 +672,11 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics -- See also Note [Implementation of Unsatisfiable constraints], point (F). is_user_type_error item _ = containsUserTypeError (errorItemPred item) + is_implicit_lifting item _ = + case (errorItemOrigin item) of + ImplicitLiftOrigin {} -> True + _ -> False + is_homo_equality _ (EqPred _ ty1 ty2) = typeKind ty1 `tcEqType` typeKind ty2 is_homo_equality _ _ @@ -1082,7 +1088,7 @@ mkUserTypeErrorReporter :: Reporter mkUserTypeErrorReporter ctxt = mapM_ $ \item -> do { let err = important ctxt $ mkUserTypeError item ; maybeReportError ctxt (item :| []) err - ; addDeferredBinding err item } + ; addSolverDeferredBinding err item } mkUserTypeError :: ErrorItem -> TcSolverReportMsg mkUserTypeError item @@ -1095,6 +1101,21 @@ mkUserTypeError item where pty = errorItemPred item +mkImplicitLiftingReporter :: Reporter +mkImplicitLiftingReporter ctxt + = mapM_ $ \item -> do { let err = mkImplicitLiftingError item + ; msg <- mkErrorReport (ctLocEnv (errorItemCtLoc item)) err (Just ctxt) [] [] + ; reportDiagnostic msg + ; addDeferredBinding ctxt [] [] err item + } + + where + mkImplicitLiftingError :: ErrorItem -> TcRnMessage + mkImplicitLiftingError item = + case errorItemOrigin item of + ImplicitLiftOrigin bound used gre name -> TcRnBadlyLevelled (LevelCheckSplice name gre) bound used (Just item) (cec_defer_type_errors ctxt) + _ -> pprPanic "mkImplicitLiftingError" (ppr item) + mkGivenErrorReporter :: Reporter -- See Note [Given errors] mkGivenErrorReporter ctxt (item:|_) @@ -1192,7 +1213,7 @@ reportGroup mk_err ctxt items ; maybeReportError ctxt items err -- But see Note [Always warn with -fdefer-type-errors] ; traceTc "reportGroup" (ppr items) - ; mapM_ (addDeferredBinding err) items } + ; mapM_ (addSolverDeferredBinding err) items } -- Add deferred bindings for all -- Redundant if we are going to abort compilation, -- but that's hard to know for sure, and if we don't @@ -1225,15 +1246,23 @@ maybeReportError ctxt items@(item1:|_) (SolverReport { sr_important_msg = import msg <- mkErrorReport (ctLocEnv (errorItemCtLoc item1)) diag (Just ctxt) supp hints reportDiagnostic msg -addDeferredBinding :: SolverReport -> ErrorItem -> TcM () +addSolverDeferredBinding :: SolverReport -> ErrorItem -> TcM () +addSolverDeferredBinding err item = + let ctxt = reportContext . sr_important_msg $ err + supp = sr_supplementary err + hints = sr_hints err + important = sr_important_msg err + in addDeferredBinding ctxt supp hints (TcRnSolverReport important ErrorWithoutFlag) item + + +addDeferredBinding :: SolverReportErrCtxt -> [SupplementaryInfo] -> [GhcHint] -> TcRnMessage -> ErrorItem -> TcM () -- See Note [Deferring coercion errors to runtime] -addDeferredBinding err (EI { ei_evdest = Just dest - , ei_pred = item_ty - , ei_loc = loc }) +addDeferredBinding ctxt supp hints msg (EI { ei_evdest = Just dest + , ei_pred = item_ty + , ei_loc = loc }) -- if evdest is Just, then the constraint was from a wanted - | let ctxt = reportContext . sr_important_msg $ err - , deferringAnyBindings ctxt - = do { err_tm <- mkErrorTerm loc item_ty err + | deferringAnyBindings ctxt + = do { err_tm <- mkErrorTerm loc item_ty ctxt msg supp hints ; let ev_binds_var = cec_binds ctxt ; case dest of @@ -1244,15 +1273,24 @@ addDeferredBinding err (EI { ei_evdest = Just dest let co_var = coHoleCoVar hole ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var EvNonCanonical err_tm ; fillCoercionHole hole (mkCoVarCo co_var) } } -addDeferredBinding _ _ = return () -- Do not set any evidence for Given +addDeferredBinding _ _ _ _ _ = return () -- Do not set any evidence for Given + +mkSolverErrorTerm :: CtLoc -> Type -- of the error term + -> SolverReport -> TcM EvTerm +mkSolverErrorTerm ct_loc ty err + = mkErrorTerm ct_loc ty (reportContext . sr_important_msg $ err) + (TcRnSolverReport (sr_important_msg err) ErrorWithoutFlag) + (sr_supplementary err) + (sr_hints err) mkErrorTerm :: CtLoc -> Type -- of the error term - -> SolverReport -> TcM EvTerm -mkErrorTerm ct_loc ty (SolverReport { sr_important_msg = important, sr_supplementary = supp, sr_hints = hints }) + -> SolverReportErrCtxt -> TcRnMessage + -> [SupplementaryInfo] -> [GhcHint] -> TcM EvTerm +mkErrorTerm ct_loc ty ctxt msg supp hints = do { msg <- mkErrorReport (ctLocEnv ct_loc) - (TcRnSolverReport important ErrorWithoutFlag) - (Just $ reportContext important) + msg + (Just $ ctxt) supp hints -- This will be reported at runtime, so we always want "error:" in the report, never "warning:" @@ -1526,7 +1564,7 @@ maybeAddDeferredBindings hole report = do -- not for holes in partial type signatures -- cf. addDeferredBinding when (deferringAnyBindings ctxt) $ do - err_tm <- mkErrorTerm (hole_loc hole) ref_ty report + err_tm <- mkSolverErrorTerm (hole_loc hole) ref_ty report -- NB: ref_ty, not hole_ty. hole_ty might be rewritten. -- See Note [Holes in expressions] in GHC.Hs.Expr writeMutVar ref err_tm ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -105,6 +105,7 @@ import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Fixity (defaultFixity) +import GHC.Types.ThLevelIndex (pprThBindLevel) import GHC.Iface.Errors.Types import GHC.Iface.Errors.Ppr @@ -1517,23 +1518,8 @@ instance Diagnostic TcRnMessage where hsep [ text "Unknown type variable" <> plural errorVars , text "on the RHS of injectivity condition:" , interpp'SP errorVars ] - TcRnBadlyLevelled reason bind_lvls use_lvl - -> - mkSimpleDecorated $ - vcat $ - [ fsep [ text "Level error:", pprLevelCheckReason reason - , text "is bound at" <+> pprThBindLevel bind_lvls - , text "but used at level" <+> ppr use_lvl] - ] ++ - [ fsep [ text "Hint: quoting" <+> thBrackets (ppUnless (isValName n) "t") (ppr n) - , text "or an enclosing expression" - , text "would allow the quotation to be used at an earlier level" - ] - | LevelCheckSplice n _ <- [reason] - ] ++ - [ "From imports" <+> (ppr (gre_imp gre)) - | LevelCheckSplice _ (Just gre) <- [reason] - , not (isEmptyBag (gre_imp gre)) ] + TcRnBadlyLevelled reason bind_lvls use_lvl lift_attempt _reason + -> pprTcRnBadlyLevelled reason bind_lvls use_lvl lift_attempt TcRnBadlyLevelledType name bind_lvls use_lvl -> mkSimpleDecorated $ text "Badly levelled type:" <+> ppr name <+> @@ -2490,8 +2476,8 @@ instance Diagnostic TcRnMessage where -> ErrorWithoutFlag TcRnUnknownTyVarsOnRhsOfInjCond{} -> ErrorWithoutFlag - TcRnBadlyLevelled{} - -> ErrorWithoutFlag + TcRnBadlyLevelled _ _ _ _ reason + -> reason TcRnBadlyLevelledType{} -> WarningWithFlag Opt_WarnBadlyLevelledTypes TcRnTyThingUsedWrong{} @@ -3389,6 +3375,22 @@ instance Diagnostic TcRnMessage where diagnosticCode = constructorCode @GHC +pprTcRnBadlyLevelled :: LevelCheckReason -> Set.Set ThLevelIndex -> ThLevelIndex -> Maybe ErrorItem -> DecoratedSDoc +pprTcRnBadlyLevelled reason bind_lvls use_lvl lift_attempt = mkDecorated $ + [ fsep [ text "Level error:", pprLevelCheckReason reason + , text "is bound at" <+> pprThBindLevel bind_lvls + , text "but used at level" <+> ppr use_lvl] + ] ++ + [hang (text "Could not be resolved by implicit lifting due to the following error:") 2 + (text "No instance for:" <+> quotes (ppr (errorItemPred item))) + | Just item <- [lift_attempt] + ] ++ + [ vcat (text "Available from the imports:" : ppr_imports (gre_imp gre)) + | LevelCheckSplice _ (Just gre) <- [reason] + , not (isEmptyBag (gre_imp gre)) ] + where + ppr_imports :: Bag ImportSpec -> [SDoc] + ppr_imports = map ((bullet <+>) . ppr ) . bagToList note :: SDoc -> SDoc note note = "Note" <> colon <+> note <> dot @@ -4537,8 +4539,7 @@ pprMismatchMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extra) : pp_givens useful_givens) supplementary = case mb_extra of - Nothing - -> Left [] + Nothing -> Right empty Just (CND_Extra level ty1 ty2) -> mk_supplementary_ea_msg ctxt level ty1 ty2 orig ct_loc = errorItemCtLoc item @@ -7491,6 +7492,3 @@ pprErrCtxtMsg = \case text "in" <+> quotes (ppr req_uid) <> dot -------------------------------------------------------------------------------- - -pprThBindLevel :: Set.Set ThLevelIndex -> SDoc -pprThBindLevel levels_set = text "level" <> pluralSet levels_set <+> pprUnquotedSet levels_set \ No newline at end of file ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -3497,6 +3497,8 @@ data TcRnMessage where :: !LevelCheckReason -- ^ The binding -> !(Set.Set ThLevelIndex) -- ^ The binding levels -> !ThLevelIndex -- ^ The level at which the binding is used. + -> !(Maybe ErrorItem) -- ^ The attempt we made to implicitly lift the binding. + -> DiagnosticReason -- ^ Whether to defer this error or fail -> TcRnMessage {-| TcRnBadlyLevelledWarn is a warning that occurs when a TH type binding is ===================================== compiler/GHC/Tc/Gen/Splice.hs ===================================== @@ -54,6 +54,7 @@ import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType import GHC.Tc.Gen.Expr +import GHC.Tc.Gen.Head import GHC.Tc.Utils.Unify import GHC.Tc.Utils.Env import GHC.Tc.Types.Origin @@ -720,8 +721,8 @@ tcUntypedBracket rn_expr brack ps res_ty -- Match the expected type with the type of all the internal -- splices. They might have further constrained types and if they do -- we want to reflect that in the overall type of the bracket. - ; ps' <- case quoteWrapperTyVarTy <$> brack_info of - Just m_var -> mapM (tcPendingSplice m_var) ps + ; ps' <- case brack_info of + Just q -> mapM (tcPendingSplice q) ps Nothing -> assert (null ps) $ return [] -- Notice that we don't attempt to typecheck the body @@ -781,11 +782,11 @@ brackTy b = --------------- -- | Typechecking a pending splice from a untyped bracket -tcPendingSplice :: TcType -- Metavariable for the expected overall type of the +tcPendingSplice :: QuoteWrapper -- Metavariable for the expected overall type of the -- quotation. -> PendingRnSplice -> TcM PendingTcSplice -tcPendingSplice m_var (PendingRnSplice flavour splice_name expr) +tcPendingSplice (QuoteWrapper _ m_var) (PendingRnSplice flavour splice_name expr) -- See Note [Typechecking Overloaded Quotes] = do { meta_ty <- tcMetaTy meta_ty_name -- Expected type of splice, e.g. m Exp @@ -799,6 +800,26 @@ tcPendingSplice m_var (PendingRnSplice flavour splice_name expr) UntypedPatSplice -> patTyConName UntypedTypeSplice -> typeTyConName UntypedDeclSplice -> decsTyConName + -- Identifiers that are lifted implicitly, such as 'x' in + -- E.g. \x -> [| h x |] + -- We must behave as if the reference to x was + -- h $(lift x) + -- We use 'x' itself as the SplicePointName, used by + -- the desugarer to stitch it all back together. + -- If 'x' occurs many times we may get many identical + -- bindings of the same SplicePointName, but that doesn't + -- matter, although it's a mite untidy. +tcPendingSplice q (PendingImplicitLift bound used gre id_name) + = do { (id_expr, id_ty) <- tcInferId id_name + -- lift :: Quote m' => a -> m' Exp + ; lift <- setSrcSpan (getLocA id_name) $ + newMethodFromName (ImplicitLiftOrigin bound used gre (getName id_name)) + GHC.Builtin.Names.TH.liftName + [getRuntimeRep id_ty, id_ty] + ; let res = nlHsApp (mkLHsWrap (applyQuoteWrapper q) (noLocA lift)) (noLocA id_expr) + + ; return (PendingTcSplice (getName id_name) res) } + --------------- -- Takes a m and tau and returns the type m (TExp tau) ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -1652,7 +1652,7 @@ checkCrossLevelClsInst dflags reason bind_lvls use_lvl_idx is_local -- With ImplicitStagePersistence, using later than bound is fine | xopt LangExt.ImplicitStagePersistence dflags , any (use_lvl_idx >=) bind_lvls = return () - | otherwise = TcM.addErrTc (TcRnBadlyLevelled reason bind_lvls use_lvl_idx) + | otherwise = TcM.addErrTc (TcRnBadlyLevelled reason bind_lvls use_lvl_idx Nothing ErrorWithoutFlag) ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -80,11 +80,13 @@ import GHC.Utils.Monad import GHC.Utils.Misc( HasDebugCallStack ) import GHC.Types.Unique import GHC.Types.Unique.Supply +import GHC.Types.ThLevelIndex import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import qualified Data.Kind as Hs import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Set as S {- ********************************************************************* * * @@ -647,6 +649,7 @@ data CtOrigin Type -- the instance-sig type Type -- the instantiated type of the method | AmbiguityCheckOrigin UserTypeCtxt + | ImplicitLiftOrigin (S.Set ThLevelIndex) ThLevelIndex (Maybe GlobalRdrElt) Name data NonLinearPatternReason = LazyPatternReason @@ -944,6 +947,7 @@ pprCtO (UsageEnvironmentOf x) = hsep [text "multiplicity of", quotes (ppr x)] pprCtO (OmittedFieldOrigin Nothing) = text "an omitted anonymous field" pprCtO (OmittedFieldOrigin (Just fl)) = hsep [text "omitted field" <+> quotes (ppr fl)] pprCtO BracketOrigin = text "a quotation bracket" +pprCtO (ImplicitLiftOrigin _ _ _ n) = text "an implicit lift of" <+> quotes (ppr n) -- These ones are handled by pprCtOrigin, but we nevertheless sometimes -- get here via callStackOriginFS, when doing ambiguity checks @@ -978,7 +982,6 @@ pprNonLinearPatternReason PatternSynonymReason = parens (text "pattern synonyms pprNonLinearPatternReason ViewPatternReason = parens (text "view patterns aren't linear") pprNonLinearPatternReason OtherPatternReason = empty - {- ********************************************************************* * * CallStacks and CtOrigin ===================================== compiler/GHC/Types/ThLevelIndex.hs ===================================== @@ -3,9 +3,10 @@ module GHC.Types.ThLevelIndex where import GHC.Prelude import GHC.Utils.Outputable import GHC.Types.Basic ( ImportLevel(..) ) - +import Data.Data (Data) +import qualified Data.Set as Set -- | The integer which represents the level -newtype ThLevelIndex = ThLevelIndex Int deriving (Eq, Ord) +newtype ThLevelIndex = ThLevelIndex Int deriving (Eq, Ord, Data) -- NB: see Note [Template Haskell levels] in GHC.Tc.Gen.Splice -- Incremented when going inside a bracket, -- decremented when going inside a splice @@ -32,4 +33,7 @@ quoteLevelIndex = incThLevelIndex topLevelIndex thLevelIndexFromImportLevel :: ImportLevel -> ThLevelIndex thLevelIndexFromImportLevel NormalLevel = topLevelIndex thLevelIndexFromImportLevel SpliceLevel = spliceLevelIndex -thLevelIndexFromImportLevel QuoteLevel = quoteLevelIndex \ No newline at end of file +thLevelIndexFromImportLevel QuoteLevel = quoteLevelIndex + +pprThBindLevel :: Set.Set ThLevelIndex -> SDoc +pprThBindLevel levels_set = text "level" <> pluralSet levels_set <+> pprUnquotedSet levels_set \ No newline at end of file ===================================== testsuite/tests/quotes/LiftErrMsg.hs ===================================== @@ -0,0 +1,27 @@ +{-# LANGUAGE NoImplicitStagePersistence #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +module LiftErrMsg where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +data B = B + +local_b :: [B] +local_b = [B] + +test :: Q Exp +test = [| id |] + +test2 :: Q Exp +test2 = [| (id, id) |] + +test3 :: Q Exp +test3 = [| local_b |] + +test4 :: a -> Q Exp +test4 x = [| x |] + +test5 :: Lift a => a -> Q Exp +test5 x = [| x |] + ===================================== testsuite/tests/quotes/LiftErrMsg.stderr ===================================== @@ -0,0 +1,38 @@ +LiftErrMsg.hs:14:11: error: [GHC-28914] + • Level error: ‘id’ is bound at level 0 but used at level 1 + • Could not be resolved by implicit lifting due to the following error: + No instance for: ‘Lift (forall a. a -> a)’ + • Available from the imports: + • imported from ‘Prelude’ at LiftErrMsg.hs:3:8-17 + • In the expression: + [| id |] + pending(rn) [implicit lift: id] + In an equation for ‘test’: + test + = [| id |] + pending(rn) [implicit lift: id] + +LiftErrMsg.hs:20:12: error: [GHC-28914] + • Level error: ‘local_b’ is bound at level 0 but used at level 1 + • Could not be resolved by implicit lifting due to the following error: + No instance for: ‘Lift B’ + • In the expression: + [| local_b |] + pending(rn) [implicit lift: local_b] + In an equation for ‘test3’: + test3 + = [| local_b |] + pending(rn) [implicit lift: local_b] + +LiftErrMsg.hs:23:14: error: [GHC-28914] + • Level error: ‘x’ is bound at level 0 but used at level 1 + • Could not be resolved by implicit lifting due to the following error: + No instance for: ‘Lift a’ + • In the expression: + [| x |] + pending(rn) [implicit lift: x] + In an equation for ‘test4’: + test4 x + = [| x |] + pending(rn) [implicit lift: x] + ===================================== testsuite/tests/quotes/LiftErrMsgDefer.hs ===================================== @@ -0,0 +1,26 @@ +{-# LANGUAGE NoImplicitStagePersistence #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +module Main where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +data B = B + +local_b :: [B] +local_b = [B] + +test1 :: Q Exp +test1 = [| id |] + +test2 :: Q Exp +test2 = [| (id, id) |] + +test3 :: Q Exp +test3 = [| local_b |] + +main = do + runQ test1 + runQ test2 + runQ test3 + return () ===================================== testsuite/tests/quotes/LiftErrMsgDefer.stderr ===================================== @@ -0,0 +1,22 @@ +LiftErrMsgDefer: Uncaught exception ghc-internal:GHC.Internal.Control.Exception.Base.TypeError: + +LiftErrMsgDefer.hs:14:12: warning: [GHC-28914] [-Wdeferred-type-errors (in -Wdefault)] + • Level error: ‘id’ is bound at level 0 but used at level 1 + • Could not be resolved by implicit lifting due to the following error: + No instance for: ‘Lift (forall a. a -> a)’ + • Available from the imports: + • imported from ‘Prelude’ at LiftErrMsgDefer.hs:3:8-11 + • In the expression: + [| id |] + pending(rn) [implicit lift: id] + In an equation for ‘test1’: + test1 + = [| id |] + pending(rn) [implicit lift: id] +(deferred type error) + +HasCallStack backtrace: + collectBacktraces, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:169:13 in ghc-internal:GHC.Internal.Exception + toExceptionWithBacktrace, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:89:42 in ghc-internal:GHC.Internal.Exception + throw, called at libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs:435:30 in ghc-internal:GHC.Internal.Control.Exception.Base + ===================================== testsuite/tests/quotes/all.T ===================================== @@ -43,3 +43,5 @@ test('T20893', normal, compile_and_run, ['']) test('T21619', normal, compile, ['']) test('T20472_quotes', normal, compile, ['']) test('T24750', normal, compile_and_run, ['']) +test('LiftErrMsg', normal, compile_fail, ['']) +test('LiftErrMsgDefer', [exit_code(1)], compile_and_run, ['-fdefer-type-errors']) ===================================== testsuite/tests/th/TH_Lift.stderr ===================================== @@ -1,161 +1,161 @@ TH_Lift.hs:18:6-39: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (5 :: Integer) ======> 5 TH_Lift.hs:21:6-35: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (5 :: Int) ======> 5 TH_Lift.hs:24:7-37: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (5 :: Int8) ======> 5 TH_Lift.hs:27:7-38: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (5 :: Int16) ======> 5 TH_Lift.hs:30:7-38: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (5 :: Int32) ======> 5 TH_Lift.hs:33:7-38: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (5 :: Int64) ======> 5 TH_Lift.hs:36:6-36: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (5 :: Word) ======> 5 TH_Lift.hs:39:6-37: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (5 :: Word8) ======> 5 TH_Lift.hs:42:6-38: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (5 :: Word16) ======> 5 TH_Lift.hs:45:6-38: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (5 :: Word32) ======> 5 TH_Lift.hs:48:6-38: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (5 :: Word64) ======> 5 TH_Lift.hs:51:7-40: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (5 :: Natural) ======> 5 TH_Lift.hs:54:6-44: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (5 % 3 :: Rational) ======> 1.6666666666666667 TH_Lift.hs:57:7-39: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (pi :: Float) ======> 3.1415927410125732 TH_Lift.hs:60:7-40: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (pi :: Double) ======> 3.141592653589793 TH_Lift.hs:63:6-28: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) 'x' ======> 'x' TH_Lift.hs:66:6-29: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) True ======> True TH_Lift.hs:69:6-35: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (Just 'x') ======> Just 'x' TH_Lift.hs:72:6-58: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (Right False :: Either Char Bool) ======> Right False TH_Lift.hs:75:6-29: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) "hi!" ======> "hi!" TH_Lift.hs:78:6-27: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) () ======> () TH_Lift.hs:81:6-46: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (True, 'x', 4 :: Int) ======> (,,) True 'x' 4 TH_Lift.hs:84:6-41: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) ('a' :| "bcde") ======> (:|) 'a' "bcde" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fe034312f9c4715836cd2b17985b5d3… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fe034312f9c4715836cd2b17985b5d3… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][ghc-9.12] 2 commits: template-haskell: fix haddocks
by Ben Gamari (＠bgamari) 13 May '25

13 May '25

Ben Gamari pushed to branch ghc-9.12 at Glasgow Haskell Compiler / GHC Commits: a2b43e25 by Teo Camarasu at 2025-05-13T10:55:38-04:00 template-haskell: fix haddocks It seems that we need a direct dependency on ghc-internal, otherwise Haddock cannot find our haddocks The bug seems to be caused by Hadrian because if I rebuild with cabal-install (without this extra dependency) then I get accurate Haddocks. Resolves #25705 (cherry picked from commit c3b5b216667d946f096116486b835fe717b2e63a) - - - - - c4535f96 by Teo Camarasu at 2025-05-13T10:58:45-04:00 template-haskell: Add explicit exports lists to all remaining modules - - - - - 4 changed files: - libraries/template-haskell/Language/Haskell/TH/Ppr.hs - libraries/template-haskell/Language/Haskell/TH/PprLib.hs - libraries/template-haskell/Language/Haskell/TH/Syntax.hs - libraries/template-haskell/template-haskell.cabal.in Changes: ===================================== libraries/template-haskell/Language/Haskell/TH/Ppr.hs ===================================== @@ -1,9 +1,91 @@ {-# LANGUAGE Safe #-} --- | contains a prettyprinter for the --- Template Haskell datatypes -module Language.Haskell.TH.Ppr - ( module GHC.Internal.TH.Ppr ) - where +{- | contains a prettyprinter for the +Template Haskell datatypes +-} +module Language.Haskell.TH.Ppr ( + appPrec, + bar, + bytesToString, + commaSep, + commaSepApplied, + commaSepWith, + fromTANormal, + funPrec, + hashParens, + isStarT, + isSymOcc, + nestDepth, + noPrec, + opPrec, + parensIf, + pprBangType, + pprBndrVis, + pprBody, + pprClause, + pprCtxWith, + pprCxt, + pprExp, + pprFields, + pprFixity, + pprForall, + pprForall', + pprForallVis, + pprFunArgType, + pprGadtRHS, + pprGuarded, + pprInfixExp, + pprInfixT, + pprLit, + pprMatchPat, + pprMaybeExp, + pprNamespaceSpecifier, + pprParendType, + pprParendTypeArg, + pprPat, + pprPatSynSig, + pprPatSynType, + pprPrefixOcc, + pprRecFields, + pprStrictType, + pprString, + pprTyApp, + pprTyLit, + pprType, + pprVarBangType, + pprVarStrictType, + ppr_bndrs, + ppr_ctx_preds_with, + ppr_cxt_preds, + ppr_data, + ppr_dec, + ppr_deriv_clause, + ppr_deriv_strategy, + ppr_newtype, + ppr_overlap, + ppr_sig, + ppr_tf_head, + ppr_tySyn, + ppr_type_data, + ppr_typedef, + pprint, + qualPrec, + quoteParens, + semiSep, + semiSepWith, + sepWith, + showtextl, + sigPrec, + split, + unboxedSumBars, + unopPrec, + where_clause, + ForallVisFlag (..), + Ppr (..), + PprFlag (..), + Precedence, + TypeArg (..), +) +where import GHC.Internal.TH.Ppr ===================================== libraries/template-haskell/Language/Haskell/TH/PprLib.hs ===================================== @@ -1,8 +1,56 @@ {-# LANGUAGE Safe #-} -- | Monadic front-end to Text.PrettyPrint -module Language.Haskell.TH.PprLib - ( module GHC.Internal.TH.PprLib ) - where +module Language.Haskell.TH.PprLib ( + ($$), + ($+$), + (<+>), + (<>), + arrow, + braces, + brackets, + cat, + char, + colon, + comma, + dcolon, + double, + doubleQuotes, + empty, + equals, + fcat, + float, + fsep, + hang, + hcat, + hsep, + int, + integer, + isEmpty, + lbrace, + lbrack, + lparen, + nest, + parens, + pprName, + pprName', + ptext, + punctuate, + quotes, + rational, + rbrace, + rbrack, + rparen, + semi, + sep, + space, + text, + to_HPJ_Doc, + vcat, + Doc, + PprM, +) +where import GHC.Internal.TH.PprLib +import Prelude () ===================================== libraries/template-haskell/Language/Haskell/TH/Syntax.hs ===================================== @@ -2,13 +2,196 @@ {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE Trustworthy #-} -module Language.Haskell.TH.Syntax - ( module GHC.Internal.TH.Syntax - , makeRelativeToProject - , module GHC.Internal.TH.Lift - , addrToByteArrayName - , addrToByteArray - ) +{-# LANGUAGE UnboxedTuples #-} + +module Language.Haskell.TH.Syntax ( + Quote (..), + Exp (..), + Match (..), + Clause (..), + Q (..), + Pat (..), + Stmt (..), + Con (..), + Type (..), + Dec (..), + BangType, + VarBangType, + FieldExp, + FieldPat, + Name (..), + FunDep (..), + Pred, + RuleBndr (..), + TySynEqn (..), + InjectivityAnn (..), + Kind, + Overlap (..), + DerivClause (..), + DerivStrategy (..), + Code (..), + ModName (..), + addCorePlugin, + addDependentFile, + addForeignFile, + addForeignFilePath, + addForeignSource, + addModFinalizer, + addTempFile, + addTopDecls, + badIO, + bindCode, + bindCode_, + cmpEq, + compareBytes, + counter, + defaultFixity, + eqBytes, + extsEnabled, + getDoc, + getPackageRoot, + getQ, + get_cons_names, + hoistCode, + isExtEnabled, + isInstance, + joinCode, + liftCode, + location, + lookupName, + lookupTypeName, + lookupValueName, + manyName, + maxPrecedence, + memcmp, + mkNameG, + mkNameU, + mkOccName, + mkPkgName, + mk_tup_name, + mkName, + mkNameG_v, + mkNameG_d, + mkNameG_tc, + mkNameL, + mkNameS, + unTypeCode, + mkModName, + unsafeCodeCoerce, + mkNameQ, + mkNameG_fld, + modString, + nameBase, + nameModule, + namePackage, + nameSpace, + newDeclarationGroup, + newNameIO, + occString, + oneName, + pkgString, + putDoc, + putQ, + recover, + reify, + reifyAnnotations, + reifyConStrictness, + reifyFixity, + reifyInstances, + reifyModule, + reifyRoles, + reifyType, + report, + reportError, + reportWarning, + runIO, + sequenceQ, + runQ, + showName, + showName', + thenCmp, + tupleDataName, + tupleTypeName, + unTypeQ, + unboxedSumDataName, + unboxedSumTypeName, + unboxedTupleDataName, + unboxedTupleTypeName, + unsafeTExpCoerce, + ForeignSrcLang (..), + Extension (..), + AnnLookup (..), + AnnTarget (..), + Arity, + Bang (..), + BndrVis (..), + Body (..), + Bytes (..), + Callconv (..), + CharPos, + Cxt, + DecidedStrictness (..), + DocLoc (..), + FamilyResultSig (..), + Fixity (..), + FixityDirection (..), + Foreign (..), + Guard (..), + Info (..), + Inline (..), + InstanceDec, + Lit (..), + Loc (..), + Module (..), + ModuleInfo (..), + NameFlavour (..), + NameIs (..), + NameSpace (..), + NamespaceSpecifier (..), + OccName (..), + ParentName, + PatSynArgs (..), + PatSynDir (..), + PatSynType, + Phases (..), + PkgName (..), + Pragma (..), + Quasi (..), + Range (..), + Role (..), + RuleMatch (..), + Safety (..), + SourceStrictness (..), + SourceUnpackedness (..), + Specificity (..), + Strict, + StrictType, + SumAlt, + SumArity, + TExp (..), + TyLit (..), + TyVarBndr (..), + TypeFamilyHead (..), + Uniq, + Unlifted, + VarStrictType, + makeRelativeToProject, + liftString, + Lift (..), + dataToExpQ, + dataToPatQ, + dataToQa, + falseName, + justName, + leftName, + liftData, + nonemptyName, + nothingName, + rightName, + trueName, + addrToByteArrayName, + addrToByteArray, +) where import GHC.Internal.TH.Syntax @@ -18,7 +201,7 @@ import Data.Array.Byte import GHC.Exts import GHC.ST --- This module completely re-exports 'GHC.Internal.TH.Syntax', +-- This module completely re-exports 'GHC.Boot.TH.Syntax', -- and exports additionally functions that depend on filepath. -- | The input is a filepath, which if relative is offset by the package root. ===================================== libraries/template-haskell/template-haskell.cabal.in ===================================== @@ -53,6 +53,10 @@ Library build-depends: base >= 4.11 && < 4.22, + -- We don't directly depend on any of the modules from `ghc-internal` + -- But we need to depend on it to work around a hadrian bug. + -- See: https://gitlab.haskell.org/ghc/ghc/-/issues/25705 + ghc-internal == @ProjectVersionForLib@.*, ghc-boot-th == @ProjectVersionMunged@ other-modules: View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b30f25591e78d42837eff475bbe25f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b30f25591e78d42837eff475bbe25f… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/T25821
by Ben Gamari (＠bgamari) 13 May '25

13 May '25

Ben Gamari pushed new branch wip/T25821 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T25821 You're receiving this email because of your account on gitlab.haskell.org.

1 0