[Git][ghc/ghc][master] hadrian: Use a response file to invoke GHC for dep gathering.
by Marge Bot (＠marge-bot) 06 Dec '25
by Marge Bot (＠marge-bot) 06 Dec '25
06 Dec '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
9d371d23 by Matthew Pickering at 2025-12-06T11:07:09-05:00
hadrian: Use a response file to invoke GHC for dep gathering.
In some cases we construct an argument list too long for GHC to
handle directly on windows. This happens when we generate
the dependency file because the command line will contain
references to a large number of .hs files.
To avoid this we now invoke GHC using a response file when
generating dependencies to sidestep length limitations.
Note that we only pass the actual file names in the dependency
file. Why? Because this side-steps #26560
- - - - -
2 changed files:
- hadrian/src/Builder.hs
- hadrian/src/Settings/Builders/Ghc.hs
Changes:
=====================================
hadrian/src/Builder.hs
=====================================
@@ -361,6 +361,12 @@ instance H.Builder Builder where
Haddock BuildPackage -> runHaddock path buildArgs buildInputs
+ Ghc FindHsDependencies _ -> do
+ -- Use a response file for ghc -M invocations, to
+ -- avoid issues with command line size limit on
+ -- Windows (#26637)
+ runGhcWithResponse path buildArgs buildInputs
+
HsCpp -> captureStdout
Make dir -> cmd' buildOptions path ["-C", dir] buildArgs
@@ -403,6 +409,17 @@ runHaddock haddockPath flagArgs fileInputs = withTempFile $ \tmp -> do
writeFile' tmp $ escapeArgs fileInputs
cmd [haddockPath] flagArgs ('@' : tmp)
+runGhcWithResponse :: FilePath -> [String] -> [FilePath] -> Action ()
+runGhcWithResponse ghcPath flagArgs fileInputs = withTempFile $ \tmp -> do
+
+ writeFile' tmp $ escapeArgs fileInputs
+
+ -- We can't put the flags in a response file, because some flags
+ -- require empty arguments (such as the -dep-suffix flag), but
+ -- that isn't supported yet due to #26560.
+ cmd [ghcPath] flagArgs ('@' : tmp)
+
+
-- TODO: Some builders are required only on certain platforms. For example,
-- 'Objdump' is only required on OpenBSD and AIX. Add support for platform
-- specific optional builders as soon as we can reliably test this feature.
=====================================
hadrian/src/Settings/Builders/Ghc.hs
=====================================
@@ -182,7 +182,7 @@ findHsDependencies = builder (Ghc FindHsDependencies) ? do
, arg "-include-pkg-deps"
, arg "-dep-makefile", arg =<< getOutput
, pure $ concat [ ["-dep-suffix", wayPrefix w] | w <- Set.toList ways ]
- , getInputs ]
+ ]
haddockGhcArgs :: Args
haddockGhcArgs = mconcat [ commonGhcArgs
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9d371d23c526fd160d7e99bef2bc7da…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9d371d23c526fd160d7e99bef2bc7da…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] NCG/LA64: Simplify genCCall into two parts
by Marge Bot (＠marge-bot) 06 Dec '25
by Marge Bot (＠marge-bot) 06 Dec '25
06 Dec '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
d6cf8463 by Peng Fan at 2025-12-06T11:06:28-05:00
NCG/LA64: Simplify genCCall into two parts
genCCall is too long, so it's been simplified into two parts:
genPrim and genLibCCall.
Suggested by Andreas Klebinger
- - - - -
1 changed file:
- compiler/GHC/CmmToAsm/LA64/CodeGen.hs
Changes:
=====================================
compiler/GHC/CmmToAsm/LA64/CodeGen.hs
=====================================
@@ -3,6 +3,7 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE MultiWayIf #-}
module GHC.CmmToAsm.LA64.CodeGen (
cmmTopCodeGen
, generateJumpTableForInstr
@@ -268,8 +269,10 @@ stmtToInstrs stmt = do
config <- getConfig
platform <- getPlatform
case stmt of
- CmmUnsafeForeignCall target result_regs args
- -> genCCall target result_regs args
+ CmmUnsafeForeignCall target result_regs args ->
+ case target of
+ PrimTarget primOp -> genPrim primOp result_regs args
+ ForeignTarget addr conv -> genCCall addr conv result_regs args
CmmComment s -> return (unitOL (COMMENT (ftext s)))
CmmTick {} -> return nilOL
@@ -1631,6 +1634,319 @@ genCondBranch true false expr = do
b2 <- genBranch false
return (b1 `appOL` b2)
+genPrim
+ :: CallishMachOp -- MachOp
+ -> [CmmFormal] -- where to put the result
+ -> [CmmActual] -- arguments (of mixed type)
+ -> NatM InstrBlock
+
+genPrim MO_F32_Fabs [dst] [src] = genFloatAbs W32 dst src
+genPrim MO_F64_Fabs [dst] [src] = genFloatAbs W64 dst src
+genPrim MO_F32_Sqrt [dst] [src] = genFloatSqrt FF32 dst src
+genPrim MO_F64_Sqrt [dst] [src] = genFloatSqrt FF64 dst src
+genPrim (MO_Clz width) [dst] [src] = genClz width dst src
+genPrim (MO_Ctz width) [dst] [src] = genCtz width dst src
+genPrim (MO_BSwap width) [dst] [src] = genByteSwap width dst src
+genPrim (MO_BRev width) [dst] [src] = genBitRev width dst src
+genPrim MO_AcquireFence [] [] = return $ unitOL (DBAR HintAcquire)
+genPrim MO_ReleaseFence [] [] = return $ unitOL (DBAR HintRelease)
+genPrim MO_SeqCstFence [] [] = return $ unitOL (DBAR HintSeqcst)
+genPrim MO_Touch [] [_] = return nilOL
+genPrim (MO_Prefetch_Data _n) [] [_] = return nilOL
+genPrim (MO_AtomicRead w mo) [dst] [addr] = genAtomicRead w mo dst addr
+genPrim (MO_AtomicWrite w mo) [] [addr,val] = genAtomicWrite w mo addr val
+
+genPrim mop@(MO_S_Mul2 _w) _ _ = unsupported mop
+genPrim mop@(MO_S_QuotRem _w) _ _ = unsupported mop
+genPrim mop@(MO_U_QuotRem _w) _ _ = unsupported mop
+genPrim mop@(MO_U_QuotRem2 _w) _ _ = unsupported mop
+genPrim mop@(MO_Add2 _w) _ _ = unsupported mop
+genPrim mop@(MO_AddWordC _w) _ _ = unsupported mop
+genPrim mop@(MO_SubWordC _w) _ _ = unsupported mop
+genPrim mop@(MO_AddIntC _w) _ _ = unsupported mop
+genPrim mop@(MO_SubIntC _w) _ _ = unsupported mop
+genPrim mop@(MO_U_Mul2 _w) _ _ = unsupported mop
+genPrim mop@MO_I64X2_Min _ _ = unsupported mop
+genPrim mop@MO_I64X2_Max _ _ = unsupported mop
+genPrim mop@MO_W64X2_Min _ _ = unsupported mop
+genPrim mop@MO_W64X2_Max _ _ = unsupported mop
+genPrim mop@MO_VS_Quot {} _ _ = unsupported mop
+genPrim mop@MO_VS_Rem {} _ _ = unsupported mop
+genPrim mop@MO_VU_Quot {} _ _ = unsupported mop
+genPrim mop@MO_VU_Rem {} _ _ = unsupported mop
+
+genPrim (MO_PopCnt width) [dst] [src] = genLibCCall (popCntLabel width) [dst] [src]
+genPrim (MO_Pdep width) [dst] [src,mask] = genLibCCall (pdepLabel width) [dst] [src,mask]
+genPrim (MO_Pext width) [dst] [src,mask] = genLibCCall (pextLabel width) [dst] [src,mask]
+genPrim (MO_UF_Conv width) [dst] [src] = genLibCCall (word2FloatLabel width) [dst] [src]
+genPrim (MO_AtomicRMW width amop) [dst] [addr,n] = genLibCCall (atomicRMWLabel width amop) [dst] [addr,n]
+genPrim (MO_Cmpxchg width) [dst] [addr,old,new] = genLibCCall (cmpxchgLabel width) [dst] [addr,old,new]
+genPrim (MO_Xchg width) [dst] [addr,val] = genLibCCall (xchgLabel width) [dst] [addr,val]
+genPrim (MO_Memcpy _align) [] [dst,src,n] = genLibCCall (fsLit "memcpy") [] [dst,src,n]
+genPrim (MO_Memmove _align) [] [dst,src,n] = genLibCCall (fsLit "memmove") [] [dst,src,n]
+genPrim (MO_Memcmp _align) [rst] [dst,src,n] = genLibCCall (fsLit "memcmp") [rst] [dst,src,n]
+genPrim (MO_Memset _align) [] [dst,cnt,n] = genLibCCall (fsLit "memset") [] [dst,cnt,n]
+genPrim MO_F32_Sin [dst] [src] = genLibCCall (fsLit "sinf") [dst] [src]
+genPrim MO_F32_Cos [dst] [src] = genLibCCall (fsLit "cosf") [dst] [src]
+genPrim MO_F32_Tan [dst] [src] = genLibCCall (fsLit "tanf") [dst] [src]
+genPrim MO_F32_Exp [dst] [src] = genLibCCall (fsLit "expf") [dst] [src]
+genPrim MO_F32_ExpM1 [dst] [src] = genLibCCall (fsLit "expm1f") [dst] [src]
+genPrim MO_F32_Log [dst] [src] = genLibCCall (fsLit "logf") [dst] [src]
+genPrim MO_F32_Log1P [dst] [src] = genLibCCall (fsLit "log1pf") [dst] [src]
+genPrim MO_F32_Asin [dst] [src] = genLibCCall (fsLit "asinf") [dst] [src]
+genPrim MO_F32_Acos [dst] [src] = genLibCCall (fsLit "acosf") [dst] [src]
+genPrim MO_F32_Atan [dst] [src] = genLibCCall (fsLit "atanf") [dst] [src]
+genPrim MO_F32_Sinh [dst] [src] = genLibCCall (fsLit "sinhf") [dst] [src]
+genPrim MO_F32_Cosh [dst] [src] = genLibCCall (fsLit "coshf") [dst] [src]
+genPrim MO_F32_Tanh [dst] [src] = genLibCCall (fsLit "tanhf") [dst] [src]
+genPrim MO_F32_Pwr [dst] [x,y] = genLibCCall (fsLit "powf") [dst] [x,y]
+genPrim MO_F32_Asinh [dst] [src] = genLibCCall (fsLit "asinhf") [dst] [src]
+genPrim MO_F32_Acosh [dst] [src] = genLibCCall (fsLit "acoshf") [dst] [src]
+genPrim MO_F32_Atanh [dst] [src] = genLibCCall (fsLit "atanhf") [dst] [src]
+genPrim MO_F64_Sin [dst] [src] = genLibCCall (fsLit "sin") [dst] [src]
+genPrim MO_F64_Cos [dst] [src] = genLibCCall (fsLit "cos") [dst] [src]
+genPrim MO_F64_Tan [dst] [src] = genLibCCall (fsLit "tan") [dst] [src]
+genPrim MO_F64_Exp [dst] [src] = genLibCCall (fsLit "exp") [dst] [src]
+genPrim MO_F64_ExpM1 [dst] [src] = genLibCCall (fsLit "expm1") [dst] [src]
+genPrim MO_F64_Log [dst] [src] = genLibCCall (fsLit "log") [dst] [src]
+genPrim MO_F64_Log1P [dst] [src] = genLibCCall (fsLit "log1p") [dst] [src]
+genPrim MO_F64_Asin [dst] [src] = genLibCCall (fsLit "asin") [dst] [src]
+genPrim MO_F64_Acos [dst] [src] = genLibCCall (fsLit "acos") [dst] [src]
+genPrim MO_F64_Atan [dst] [src] = genLibCCall (fsLit "atan") [dst] [src]
+genPrim MO_F64_Sinh [dst] [src] = genLibCCall (fsLit "sinh") [dst] [src]
+genPrim MO_F64_Cosh [dst] [src] = genLibCCall (fsLit "cosh") [dst] [src]
+genPrim MO_F64_Tanh [dst] [src] = genLibCCall (fsLit "tanh") [dst] [src]
+genPrim MO_F64_Pwr [dst] [x,y] = genLibCCall (fsLit "pow") [dst] [x,y]
+genPrim MO_F64_Asinh [dst] [src] = genLibCCall (fsLit "asinh") [dst] [src]
+genPrim MO_F64_Acosh [dst] [src] = genLibCCall (fsLit "acosh") [dst] [src]
+genPrim MO_F64_Atanh [dst] [src] = genLibCCall (fsLit "atanh") [dst] [src]
+genPrim MO_SuspendThread [tok] [rs,i] = genLibCCall (fsLit "suspendThread") [tok] [rs,i]
+genPrim MO_ResumeThread [rs] [tok] = genLibCCall (fsLit "resumeThread") [rs] [tok]
+genPrim MO_I64_ToI [dst] [src] = genLibCCall (fsLit "hs_int64ToInt") [dst] [src]
+genPrim MO_I64_FromI [dst] [src] = genLibCCall (fsLit "hs_intToInt64") [dst] [src]
+genPrim MO_W64_ToW [dst] [src] = genLibCCall (fsLit "hs_word64ToWord") [dst] [src]
+genPrim MO_W64_FromW [dst] [src] = genLibCCall (fsLit "hs_wordToWord64") [dst] [src]
+genPrim MO_x64_Neg [dst] [src] = genLibCCall (fsLit "hs_neg64") [dst] [src]
+genPrim MO_x64_Add [dst] [src] = genLibCCall (fsLit "hs_add64") [dst] [src]
+genPrim MO_x64_Sub [dst] [src] = genLibCCall (fsLit "hs_sub64") [dst] [src]
+genPrim MO_x64_Mul [dst] [src] = genLibCCall (fsLit "hs_mul64") [dst] [src]
+genPrim MO_I64_Quot [dst] [src] = genLibCCall (fsLit "hs_quotInt64") [dst] [src]
+genPrim MO_I64_Rem [dst] [src] = genLibCCall (fsLit "hs_remInt64") [dst] [src]
+genPrim MO_W64_Quot [dst] [src] = genLibCCall (fsLit "hs_quotWord64") [dst] [src]
+genPrim MO_W64_Rem [dst] [src] = genLibCCall (fsLit "hs_remWord64") [dst] [src]
+genPrim MO_x64_And [dst] [src] = genLibCCall (fsLit "hs_and64") [dst] [src]
+genPrim MO_x64_Or [dst] [src] = genLibCCall (fsLit "hs_or64") [dst] [src]
+genPrim MO_x64_Xor [dst] [src] = genLibCCall (fsLit "hs_xor64") [dst] [src]
+genPrim MO_x64_Not [dst] [src] = genLibCCall (fsLit "hs_not64") [dst] [src]
+genPrim MO_x64_Shl [dst] [src] = genLibCCall (fsLit "hs_uncheckedShiftL64") [dst] [src]
+genPrim MO_I64_Shr [dst] [src] = genLibCCall (fsLit "hs_uncheckedIShiftRA64") [dst] [src]
+genPrim MO_W64_Shr [dst] [src] = genLibCCall (fsLit "hs_uncheckedShiftRL64") [dst] [src]
+genPrim MO_x64_Eq [dst] [src] = genLibCCall (fsLit "hs_eq64") [dst] [src]
+genPrim MO_x64_Ne [dst] [src] = genLibCCall (fsLit "hs_ne64") [dst] [src]
+genPrim MO_I64_Ge [dst] [src] = genLibCCall (fsLit "hs_geInt64") [dst] [src]
+genPrim MO_I64_Gt [dst] [src] = genLibCCall (fsLit "hs_gtInt64") [dst] [src]
+genPrim MO_I64_Le [dst] [src] = genLibCCall (fsLit "hs_leInt64") [dst] [src]
+genPrim MO_I64_Lt [dst] [src] = genLibCCall (fsLit "hs_ltInt64") [dst] [src]
+genPrim MO_W64_Ge [dst] [src] = genLibCCall (fsLit "hs_geWord64") [dst] [src]
+genPrim MO_W64_Gt [dst] [src] = genLibCCall (fsLit "hs_gtWord64") [dst] [src]
+genPrim MO_W64_Le [dst] [src] = genLibCCall (fsLit "hs_leWord64") [dst] [src]
+genPrim MO_W64_Lt [dst] [src] = genLibCCall (fsLit "hs_ltWord64") [dst] [src]
+genPrim op dst args = do
+ platform <- ncgPlatform <$> getConfig
+ pprPanic "genPrim: unknown primOp" (ppr (pprCallishMachOp op, dst, fmap (pdoc platform) args))
+
+
+genFloatAbs :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock
+genFloatAbs w dst src = do
+ platform <- getPlatform
+ (reg_fx, _, code_fx) <- getFloatReg src
+ let dst_reg = getRegisterReg platform (CmmLocal dst)
+ return (code_fx `appOL` toOL
+ [
+ FABS (OpReg w dst_reg) (OpReg w reg_fx)
+ ]
+ )
+
+genFloatSqrt :: Format -> LocalReg -> CmmExpr -> NatM InstrBlock
+genFloatSqrt f dst src = do
+ platform <- getPlatform
+ (reg_fx, _, code_fx) <- getFloatReg src
+ let dst_reg = getRegisterReg platform (CmmLocal dst)
+ return (code_fx `appOL` toOL
+ [
+ FSQRT (OpReg w dst_reg) (OpReg w reg_fx)
+ ]
+ )
+ where
+ w = case f of
+ FF32 -> W32
+ _ -> W64
+
+genClz :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock
+genClz w dst src = do
+ platform <- getPlatform
+ (reg_x, _, code_x) <- getSomeReg src
+ let dst_reg = getRegisterReg platform (CmmLocal dst)
+ if w `elem` [W32, W64] then do
+ return (code_x `snocOL` CLZ (OpReg w dst_reg) (OpReg w reg_x))
+ else if w `elem` [W8, W16] then do
+ return (code_x `appOL` toOL
+ [
+ MOV (OpReg W64 dst_reg) (OpImm (ImmInt 1)),
+ SLL (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpImm (ImmInt (31-shift))),
+ SLL (OpReg W64 reg_x) (OpReg W64 reg_x) (OpImm (ImmInt (32-shift))),
+ OR (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpReg W64 reg_x),
+ CLZ (OpReg W64 dst_reg) (OpReg W32 dst_reg)
+ ]
+ )
+ else do
+ pprPanic "genClz: invalid width: " (ppr w)
+ where
+ shift = widthToInt w
+
+genCtz :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock
+genCtz w dst src = do
+ platform <- getPlatform
+ (reg_x, _, code_x) <- getSomeReg src
+ let dst_reg = getRegisterReg platform (CmmLocal dst)
+ if w `elem` [W32, W64] then do
+ return (code_x `snocOL` CTZ (OpReg w dst_reg) (OpReg w reg_x))
+ else if w `elem` [W8, W16] then do
+ return (code_x `appOL` toOL
+ [
+ MOV (OpReg W64 dst_reg) (OpImm (ImmInt 1)),
+ SLL (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpImm (ImmInt shift)),
+ BSTRPICK II64 (OpReg W64 reg_x) (OpReg W64 reg_x) (OpImm (ImmInt (shift-1))) (OpImm (ImmInt 0)),
+ OR (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpReg W64 reg_x),
+ CTZ (OpReg W64 dst_reg) (OpReg W64 dst_reg)
+ ]
+ )
+ else do
+ pprPanic "genCtz: invalid width: " (ppr w)
+ where
+ shift = (widthToInt w)
+
+genByteSwap :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock
+genByteSwap w dst src = do
+ platform <- getPlatform
+ (reg_x, _, code_x) <- getSomeReg src
+ let dst_reg = getRegisterReg platform (CmmLocal dst)
+ case w of
+ W64 ->
+ return (code_x `appOL` toOL
+ [
+ REVBD (OpReg w dst_reg) (OpReg w reg_x)
+ ]
+ )
+ W32 ->
+ return (code_x `appOL` toOL
+ [
+ REVB2W (OpReg w dst_reg) (OpReg w reg_x)
+ ]
+ )
+ W16 ->
+ return (code_x `appOL` toOL
+ [
+ REVB2H (OpReg w dst_reg) (OpReg w reg_x)
+ ]
+ )
+ _ -> pprPanic "genBSwap: invalid width: " (ppr w)
+
+genBitRev :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock
+genBitRev w dst src = do
+ platform <- getPlatform
+ (reg_x, _, code_x) <- getSomeReg src
+ let dst_reg = getRegisterReg platform (CmmLocal dst)
+ case w of
+ W8 ->
+ return (code_x `appOL` toOL
+ [
+ BITREV4B (OpReg W32 reg_x) (OpReg W32 reg_x),
+ AND (OpReg W64 dst_reg) (OpReg W64 reg_x) (OpImm (ImmInt 255))
+ ]
+ )
+ W16 ->
+ return (code_x `appOL` toOL
+ [
+ BITREV (OpReg W64 reg_x) (OpReg W64 reg_x),
+ SRL (OpReg W64 dst_reg) (OpReg W64 reg_x) (OpImm (ImmInt 48))
+ ]
+ )
+ _ -> return ( code_x `snocOL` BITREV (OpReg w dst_reg) (OpReg w reg_x))
+
+-- Generate C call to the given function in libc
+genLibCCall :: FastString -> [CmmFormal] -> [CmmActual] -> NatM InstrBlock
+genLibCCall name dsts args = do
+ config <- getConfig
+ target <-
+ cmmMakeDynamicReference config CallReference
+ $ mkForeignLabel name ForeignLabelInThisPackage IsFunction
+ let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn
+ genCCall target cconv dsts args
+
+unsupported :: Show a => a -> b
+unsupported mop = panic ("outOfLineCmmOp: " ++ show mop
+ ++ " not supported here")
+
+-- AMSWAP_DB* insns implentment a fully functional synchronization barrier, like DBAR 0x0.
+-- This is terrible. And AMSWAPDB only supports ISA version greater than LA64V1_0. So,
+-- implement with DBAR
+genAtomicRead :: Width -> MemoryOrdering -> LocalReg -> CmmExpr -> NatM InstrBlock
+genAtomicRead w mo dst arg = do
+ (addr_p, _, code_p) <- getSomeReg arg
+ platform <- getPlatform
+ let d = getRegisterReg platform (CmmLocal dst)
+ case mo of
+ MemOrderRelaxed ->
+ return (code_p `appOL` toOL
+ [
+ LD (intFormat w) (OpReg w d) (OpAddr $ AddrReg addr_p)
+ ]
+ )
+
+ MemOrderAcquire ->
+ return (code_p `appOL` toOL
+ [
+ LD (intFormat w) (OpReg w d) (OpAddr $ AddrReg addr_p),
+ DBAR HintAcquire
+ ]
+ )
+ MemOrderSeqCst ->
+ return (code_p `appOL` toOL
+ [
+ LD (intFormat w) (OpReg w d) (OpAddr $ AddrReg addr_p),
+ DBAR HintSeqcst
+ ]
+ )
+ _ -> panic $ "Unexpected MemOrderRelease on an AtomicRead: " ++ show mo
+
+genAtomicWrite :: Width -> MemoryOrdering -> CmmExpr -> CmmExpr -> NatM InstrBlock
+genAtomicWrite w mo addr val = do
+ (addr_p, _, code_p) <- getSomeReg addr
+ (val_reg, fmt_val, code_val) <- getSomeReg val
+ case mo of
+ MemOrderRelaxed ->
+ return (code_p `appOL`code_val `appOL` toOL
+ [
+ ST fmt_val (OpReg w val_reg) (OpAddr $ AddrReg addr_p)
+ ]
+ )
+ MemOrderRelease ->
+ return (code_p `appOL`code_val `appOL` toOL
+ [
+ DBAR HintRelease,
+ ST fmt_val (OpReg w val_reg) (OpAddr $ AddrReg addr_p)
+ ]
+ )
+ MemOrderSeqCst ->
+ return (code_p `appOL`code_val `appOL` toOL
+ [
+ DBAR HintSeqcst,
+ ST fmt_val (OpReg w val_reg) (OpAddr $ AddrReg addr_p)
+ ]
+ )
+ _ -> panic $ "Unexpected MemOrderAcquire on an AtomicWrite" ++ show mo
+
-- -----------------------------------------------------------------------------
{-
Generating C calls
@@ -1664,393 +1980,68 @@ wider than FRLEN may be passed in a GAR.
-}
genCCall
- :: ForeignTarget -- function to call
- -> [CmmFormal] -- where to put the result
- -> [CmmActual] -- arguments (of mixed type)
- -> NatM InstrBlock
-
--- TODO: Specialize where we can.
--- Generic impl
-genCCall target dest_regs arg_regs = do
- case target of
- -- The target :: ForeignTarget call can either
- -- be a foreign procedure with an address expr
- -- and a calling convention.
- ForeignTarget expr _cconv -> do
- (call_target, call_target_code) <- case expr of
- -- if this is a label, let's just directly to it.
- (CmmLit (CmmLabel lbl)) -> pure (TLabel lbl, nilOL)
- -- if it's not a label, let's compute the expression into a
- -- register and jump to that.
- _ -> do
- (reg, _format, reg_code) <- getSomeReg expr
- pure (TReg reg, reg_code)
- -- compute the code and register logic for all arg_regs.
- -- this will give us the format information to match on.
- arg_regs' <- mapM getSomeReg arg_regs
-
- -- Now this is stupid. Our Cmm expressions doesn't carry the proper sizes
- -- so while in Cmm we might get W64 incorrectly for an int, that is W32 in
- -- STG; this thenn breaks packing of stack arguments, if we need to pack
- -- for the pcs, e.g. darwinpcs. Option one would be to fix the Int type
- -- in Cmm proper. Option two, which we choose here is to use extended Hint
- -- information to contain the size information and use that when packing
- -- arguments, spilled onto the stack.
- let (_res_hints, arg_hints) = foreignTargetHints target
- arg_regs'' = zipWith (\(r, f, c) h -> (r,f,h,c)) arg_regs' arg_hints
-
- (stackSpaceWords, passRegs, passArgumentsCode) <- passArguments allGpArgRegs allFpArgRegs arg_regs'' 0 [] nilOL
-
- readResultsCode <- readResults allGpArgRegs allFpArgRegs dest_regs [] nilOL
-
- let moveStackDown 0 = toOL [ PUSH_STACK_FRAME
- , DELTA (-16)
- ]
- moveStackDown i | odd i = moveStackDown (i + 1)
- moveStackDown i = toOL [ PUSH_STACK_FRAME
- , SUB (OpReg W64 (spMachReg)) (OpReg W64 (spMachReg)) (OpImm (ImmInt (8 * i)))
- , DELTA (-8 * i - 16)
- ]
- moveStackUp 0 = toOL [ POP_STACK_FRAME
- , DELTA 0
- ]
- moveStackUp i | odd i = moveStackUp (i + 1)
- moveStackUp i = toOL [ ADD (OpReg W64 (spMachReg)) (OpReg W64 (spMachReg)) (OpImm (ImmInt (8 * i)))
- , POP_STACK_FRAME
- , DELTA 0
- ]
-
- let code =
- call_target_code -- compute the label (possibly into a register)
- `appOL` moveStackDown (stackSpaceWords)
- `appOL` passArgumentsCode -- put the arguments into x0, ...
- `snocOL` CALL call_target passRegs -- branch and link (C calls aren't tail calls, but return)
- `appOL` readResultsCode -- parse the results into registers
- `appOL` moveStackUp (stackSpaceWords)
- return code
-
- PrimTarget MO_F32_Fabs
- | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->
- unaryFloatOp W32 (\d x -> unitOL $ FABS d x) arg_reg dest_reg
- | otherwise -> panic "mal-formed MO_F32_Fabs"
- PrimTarget MO_F64_Fabs
- | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->
- unaryFloatOp W64 (\d x -> unitOL $ FABS d x) arg_reg dest_reg
- | otherwise -> panic "mal-formed MO_F64_Fabs"
-
- PrimTarget MO_F32_Sqrt
- | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->
- unaryFloatOp W32 (\d x -> unitOL $ FSQRT d x) arg_reg dest_reg
- | otherwise -> panic "mal-formed MO_F32_Sqrt"
- PrimTarget MO_F64_Sqrt
- | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->
- unaryFloatOp W64 (\d x -> unitOL $ FSQRT d x) arg_reg dest_reg
- | otherwise -> panic "mal-formed MO_F64_Sqrt"
-
- PrimTarget (MO_Clz w)
- | w `elem` [W32, W64],
- [arg_reg] <- arg_regs,
- [dest_reg] <- dest_regs -> do
- platform <- getPlatform
- (reg_x, _format_x, code_x) <- getSomeReg arg_reg
- let dst_reg = getRegisterReg platform (CmmLocal dest_reg)
- return ( code_x `snocOL`
- CLZ (OpReg w dst_reg) (OpReg w reg_x)
- )
- | w `elem` [W8, W16],
- [arg_reg] <- arg_regs,
- [dest_reg] <- dest_regs -> do
- platform <- getPlatform
- (reg_x, _format_x, code_x) <- getSomeReg arg_reg
- let dst_reg = getRegisterReg platform (CmmLocal dest_reg)
- return ( code_x `appOL` toOL
- [
- MOV (OpReg W64 dst_reg) (OpImm (ImmInt 1)),
- SLL (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpImm (ImmInt (31-shift))),
- SLL (OpReg W64 reg_x) (OpReg W64 reg_x) (OpImm (ImmInt (32-shift))),
- OR (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpReg W64 reg_x),
- CLZ (OpReg W64 dst_reg) (OpReg W32 dst_reg)
- ]
- )
- | otherwise -> unsupported (MO_Clz w)
- where
- shift = widthToInt w
-
- PrimTarget (MO_Ctz w)
- | w `elem` [W32, W64],
- [arg_reg] <- arg_regs,
- [dest_reg] <- dest_regs -> do
- platform <- getPlatform
- (reg_x, _format_x, code_x) <- getSomeReg arg_reg
- let dst_reg = getRegisterReg platform (CmmLocal dest_reg)
- return ( code_x `snocOL`
- CTZ (OpReg w dst_reg) (OpReg w reg_x)
- )
- | w `elem` [W8, W16],
- [arg_reg] <- arg_regs,
- [dest_reg] <- dest_regs -> do
- platform <- getPlatform
- (reg_x, _format_x, code_x) <- getSomeReg arg_reg
- let dst_reg = getRegisterReg platform (CmmLocal dest_reg)
- return ( code_x `appOL` toOL
- [
- MOV (OpReg W64 dst_reg) (OpImm (ImmInt 1)),
- SLL (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpImm (ImmInt shift)),
- BSTRPICK II64 (OpReg W64 reg_x) (OpReg W64 reg_x) (OpImm (ImmInt (shift-1))) (OpImm (ImmInt 0)),
- OR (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpReg W64 reg_x),
- CTZ (OpReg W64 dst_reg) (OpReg W64 dst_reg)
- ]
- )
- | otherwise -> unsupported (MO_Ctz w)
- where
- shift = (widthToInt w)
+ :: CmmExpr -- address of func call
+ -> ForeignConvention -- calling convention
+ -> [CmmFormal] -- results
+ -> [CmmActual] -- arguments
+ -> NatM InstrBlock
+
+
+genCCall expr _conv@(ForeignConvention _ argHints _resHints _) dest_regs arg_regs = do
+ (call_target, call_target_code) <- case expr of
+ -- if this is a label, let's just directly to it.
+ (CmmLit (CmmLabel lbl)) -> pure (TLabel lbl, nilOL)
+ -- if it's not a label, let's compute the expression into a
+ -- register and jump to that.
+ _ -> do
+ (reg, _format, reg_code) <- getSomeReg expr
+ pure (TReg reg, reg_code)
+ -- compute the code and register logic for all arg_regs.
+ -- this will give us the format information to match on.
+ arg_regs' <- mapM getSomeReg arg_regs
+
+ -- Now this is stupid. Our Cmm expressions doesn't carry the proper sizes
+ -- so while in Cmm we might get W64 incorrectly for an int, that is W32 in
+ -- STG; this thenn breaks packing of stack arguments, if we need to pack
+ -- for the pcs, e.g. darwinpcs. Option one would be to fix the Int type
+ -- in Cmm proper. Option two, which we choose here is to use extended Hint
+ -- information to contain the size information and use that when packing
+ -- arguments, spilled onto the stack.
+ let
+ arg_hints = take (length arg_regs) (argHints ++ repeat NoHint)
+ arg_regs'' = zipWith (\(r, f, c) h -> (r,f,h,c)) arg_regs' arg_hints
+
+ (stackSpaceWords, passRegs, passArgumentsCode) <- passArguments allGpArgRegs allFpArgRegs arg_regs'' 0 [] nilOL
+
+ readResultsCode <- readResults allGpArgRegs allFpArgRegs dest_regs [] nilOL
+
+ let moveStackDown 0 = toOL [ PUSH_STACK_FRAME
+ , DELTA (-16)
+ ]
+ moveStackDown i | odd i = moveStackDown (i + 1)
+ moveStackDown i = toOL [ PUSH_STACK_FRAME
+ , SUB (OpReg W64 (spMachReg)) (OpReg W64 (spMachReg)) (OpImm (ImmInt (8 * i)))
+ , DELTA (-8 * i - 16)
+ ]
+ moveStackUp 0 = toOL [ POP_STACK_FRAME
+ , DELTA 0
+ ]
+ moveStackUp i | odd i = moveStackUp (i + 1)
+ moveStackUp i = toOL [ ADD (OpReg W64 (spMachReg)) (OpReg W64 (spMachReg)) (OpImm (ImmInt (8 * i)))
+ , POP_STACK_FRAME
+ , DELTA 0
+ ]
- PrimTarget (MO_BSwap w)
- | w `elem` [W16, W32, W64],
- [arg_reg] <- arg_regs,
- [dest_reg] <- dest_regs -> do
- platform <- getPlatform
- (reg_x, _, code_x) <- getSomeReg arg_reg
- let dst_reg = getRegisterReg platform (CmmLocal dest_reg)
- case w of
- W64 -> return ( code_x `appOL` toOL
- [
- REVBD (OpReg w dst_reg) (OpReg w reg_x)
- ])
- W32 -> return ( code_x `appOL` toOL
- [
- REVB2W (OpReg w dst_reg) (OpReg w reg_x)
- ])
- _ -> return ( code_x `appOL` toOL
- [
- REVB2H (OpReg w dst_reg) (OpReg w reg_x)
- ])
- | otherwise -> unsupported (MO_BSwap w)
-
- PrimTarget (MO_BRev w)
- | w `elem` [W8, W16, W32, W64],
- [arg_reg] <- arg_regs,
- [dest_reg] <- dest_regs -> do
- platform <- getPlatform
- (reg_x, _, code_x) <- getSomeReg arg_reg
- let dst_reg = getRegisterReg platform (CmmLocal dest_reg)
- case w of
- W8 -> return ( code_x `appOL` toOL
- [
- BITREV4B (OpReg W32 reg_x) (OpReg W32 reg_x),
- AND (OpReg W64 dst_reg) (OpReg W64 reg_x) (OpImm (ImmInt 255))
- ])
- W16 -> return ( code_x `appOL` toOL
- [
- BITREV (OpReg W64 reg_x) (OpReg W64 reg_x),
- SRL (OpReg W64 dst_reg) (OpReg W64 reg_x) (OpImm (ImmInt 48))
- ])
- _ -> return ( code_x `snocOL` BITREV (OpReg w dst_reg) (OpReg w reg_x))
- | otherwise -> unsupported (MO_BRev w)
-
- -- mop :: CallishMachOp (see GHC.Cmm.MachOp)
- PrimTarget mop -> do
- -- We'll need config to construct forien targets
- case mop of
- -- 64 bit float ops
- MO_F64_Pwr -> mkCCall "pow"
-
- MO_F64_Sin -> mkCCall "sin"
- MO_F64_Cos -> mkCCall "cos"
- MO_F64_Tan -> mkCCall "tan"
-
- MO_F64_Sinh -> mkCCall "sinh"
- MO_F64_Cosh -> mkCCall "cosh"
- MO_F64_Tanh -> mkCCall "tanh"
-
- MO_F64_Asin -> mkCCall "asin"
- MO_F64_Acos -> mkCCall "acos"
- MO_F64_Atan -> mkCCall "atan"
-
- MO_F64_Asinh -> mkCCall "asinh"
- MO_F64_Acosh -> mkCCall "acosh"
- MO_F64_Atanh -> mkCCall "atanh"
-
- MO_F64_Log -> mkCCall "log"
- MO_F64_Log1P -> mkCCall "log1p"
- MO_F64_Exp -> mkCCall "exp"
- MO_F64_ExpM1 -> mkCCall "expm1"
-
- -- 32 bit float ops
- MO_F32_Pwr -> mkCCall "powf"
-
- MO_F32_Sin -> mkCCall "sinf"
- MO_F32_Cos -> mkCCall "cosf"
- MO_F32_Tan -> mkCCall "tanf"
- MO_F32_Sinh -> mkCCall "sinhf"
- MO_F32_Cosh -> mkCCall "coshf"
- MO_F32_Tanh -> mkCCall "tanhf"
- MO_F32_Asin -> mkCCall "asinf"
- MO_F32_Acos -> mkCCall "acosf"
- MO_F32_Atan -> mkCCall "atanf"
- MO_F32_Asinh -> mkCCall "asinhf"
- MO_F32_Acosh -> mkCCall "acoshf"
- MO_F32_Atanh -> mkCCall "atanhf"
- MO_F32_Log -> mkCCall "logf"
- MO_F32_Log1P -> mkCCall "log1pf"
- MO_F32_Exp -> mkCCall "expf"
- MO_F32_ExpM1 -> mkCCall "expm1f"
-
- -- 64-bit primops
- MO_I64_ToI -> mkCCall "hs_int64ToInt"
- MO_I64_FromI -> mkCCall "hs_intToInt64"
- MO_W64_ToW -> mkCCall "hs_word64ToWord"
- MO_W64_FromW -> mkCCall "hs_wordToWord64"
- MO_x64_Neg -> mkCCall "hs_neg64"
- MO_x64_Add -> mkCCall "hs_add64"
- MO_x64_Sub -> mkCCall "hs_sub64"
- MO_x64_Mul -> mkCCall "hs_mul64"
- MO_I64_Quot -> mkCCall "hs_quotInt64"
- MO_I64_Rem -> mkCCall "hs_remInt64"
- MO_W64_Quot -> mkCCall "hs_quotWord64"
- MO_W64_Rem -> mkCCall "hs_remWord64"
- MO_x64_And -> mkCCall "hs_and64"
- MO_x64_Or -> mkCCall "hs_or64"
- MO_x64_Xor -> mkCCall "hs_xor64"
- MO_x64_Not -> mkCCall "hs_not64"
- MO_x64_Shl -> mkCCall "hs_uncheckedShiftL64"
- MO_I64_Shr -> mkCCall "hs_uncheckedIShiftRA64"
- MO_W64_Shr -> mkCCall "hs_uncheckedShiftRL64"
- MO_x64_Eq -> mkCCall "hs_eq64"
- MO_x64_Ne -> mkCCall "hs_ne64"
- MO_I64_Ge -> mkCCall "hs_geInt64"
- MO_I64_Gt -> mkCCall "hs_gtInt64"
- MO_I64_Le -> mkCCall "hs_leInt64"
- MO_I64_Lt -> mkCCall "hs_ltInt64"
- MO_W64_Ge -> mkCCall "hs_geWord64"
- MO_W64_Gt -> mkCCall "hs_gtWord64"
- MO_W64_Le -> mkCCall "hs_leWord64"
- MO_W64_Lt -> mkCCall "hs_ltWord64"
-
- -- Conversion
- MO_UF_Conv w -> mkCCall (word2FloatLabel w)
-
- -- Optional MachOps
- -- These are enabled/disabled by backend flags: GHC.StgToCmm.Config
- MO_S_Mul2 _w -> unsupported mop
- MO_S_QuotRem _w -> unsupported mop
- MO_U_QuotRem _w -> unsupported mop
- MO_U_QuotRem2 _w -> unsupported mop
- MO_Add2 _w -> unsupported mop
- MO_AddWordC _w -> unsupported mop
- MO_SubWordC _w -> unsupported mop
- MO_AddIntC _w -> unsupported mop
- MO_SubIntC _w -> unsupported mop
- MO_U_Mul2 _w -> unsupported mop
-
- MO_VS_Quot {} -> unsupported mop
- MO_VS_Rem {} -> unsupported mop
- MO_VU_Quot {} -> unsupported mop
- MO_VU_Rem {} -> unsupported mop
- MO_I64X2_Min -> unsupported mop
- MO_I64X2_Max -> unsupported mop
- MO_W64X2_Min -> unsupported mop
- MO_W64X2_Max -> unsupported mop
-
- -- Memory Ordering
- -- Support finer-grained DBAR hints for LA664 and newer uarchs.
- -- These are treated as DBAR 0 on older uarchs, so we can start
- -- to unconditionally emit the new hints right away.
- MO_AcquireFence -> pure (unitOL (DBAR HintAcquire))
- MO_ReleaseFence -> pure (unitOL (DBAR HintRelease))
- MO_SeqCstFence -> pure (unitOL (DBAR HintSeqcst))
-
- MO_Touch -> pure nilOL -- Keep variables live (when using interior pointers)
- -- Prefetch
- MO_Prefetch_Data _n -> pure nilOL -- Prefetch hint.
-
- -- Memory copy/set/move/cmp, with alignment for optimization
-
- -- TODO Optimize and use e.g. quad registers to move memory around instead
- -- of offloading this to memcpy. For small memcpys we can utilize
- -- the 128bit quad registers in NEON to move block of bytes around.
- -- Might also make sense of small memsets? Use xzr? What's the function
- -- call overhead?
- MO_Memcpy _align -> mkCCall "memcpy"
- MO_Memset _align -> mkCCall "memset"
- MO_Memmove _align -> mkCCall "memmove"
- MO_Memcmp _align -> mkCCall "memcmp"
-
- MO_SuspendThread -> mkCCall "suspendThread"
- MO_ResumeThread -> mkCCall "resumeThread"
-
- MO_PopCnt w -> mkCCall (popCntLabel w)
- MO_Pdep w -> mkCCall (pdepLabel w)
- MO_Pext w -> mkCCall (pextLabel w)
-
- -- or a possibly side-effecting machine operation
- mo@(MO_AtomicRead w ord)
- | [p_reg] <- arg_regs
- , [dst_reg] <- dest_regs -> do
- (p, _fmt_p, code_p) <- getSomeReg p_reg
- platform <- getPlatform
- let instrs = case ord of
- MemOrderRelaxed -> unitOL $ ann moDescr (LD (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p))
-
- MemOrderAcquire -> toOL [
- ann moDescr (LD (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p)),
- DBAR HintAcquire
- ]
- MemOrderSeqCst -> toOL [
- ann moDescr (LD (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p)),
- DBAR HintSeqcst
- ]
- _ -> panic $ "Unexpected MemOrderRelease on an AtomicRead: " ++ show mo
- dst = getRegisterReg platform (CmmLocal dst_reg)
- moDescr = (text . show) mo
- code = code_p `appOL` instrs
- pure code
- | otherwise -> panic "mal-formed AtomicRead"
-
- mo@(MO_AtomicWrite w ord)
- | [p_reg, val_reg] <- arg_regs -> do
- (p, _fmt_p, code_p) <- getSomeReg p_reg
- (val, fmt_val, code_val) <- getSomeReg val_reg
- let instrs = case ord of
- MemOrderRelaxed -> unitOL $ ann moDescr (ST fmt_val (OpReg w val) (OpAddr $ AddrReg p))
- -- AMSWAP_DB* insns implentment a fully functional synchronization barrier, like DBAR 0x0.
- -- This is terrible. And AMSWAPDB only supports ISA version greater than LA64V1_0. So,
- -- implement with DBAR
- MemOrderRelease -> toOL [
- ann moDescr (DBAR HintRelease),
- ST fmt_val (OpReg w val) (OpAddr $ AddrReg p)
- ]
- MemOrderSeqCst -> toOL [
- ann moDescr (DBAR HintSeqcst),
- ST fmt_val (OpReg w val) (OpAddr $ AddrReg p)
- ]
- _ -> panic $ "Unexpected MemOrderAcquire on an AtomicWrite" ++ show mo
- moDescr = (text . show) mo
- code =
- code_p `appOL`
- code_val `appOL`
- instrs
- pure code
- | otherwise -> panic "mal-formed AtomicWrite"
-
- MO_AtomicRMW w amop -> mkCCall (atomicRMWLabel w amop)
- MO_Cmpxchg w -> mkCCall (cmpxchgLabel w)
- MO_Xchg w -> mkCCall (xchgLabel w)
+ let code =
+ call_target_code -- compute the label (possibly into a register)
+ `appOL` moveStackDown (stackSpaceWords)
+ `appOL` passArgumentsCode -- put the arguments into x0, ...
+ `snocOL` CALL call_target passRegs -- branch and link (C calls aren't tail calls, but return)
+ `appOL` readResultsCode -- parse the results into registers
+ `appOL` moveStackUp (stackSpaceWords)
+ return code
where
- unsupported :: Show a => a -> b
- unsupported mop = panic ("outOfLineCmmOp: " ++ show mop
- ++ " not supported here")
-
- mkCCall :: FastString -> NatM InstrBlock
- mkCCall name = do
- config <- getConfig
- target <-
- cmmMakeDynamicReference config CallReference
- $ mkForeignLabel name ForeignLabelInThisPackage IsFunction
- let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn
- genCCall (ForeignTarget target cconv) dest_regs arg_regs
-
-- Implementiation of the LoongArch ABI calling convention.
-- https://github.com/loongson/la-abi-specs/blob/release/lapcs.adoc#passing-ar…
passArguments :: [Reg] -> [Reg] -> [(Reg, Format, ForeignHint, InstrBlock)] -> Int -> [Reg] -> InstrBlock -> NatM (Int, [Reg], InstrBlock)
@@ -2129,10 +2120,10 @@ genCCall target dest_regs arg_regs = do
readResults _ _ [] _ accumCode = return accumCode
readResults [] _ _ _ _ = do
platform <- getPlatform
- pprPanic "genCCall, out of gp registers when reading results" (pdoc platform target)
+ pprPanic "genCCall, out of gp registers when reading results" (pdoc platform expr)
readResults _ [] _ _ _ = do
platform <- getPlatform
- pprPanic "genCCall, out of fp registers when reading results" (pdoc platform target)
+ pprPanic "genCCall, out of fp registers when reading results" (pdoc platform expr)
readResults (gpReg:gpRegs) (fpReg:fpRegs) (dst:dsts) accumRegs accumCode = do
-- gp/fp reg -> dst
platform <- getPlatform
@@ -2150,13 +2141,6 @@ genCCall target dest_regs arg_regs = do
-- truncate, otherwise an unexpectedly big value might be used in upfollowing calculations
truncateReg W64 w r_dst
- unaryFloatOp w op arg_reg dest_reg = do
- platform <- getPlatform
- (reg_fx, _format_x, code_fx) <- getFloatReg arg_reg
- let dst = getRegisterReg platform (CmmLocal dest_reg)
- let code = code_fx `appOL` op (OpReg w dst) (OpReg w reg_fx)
- pure code
-
data BlockInRange = InRange | NotInRange BlockId
genCondFarJump :: (MonadGetUnique m) => Cond -> Operand -> Operand -> BlockId -> m InstrBlock
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d6cf8463705df729a3c49603f664c14…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d6cf8463705df729a3c49603f664c14…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc] Pushed new branch wip/torsten.schmits/unit-index-only
by Torsten Schmits (＠torsten.schmits) 06 Dec '25
by Torsten Schmits (＠torsten.schmits) 06 Dec '25
06 Dec '25
Torsten Schmits pushed new branch wip/torsten.schmits/unit-index-only at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/torsten.schmits/unit-index-on…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/torsten.schmits/unit-index-debug] WIP: unit index
by Torsten Schmits (＠torsten.schmits) 06 Dec '25
by Torsten Schmits (＠torsten.schmits) 06 Dec '25
06 Dec '25
Torsten Schmits pushed to branch wip/torsten.schmits/unit-index-debug at Glasgow Haskell Compiler / GHC
Commits:
b705a78d by Torsten Schmits at 2025-12-06T12:51:22+01:00
WIP: unit index
- - - - -
22 changed files:
- compiler/GHC.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Runtime/Context.hs
- compiler/GHC/Runtime/Loader.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/Name/Ppr.hs
- compiler/GHC/Unit/Env.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/State.hs
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Monad.hs
- ghc/Main.hs
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -341,7 +341,7 @@ import GHC.Builtin.Types.Prim ( alphaTyVars )
import GHC.Data.StringBuffer
import GHC.Data.FastString
import qualified GHC.LanguageExtensions as LangExt
-import GHC.Rename.Names (renamePkgQual, renameRawPkgQual, gresFromAvails)
+import GHC.Rename.Names (gresFromAvails, hscRenamePkgQual, hscRenameRawPkgQual)
import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
import GHC.Tc.Types
@@ -625,7 +625,8 @@ setUnitDynFlagsNoCheck uid dflags1 = do
let old_hue = ue_findHomeUnitEnv uid (hsc_unit_env hsc_env)
let cached_unit_dbs = homeUnitEnv_unit_dbs old_hue
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs (hsc_all_home_unit_ids hsc_env)
+ index <- hscUnitIndex <$> getSession
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 index cached_unit_dbs (hsc_all_home_unit_ids hsc_env)
updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants
let upd hue =
@@ -760,6 +761,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
then do
-- additionally, set checked dflags so we don't lose fixes
old_unit_env <- ue_setFlags dflags0 . hsc_unit_env <$> getSession
+ ue_index <- hscUnitIndex <$> getSession
home_unit_graph <- forM (ue_home_unit_graph old_unit_env) $ \homeUnitEnv -> do
let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
@@ -767,7 +769,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
old_hpt = homeUnitEnv_hpt homeUnitEnv
home_units = unitEnv_keys (ue_home_unit_graph old_unit_env)
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags ue_index cached_unit_dbs home_units
updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
pure HomeUnitEnv
@@ -785,6 +787,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
, ue_home_unit_graph = home_unit_graph
, ue_current_unit = ue_currentUnit old_unit_env
, ue_eps = ue_eps old_unit_env
+ , ue_index
}
modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env }
else modifySession (hscSetFlags dflags0)
@@ -1379,7 +1382,8 @@ getInsts = withSession $ \hsc_env ->
getNamePprCtx :: GhcMonad m => m NamePprCtx
getNamePprCtx = withSession $ \hsc_env -> do
- return $ icNamePprCtx (hsc_unit_env hsc_env) (hsc_IC hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ return $ icNamePprCtx (hsc_unit_env hsc_env) query (hsc_IC hsc_env)
-- | Container for information about a 'Module'.
data ModuleInfo = ModuleInfo {
@@ -1474,7 +1478,8 @@ mkNamePprCtxForModule ::
ModuleInfo ->
m NamePprCtx
mkNamePprCtxForModule mod minf = withSession $ \hsc_env -> do
- let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (availsToGlobalRdrEnv hsc_env mod (minf_exports minf))
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (availsToGlobalRdrEnv hsc_env mod (minf_exports minf))
ptc = initPromotionTickContext (hsc_dflags hsc_env)
return name_ppr_ctx
@@ -1711,10 +1716,10 @@ modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc d
parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))
renamePkgQualM :: GhcMonad m => ModuleName -> Maybe FastString -> m PkgQual
-renamePkgQualM mn p = withSession $ \hsc_env -> pure (renamePkgQual (hsc_unit_env hsc_env) mn p)
+renamePkgQualM mn p = withSession $ \hsc_env -> hscRenamePkgQual hsc_env mn p
renameRawPkgQualM :: GhcMonad m => ModuleName -> RawPkgQual -> m PkgQual
-renameRawPkgQualM mn p = withSession $ \hsc_env -> pure (renameRawPkgQual (hsc_unit_env hsc_env) mn p)
+renameRawPkgQualM mn p = withSession $ \hsc_env -> hscRenameRawPkgQual hsc_env mn p
-- | Like 'findModule', but differs slightly when the module refers to
-- a source file, and the file has not been loaded via 'load'. In
@@ -1738,7 +1743,8 @@ lookupQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do
let units = hsc_units hsc_env
let dflags = hsc_dflags hsc_env
let fopts = initFinderOpts dflags
- res <- findExposedPackageModule fc fopts units mod_name NoPkgQual
+ query <- hscUnitIndexQuery hsc_env
+ res <- findExposedPackageModule fc fopts units query mod_name NoPkgQual
case res of
Found _ m -> return m
err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err
=====================================
compiler/GHC/Core/Opt/Pipeline.hs
=====================================
@@ -78,6 +78,8 @@ core2core hsc_env guts@(ModGuts { mg_module = mod
, mg_rdr_env = rdr_env })
= do { let builtin_passes = getCoreToDo dflags hpt_rule_base extra_vars
uniq_tag = 's'
+ ; query <- hscUnitIndexQuery hsc_env
+ ; let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env
; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_tag mod
name_ppr_ctx loc $
@@ -100,7 +102,6 @@ core2core hsc_env guts@(ModGuts { mg_module = mod
home_pkg_rules = hptRules hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod
, gwib_isBoot = NotBoot })
hpt_rule_base = mkRuleBase home_pkg_rules
- name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env
ptc = initPromotionTickContext dflags
-- mod: get the module out of the current HscEnv so we can retrieve it from the monad.
-- This is very convienent for the users of the monad (e.g. plugins do not have to
@@ -459,6 +460,7 @@ doCorePass pass guts = do
dflags <- getDynFlags
us <- getUniqueSupplyM
p_fam_env <- getPackageFamInstEnv
+ query <- liftIO $ hscUnitIndexQuery hsc_env
let platform = targetPlatform dflags
let fam_envs = (p_fam_env, mg_fam_inst_env guts)
let updateBinds f = return $ guts { mg_binds = f (mg_binds guts) }
@@ -471,6 +473,7 @@ doCorePass pass guts = do
mkNamePprCtx
(initPromotionTickContext dflags)
(hsc_unit_env hsc_env)
+ query
rdr_env
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -429,6 +429,7 @@ addUnit u = do
logger <- getLogger
let dflags0 = hsc_dflags hsc_env
let old_unit_env = hsc_unit_env hsc_env
+ ue_index = hscUnitIndex hsc_env
newdbs <- case ue_unit_dbs old_unit_env of
Nothing -> panic "addUnit: called too early"
Just dbs ->
@@ -437,7 +438,7 @@ addUnit u = do
, unitDatabaseUnits = [u]
}
in return (dbs ++ [newdb]) -- added at the end because ordering matters
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs) (hsc_all_home_unit_ids hsc_env)
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 ue_index (Just newdbs) (hsc_all_home_unit_ids hsc_env)
-- update platform constants
dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
@@ -452,6 +453,7 @@ addUnit u = do
(homeUnitId home_unit)
(mkHomeUnitEnv dflags (ue_hpt old_unit_env) (Just home_unit))
, ue_eps = ue_eps old_unit_env
+ , ue_index
}
setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env }
@@ -870,6 +872,8 @@ hsModuleToModSummary home_keys pn hsc_src modname
hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+
-- Also copied from 'getImports'
let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps
@@ -882,7 +886,7 @@ hsModuleToModSummary home_keys pn hsc_src modname
implicit_imports = mkPrelImports modname loc
implicit_prelude imps
- rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) modname
+ rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query modname
convImport (L _ i) = (rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i)
extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname
=====================================
compiler/GHC/Driver/Env.hs
=====================================
@@ -7,6 +7,8 @@ module GHC.Driver.Env
, hsc_home_unit
, hsc_home_unit_maybe
, hsc_units
+ , hscUnitIndex
+ , hscUnitIndexQuery
, hsc_HPT
, hsc_HUE
, hsc_HUG
@@ -118,6 +120,13 @@ hsc_home_unit_maybe = ue_homeUnit . hsc_unit_env
hsc_units :: HasDebugCallStack => HscEnv -> UnitState
hsc_units = ue_units . hsc_unit_env
+hscUnitIndex :: HscEnv -> UnitIndex
+hscUnitIndex = ue_index . hsc_unit_env
+
+hscUnitIndexQuery :: HscEnv -> IO UnitIndexQuery
+hscUnitIndexQuery hsc_env =
+ unitIndexQuery (hscActiveUnitId hsc_env) (hscUnitIndex hsc_env)
+
hsc_HPT :: HscEnv -> HomePackageTable
hsc_HPT = ue_hpt . hsc_unit_env
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -2665,9 +2665,10 @@ hscTidy hsc_env guts = do
$! {-# SCC "CoreTidy" #-} tidyProgram opts guts
-- post tidy pretty-printing and linting...
+ query <- hscUnitIndexQuery hsc_env
let tidy_rules = md_rules details
let all_tidy_binds = cg_binds cgguts
- let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (mg_rdr_env guts)
+ let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (mg_rdr_env guts)
ptc = initPromotionTickContext (hsc_dflags hsc_env)
endPassHscEnvIO hsc_env name_ppr_ctx CoreTidy all_tidy_binds tidy_rules
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -190,12 +190,13 @@ depanalE excluded_mods allow_dup_roots = do
if isEmptyMessages errs
then do
hsc_env <- getSession
+ query <- liftIO $ hscUnitIndexQuery hsc_env
let one_unit_messages get_mod_errs k hue = do
errs <- get_mod_errs
unknown_module_err <- warnUnknownModules (hscSetActiveUnitId k hsc_env) (homeUnitEnv_dflags hue) mod_graph
let unused_home_mod_err = warnMissingHomeModules (homeUnitEnv_dflags hue) (hsc_targets hsc_env) mod_graph
- unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) (homeUnitEnv_dflags hue) mod_graph
+ unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) query (homeUnitEnv_dflags hue) mod_graph
return $ errs `unionMessages` unused_home_mod_err
@@ -513,15 +514,15 @@ loadWithCache cache diag_wrapper how_much = do
-- actually loaded packages. All the packages, specified on command line,
-- but never loaded, are probably unused dependencies.
-warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages
-warnUnusedPackages us dflags mod_graph =
+warnUnusedPackages :: UnitState -> UnitIndexQuery -> DynFlags -> ModuleGraph -> DriverMessages
+warnUnusedPackages us query dflags mod_graph =
let diag_opts = initDiagOpts dflags
home_mod_sum = filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph)
-- Only need non-source imports here because SOURCE imports are always HPT
loadedPackages = concat $
- mapMaybe (\(fs, mn) -> lookupModulePackage us (unLoc mn) fs)
+ mapMaybe (\(fs, mn) -> lookupModulePackage us query (unLoc mn) fs)
$ concatMap ms_imps home_mod_sum
any_import_ghc_prim = any ms_ghc_prim_import home_mod_sum
@@ -2399,7 +2400,8 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn
let mopts = map unLoc $ snd $ getOptions popts pi_hspp_buf src_fn
pure $ ((, mopts) <$>) $ first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps
- let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query
let rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn))
let pi_srcimps = rn_imps pi_srcimps'
let pi_theimps = rn_imps pi_theimps'
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -692,9 +692,10 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do
-- gather the imports and module name
(hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do
buf <- hGetStringBuffer input_fn
+ query <- hscUnitIndexQuery hsc_env
let imp_prelude = xopt LangExt.ImplicitPrelude dflags
popts = initParserOpts dflags
- rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
+ rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query
rn_imps = fmap (\(rpk, lmn@(L _ mn)) -> (rn_pkg_qual mn rpk, lmn))
eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff)
case eimps of
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -149,7 +149,8 @@ deSugar hsc_env
= do { let dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
ptc = initPromotionTickContext (hsc_dflags hsc_env)
- name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env
+ ; query <- hscUnitIndexQuery hsc_env
+ ; let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env
; withTiming logger
(text "Desugar"<+>brackets (ppr mod))
(const ()) $
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -89,6 +89,7 @@ import GHC.Data.FastString
import GHC.Unit.Env
import GHC.Unit.External
+import GHC.Unit.State (UnitIndexQuery)
import GHC.Unit.Module
import GHC.Unit.Module.ModGuts
@@ -264,7 +265,8 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
++ eps_complete_matches eps -- from imports
-- re-use existing next_wrapper_num to ensure uniqueness
next_wrapper_num_var = tcg_next_wrapper_num tcg_env
- ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env ptc
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+ ; return $ mkDsEnvs unit_env query this_mod rdr_env type_env fam_inst_env ptc
msg_var cc_st_var next_wrapper_num_var complete_matches
}
@@ -292,6 +294,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
; next_wrapper_num <- newIORef emptyModuleEnv
; msg_var <- newIORef emptyMessages
; eps <- liftIO $ hscEPS hsc_env
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
; let unit_env = hsc_unit_env hsc_env
type_env = typeEnvFromEntities ids tycons patsyns fam_insts
ptc = initPromotionTickContext (hsc_dflags hsc_env)
@@ -303,7 +306,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
bindsToIds (Rec binds) = map fst binds
ids = concatMap bindsToIds binds
- envs = mkDsEnvs unit_env this_mod rdr_env type_env
+ envs = mkDsEnvs unit_env query this_mod rdr_env type_env
fam_inst_env ptc msg_var cc_st_var
next_wrapper_num complete_matches
; runDs hsc_env envs thing_inside
@@ -342,12 +345,12 @@ initTcDsForSolver thing_inside
Just ret -> pure ret
Nothing -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLocDefault (getErrorMessages msgs)) }
-mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
+mkDsEnvs :: UnitEnv -> UnitIndexQuery -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> PromotionTickContext
-> IORef (Messages DsMessage) -> IORef CostCentreState
-> IORef (ModuleEnv Int) -> CompleteMatches
-> (DsGblEnv, DsLclEnv)
-mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
+mkDsEnvs unit_env query mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
next_wrapper_num complete_matches
= let if_genv = IfGblEnv { if_doc = text "mkDsEnvs"
-- Failing tests here are `ghci` and `T11985` if you get this wrong.
@@ -364,7 +367,7 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
, ds_fam_inst_env = fam_inst_env
, ds_gbl_rdr_env = rdr_env
, ds_if_env = (if_genv, if_lenv)
- , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env rdr_env
+ , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env query rdr_env
, ds_msgs = msg_var
, ds_complete_matches = complete_matches
, ds_cc_st = cc_st_var
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -588,7 +588,8 @@ checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
checkDependencies hsc_env summary iface
= do
res_normal <- classify_import (findImportedModule hsc_env) (ms_textual_imps summary ++ ms_srcimps summary)
- res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units mhome_unit mod) (ms_plugin_imps summary)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units query mhome_unit mod) (ms_plugin_imps summary)
case sequence (res_normal ++ res_plugin ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of
Left recomp -> return $ NeedsRecompile recomp
Right es -> do
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -27,6 +27,7 @@ module GHC.Rename.Names (
getMinimalImports,
printMinimalImports,
renamePkgQual, renameRawPkgQual,
+ hscRenamePkgQual, hscRenameRawPkgQual,
classifyGREs,
ImportDeclUsage,
) where
@@ -337,7 +338,8 @@ rnImportDecl this_mod
hsc_env <- getTopEnv
unit_env <- hsc_unit_env <$> getTopEnv
- let pkg_qual = renameRawPkgQual unit_env imp_mod_name raw_pkg_qual
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let pkg_qual = renameRawPkgQual unit_env query imp_mod_name raw_pkg_qual
-- Check for self-import, which confuses the typechecker (#9032)
-- ghc --make rejects self-import cycles already, but batch-mode may not
@@ -447,14 +449,14 @@ rnImportDecl this_mod
-- | Rename raw package imports
-renameRawPkgQual :: UnitEnv -> ModuleName -> RawPkgQual -> PkgQual
-renameRawPkgQual unit_env mn = \case
+renameRawPkgQual :: UnitEnv -> UnitIndexQuery -> ModuleName -> RawPkgQual -> PkgQual
+renameRawPkgQual unit_env query mn = \case
NoRawPkgQual -> NoPkgQual
- RawPkgQual p -> renamePkgQual unit_env mn (Just (sl_fs p))
+ RawPkgQual p -> renamePkgQual unit_env query mn (Just (sl_fs p))
-- | Rename raw package imports
-renamePkgQual :: UnitEnv -> ModuleName -> Maybe FastString -> PkgQual
-renamePkgQual unit_env mn mb_pkg = case mb_pkg of
+renamePkgQual :: UnitEnv -> UnitIndexQuery -> ModuleName -> Maybe FastString -> PkgQual
+renamePkgQual unit_env query mn mb_pkg = case mb_pkg of
Nothing -> NoPkgQual
Just pkg_fs
| Just uid <- homeUnitId <$> ue_homeUnit unit_env
@@ -464,7 +466,7 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of
| Just (uid, _) <- find (fromMaybe False . fmap (== pkg_fs) . snd) home_names
-> ThisPkg uid
- | Just uid <- resolvePackageImport (ue_units unit_env) mn (PackageName pkg_fs)
+ | Just uid <- resolvePackageImport (ue_units unit_env) query mn (PackageName pkg_fs)
-> OtherPkg uid
| otherwise
@@ -482,6 +484,25 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of
hpt_deps :: S.Set UnitId
hpt_deps = homeUnitDepends units
+hscRenameRawPkgQual ::
+ MonadIO m =>
+ HscEnv ->
+ ModuleName ->
+ RawPkgQual ->
+ m PkgQual
+hscRenameRawPkgQual hsc_env name raw = do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ pure (renameRawPkgQual (hsc_unit_env hsc_env) query name raw)
+
+hscRenamePkgQual ::
+ MonadIO m =>
+ HscEnv ->
+ ModuleName ->
+ Maybe FastString ->
+ m PkgQual
+hscRenamePkgQual hsc_env name package = do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ pure (renamePkgQual (hsc_unit_env hsc_env) query name package)
-- | Calculate the 'ImportAvails' induced by an import of a particular
-- interface, but without 'imp_mods'.
=====================================
compiler/GHC/Runtime/Context.hs
=====================================
@@ -26,6 +26,7 @@ import GHC.Runtime.Eval.Types ( IcGlobalRdrEnv(..), Resume )
import GHC.Unit
import GHC.Unit.Env
+import GHC.Unit.State (UnitIndexQuery)
import GHC.Core.FamInstEnv
import GHC.Core.InstEnv
@@ -351,8 +352,8 @@ icInScopeTTs ictxt = filter in_scope_unqualified (ic_tythings ictxt)
]
-- | Get the NamePprCtx function based on the flags and this InteractiveContext
-icNamePprCtx :: UnitEnv -> InteractiveContext -> NamePprCtx
-icNamePprCtx unit_env ictxt = mkNamePprCtx ptc unit_env (icReaderEnv ictxt)
+icNamePprCtx :: UnitEnv -> UnitIndexQuery -> InteractiveContext -> NamePprCtx
+icNamePprCtx unit_env query ictxt = mkNamePprCtx ptc unit_env query (icReaderEnv ictxt)
where ptc = initPromotionTickContext (ic_dflags ictxt)
-- | extendInteractiveContext is called with new TyThings recently defined to update the
=====================================
compiler/GHC/Runtime/Loader.hs
=====================================
@@ -348,7 +348,8 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
let unit_state = ue_units unit_env
let mhome_unit = hsc_home_unit_maybe hsc_env
-- First find the unit the module resides in by searching exposed units and home modules
- found_module <- findPluginModule fc fopts unit_state mhome_unit mod_name
+ query <- hscUnitIndexQuery hsc_env
+ found_module <- findPluginModule fc fopts unit_state query mhome_unit mod_name
case found_module of
Found _ mod -> do
-- Find the exports of the module
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -266,9 +266,11 @@ tcRnModuleTcRnM hsc_env mod_sum
; when (notNull prel_imports) $ do
addDiagnostic TcRnImplicitImportOfPrelude
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+
; -- TODO This is a little skeevy; maybe handle a bit more directly
let { simplifyImport (L _ idecl) =
- ( renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName idecl) (ideclPkgQual idecl)
+ ( renameRawPkgQual (hsc_unit_env hsc_env) query (unLoc $ ideclName idecl) (ideclPkgQual idecl)
, reLoc $ ideclName idecl)
}
; raw_sig_imports <- liftIO
@@ -1996,11 +1998,13 @@ runTcInteractive hsc_env thing_inside
(loadSrcInterface (text "runTcInteractive") m
NotBoot mb_pkg)
+
; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i ->
case i of -- force above: see #15111
IIModule n -> getOrphans n NoPkgQual
- IIDecl i -> getOrphans (unLoc (ideclName i))
- (renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i))
+ IIDecl i -> do
+ qual <- hscRenameRawPkgQual hsc_env (unLoc $ ideclName i) (ideclPkgQual i)
+ getOrphans (unLoc (ideclName i)) qual
; let imports = emptyImportAvails { imp_orphs = orphs }
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -869,7 +869,8 @@ getNamePprCtx
= do { ptc <- initPromotionTickContext <$> getDynFlags
; rdr_env <- getGlobalRdrEnv
; hsc_env <- getTopEnv
- ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env }
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+ ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env }
-- | Like logInfoTcRn, but for user consumption
printForUserTcRn :: SDoc -> TcRn ()
=====================================
compiler/GHC/Types/Name/Ppr.hs
=====================================
@@ -13,6 +13,7 @@ import GHC.Data.FastString
import GHC.Unit
import GHC.Unit.Env
+import GHC.Unit.State (UnitIndexQuery)
import GHC.Types.Name
import GHC.Types.Name.Reader
@@ -68,11 +69,11 @@ with some holes, we should try to give the user some more useful information.
-- | Creates some functions that work out the best ways to format
-- names for the user according to a set of heuristics.
-mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> GlobalRdrEnvX info -> NamePprCtx
-mkNamePprCtx ptc unit_env env
+mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> UnitIndexQuery -> GlobalRdrEnvX info -> NamePprCtx
+mkNamePprCtx ptc unit_env index env
= QueryQualify
(mkQualName env)
- (mkQualModule unit_state home_unit)
+ (mkQualModule unit_state index home_unit)
(mkQualPackage unit_state)
(mkPromTick ptc env)
where
@@ -206,8 +207,8 @@ Side note (int-index):
-- | Creates a function for formatting modules based on two heuristics:
-- (1) if the module is the current module, don't qualify, and (2) if there
-- is only one exposed package which exports this module, don't qualify.
-mkQualModule :: UnitState -> Maybe HomeUnit -> QueryQualifyModule
-mkQualModule unit_state mhome_unit mod
+mkQualModule :: UnitState -> UnitIndexQuery -> Maybe HomeUnit -> QueryQualifyModule
+mkQualModule unit_state index mhome_unit mod
| Just home_unit <- mhome_unit
, isHomeModule home_unit mod = False
@@ -218,7 +219,7 @@ mkQualModule unit_state mhome_unit mod
= False
| otherwise = True
- where lookup = lookupModuleInAllUnits unit_state (moduleName mod)
+ where lookup = lookupModuleInAllUnits unit_state index (moduleName mod)
-- | Creates a function for formatting packages based on two heuristics:
-- (1) don't qualify if the package in question is "main", and (2) only qualify
=====================================
compiler/GHC/Unit/Env.hs
=====================================
@@ -100,6 +100,8 @@ data UnitEnv = UnitEnv
, ue_namever :: !GhcNameVersion
-- ^ GHC name/version (used for dynamic library suffix)
+
+ , ue_index :: !UnitIndex
}
ueEPS :: UnitEnv -> IO ExternalPackageState
@@ -108,12 +110,14 @@ ueEPS = eucEPS . ue_eps
initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv
initUnitEnv cur_unit hug namever platform = do
eps <- initExternalUnitCache
+ ue_index <- newUnitIndex
return $ UnitEnv
{ ue_eps = eps
, ue_home_unit_graph = hug
, ue_current_unit = cur_unit
, ue_platform = platform
, ue_namever = namever
+ , ue_index
}
-- | Get home-unit
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -36,7 +36,6 @@ module GHC.Unit.Finder (
lookupFileCache
) where
-import GHC.Driver.Env (hsc_mod_graph)
import GHC.Prelude
import GHC.Platform.Ways
@@ -68,7 +67,7 @@ import Control.Monad
import Data.Time
import qualified Data.Map as M
import GHC.Driver.Env
- ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env) )
+ ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env, hsc_mod_graph), hscUnitIndexQuery )
import GHC.Driver.Config.Finder
import GHC.Unit.Module.Graph (mgHomeModuleMap, ModuleNameHomeMap)
import qualified Data.Set as Set
@@ -164,19 +163,21 @@ findImportedModule hsc_env mod pkg_qual =
dflags = hsc_dflags hsc_env
fopts = initFinderOpts dflags
in do
+ query <- hscUnitIndexQuery hsc_env
let home_module_map = mgHomeModuleMap (hsc_mod_graph hsc_env)
- findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) home_module_map mhome_unit mod pkg_qual
+ findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) query home_module_map mhome_unit mod pkg_qual
findImportedModuleNoHsc
:: FinderCache
-> FinderOpts
-> UnitEnv
+ -> UnitIndexQuery
-> ModuleNameHomeMap
-> Maybe HomeUnit
-> ModuleName
-> PkgQual
-> IO FindResult
-findImportedModuleNoHsc fc fopts ue home_module_map mhome_unit mod_name mb_pkg =
+findImportedModuleNoHsc fc fopts ue query home_module_map mhome_unit mod_name mb_pkg =
case mb_pkg of
NoPkgQual -> unqual_import
ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import
@@ -202,7 +203,7 @@ findImportedModuleNoHsc fc fopts ue home_module_map mhome_unit mod_name mb_pkg =
-- If the module is reexported, then look for it as if it was from the perspective
-- of that package which reexports it.
| mod_name `Set.member` finder_reexportedModules opts =
- findImportedModuleNoHsc fc opts ue home_module_map (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
+ findImportedModuleNoHsc fc opts ue query home_module_map (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
| mod_name `Set.member` finder_hiddenModules opts =
return (mkHomeHidden uid)
| otherwise =
@@ -213,11 +214,11 @@ findImportedModuleNoHsc fc fopts ue home_module_map mhome_unit mod_name mb_pkg =
-- first before looking at the packages in order.
any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts_list)
- pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg
+ pkg_import = findExposedPackageModule fc fopts units query mod_name mb_pkg
unqual_import = any_home_import
`orIfNotFound`
- findExposedPackageModule fc fopts units mod_name NoPkgQual
+ findExposedPackageModule fc fopts units query mod_name NoPkgQual
units = case mhome_unit of
Nothing -> ue_units ue
@@ -242,13 +243,13 @@ findImportedModuleNoHsc fc fopts ue home_module_map mhome_unit mod_name mb_pkg =
-- plugin. This consults the same set of exposed packages as
-- 'findImportedModule', unless @-hide-all-plugin-packages@ or
-- @-plugin-package@ are specified.
-findPluginModule :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult
-findPluginModule fc fopts units (Just home_unit) mod_name =
+findPluginModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> Maybe HomeUnit -> ModuleName -> IO FindResult
+findPluginModule fc fopts units query (Just home_unit) mod_name =
findHomeModule fc fopts home_unit mod_name
`orIfNotFound`
- findExposedPluginPackageModule fc fopts units mod_name
-findPluginModule fc fopts units Nothing mod_name =
- findExposedPluginPackageModule fc fopts units mod_name
+ findExposedPluginPackageModule fc fopts units query mod_name
+findPluginModule fc fopts units query Nothing mod_name =
+ findExposedPluginPackageModule fc fopts units query mod_name
-- | Locate a specific 'Module'. The purpose of this function is to
-- create a 'ModLocation' for a given 'Module', that is to find out
@@ -304,15 +305,15 @@ homeSearchCache fc home_unit mod_name do_this = do
let mod = mkModule home_unit mod_name
modLocationCache fc mod do_this
-findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult
-findExposedPackageModule fc fopts units mod_name mb_pkg =
+findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> ModuleName -> PkgQual -> IO FindResult
+findExposedPackageModule fc fopts units query mod_name mb_pkg =
findLookupResult fc fopts
- $ lookupModuleWithSuggestions units mod_name mb_pkg
+ $ lookupModuleWithSuggestions units query mod_name mb_pkg
-findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> IO FindResult
-findExposedPluginPackageModule fc fopts units mod_name =
+findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> ModuleName -> IO FindResult
+findExposedPluginPackageModule fc fopts units query mod_name =
findLookupResult fc fopts
- $ lookupPluginModuleWithSuggestions units mod_name NoPkgQual
+ $ lookupPluginModuleWithSuggestions units query mod_name NoPkgQual
findLookupResult :: FinderCache -> FinderOpts -> LookupResult -> IO FindResult
findLookupResult fc fopts r = case r of
=====================================
compiler/GHC/Unit/State.hs
=====================================
@@ -1,6 +1,6 @@
-- (c) The University of Glasgow, 2006
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase, OverloadedRecordDot, RecordWildCards #-}
-- | Unit manipulation
module GHC.Unit.State (
@@ -49,6 +49,15 @@ module GHC.Unit.State (
closeUnitDeps',
mayThrowUnitErr,
+ UnitConfig (..),
+ UnitIndex (..),
+ UnitIndexQuery (..),
+ UnitVisibility (..),
+ VisibilityMap,
+ ModuleNameProvidersMap,
+ newUnitIndex,
+ unitIndexQuery,
+
-- * Module hole substitution
ShHoleSubst,
renameHoleUnit,
@@ -121,6 +130,8 @@ import qualified Data.Semigroup as Semigroup
import qualified Data.Set as Set
import GHC.LanguageExtensions
import Control.Applicative
+import Control.Monad.IO.Class (MonadIO (..))
+import Data.IORef (IORef, newIORef, readIORef)
-- ---------------------------------------------------------------------------
-- The Unit state
@@ -577,10 +588,10 @@ searchPackageId pkgstate pid = filter ((pid ==) . unitPackageId)
-- | Find the UnitId which an import qualified by a package import comes from.
-- Compared to 'lookupPackageName', this function correctly accounts for visibility,
-- renaming and thinning.
-resolvePackageImport :: UnitState -> ModuleName -> PackageName -> Maybe UnitId
-resolvePackageImport unit_st mn pn = do
+resolvePackageImport :: UnitState -> UnitIndexQuery -> ModuleName -> PackageName -> Maybe UnitId
+resolvePackageImport unit_st query mn pn = do
-- 1. Find all modules providing the ModuleName (this accounts for visibility/thinning etc)
- providers <- filterUniqMap originVisible <$> lookupUniqMap (moduleNameProvidersMap unit_st) mn
+ providers <- filterUniqMap originVisible <$> query.findOrigin unit_st mn False
-- 2. Get the UnitIds of the candidates
let candidates_uid = concatMap to_uid $ sortOn fst $ nonDetUniqMapToList providers
-- 3. Get the package names of the candidates
@@ -638,14 +649,14 @@ listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state)
-- 'initUnits' can be called again subsequently after updating the
-- 'packageFlags' field of the 'DynFlags', and it will update the
-- 'unitState' in 'DynFlags'.
-initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
-initUnits logger dflags cached_dbs home_units = do
+initUnits :: Logger -> DynFlags -> UnitIndex -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
+initUnits logger dflags index cached_dbs home_units = do
let forceUnitInfoMap (state, _) = unitInfoMap state `seq` ()
(unit_state,dbs) <- withTiming logger (text "initializing unit database")
forceUnitInfoMap
- $ mkUnitState logger (initUnitConfig dflags cached_dbs home_units)
+ $ mkUnitState logger (homeUnitId_ dflags) (initUnitConfig dflags cached_dbs home_units) index
putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map"
FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})
@@ -1021,7 +1032,7 @@ selectPackages prec_map arg pkgs unusable
= let matches = matching arg
(ps,rest) = partition matches pkgs
in if null ps
- then Left (filter (matches.fst) (nonDetEltsUniqMap unusable))
+ then Left (filter (matches . fst) (nonDetEltsUniqMap unusable))
else Right (sortByPreference prec_map ps, rest)
-- | Rename a 'UnitInfo' according to some module instantiation.
@@ -1484,9 +1495,11 @@ validateDatabase cfg pkg_map1 =
mkUnitState
:: Logger
+ -> UnitId
-> UnitConfig
+ -> UnitIndex
-> IO (UnitState,[UnitDatabase UnitId])
-mkUnitState logger cfg = do
+mkUnitState logger unit cfg index = do
{-
Plan.
@@ -1542,15 +1555,9 @@ mkUnitState logger cfg = do
-- if databases have not been provided, read the database flags
raw_dbs <- case unitConfigDBCache cfg of
- Nothing -> readUnitDatabases logger cfg
+ Nothing -> index.readDatabases logger unit cfg
Just dbs -> return dbs
- -- distrust all units if the flag is set
- let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) }
- dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs
- | otherwise = raw_dbs
-
-
-- This, and the other reverse's that you will see, are due to the fact that
-- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order
-- than they are on the command line.
@@ -1561,159 +1568,7 @@ mkUnitState logger cfg = do
let home_unit_deps = selectHomeUnits (unitConfigHomeUnits cfg) hpt_flags
- -- Merge databases together, without checking validity
- (pkg_map1, prec_map) <- mergeDatabases logger dbs
-
- -- Now that we've merged everything together, prune out unusable
- -- packages.
- let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
-
- reportCycles logger sccs
- reportUnusable logger unusable
-
- -- Apply trust flags (these flags apply regardless of whether
- -- or not packages are visible or not)
- pkgs1 <- mayThrowUnitErr
- $ foldM (applyTrustFlag prec_map unusable)
- (nonDetEltsUniqMap pkg_map2) (reverse (unitConfigFlagsTrusted cfg))
- let prelim_pkg_db = mkUnitInfoMap pkgs1
-
- --
- -- Calculate the initial set of units from package databases, prior to any package flags.
- --
- -- Conceptually, we select the latest versions of all valid (not unusable) *packages*
- -- (not units). This is empty if we have -hide-all-packages.
- --
- -- Then we create an initial visibility map with default visibilities for all
- -- exposed, definite units which belong to the latest valid packages.
- --
- let preferLater unit unit' =
- case compareByPreference prec_map unit unit' of
- GT -> unit
- _ -> unit'
- addIfMorePreferable m unit = addToUDFM_C preferLater m (fsPackageName unit) unit
- -- This is the set of maximally preferable packages. In fact, it is a set of
- -- most preferable *units* keyed by package name, which act as stand-ins in
- -- for "a package in a database". We use units here because we don't have
- -- "a package in a database" as a type currently.
- mostPreferablePackageReps = if unitConfigHideAll cfg
- then emptyUDFM
- else foldl' addIfMorePreferable emptyUDFM pkgs1
- -- When exposing units, we want to consider all of those in the most preferable
- -- packages. We can implement that by looking for units that are equi-preferable
- -- with the most preferable unit for package. Being equi-preferable means that
- -- they must be in the same database, with the same version, and the same package name.
- --
- -- We must take care to consider all these units and not just the most
- -- preferable one, otherwise we can end up with problems like #16228.
- mostPreferable u =
- case lookupUDFM mostPreferablePackageReps (fsPackageName u) of
- Nothing -> False
- Just u' -> compareByPreference prec_map u u' == EQ
- vis_map1 = foldl' (\vm p ->
- -- Note: we NEVER expose indefinite packages by
- -- default, because it's almost assuredly not
- -- what you want (no mix-in linking has occurred).
- if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p
- then addToUniqMap vm (mkUnit p)
- UnitVisibility {
- uv_expose_all = True,
- uv_renamings = [],
- uv_package_name = First (Just (fsPackageName p)),
- uv_requirements = emptyUniqMap,
- uv_explicit = Nothing
- }
- else vm)
- emptyUniqMap pkgs1
-
- --
- -- Compute a visibility map according to the command-line flags (-package,
- -- -hide-package). This needs to know about the unusable packages, since if a
- -- user tries to enable an unusable package, we should let them know.
- --
- vis_map2 <- mayThrowUnitErr
- $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
- (unitConfigHideAll cfg) pkgs1)
- vis_map1 other_flags
-
- --
- -- Sort out which packages are wired in. This has to be done last, since
- -- it modifies the unit ids of wired in packages, but when we process
- -- package arguments we need to key against the old versions.
- --
- (pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2
- let pkg_db = mkUnitInfoMap pkgs2
-
- -- Update the visibility map, so we treat wired packages as visible.
- let vis_map = updateVisibilityMap wired_map vis_map2
-
- let hide_plugin_pkgs = unitConfigHideAllPlugins cfg
- plugin_vis_map <-
- case unitConfigFlagsPlugins cfg of
- -- common case; try to share the old vis_map
- [] | not hide_plugin_pkgs -> return vis_map
- | otherwise -> return emptyUniqMap
- _ -> do let plugin_vis_map1
- | hide_plugin_pkgs = emptyUniqMap
- -- Use the vis_map PRIOR to wired in,
- -- because otherwise applyPackageFlag
- -- won't work.
- | otherwise = vis_map2
- plugin_vis_map2
- <- mayThrowUnitErr
- $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
- hide_plugin_pkgs pkgs1)
- plugin_vis_map1
- (reverse (unitConfigFlagsPlugins cfg))
- -- Updating based on wired in packages is mostly
- -- good hygiene, because it won't matter: no wired in
- -- package has a compiler plugin.
- -- TODO: If a wired in package had a compiler plugin,
- -- and you tried to pick different wired in packages
- -- with the plugin flags and the normal flags... what
- -- would happen? I don't know! But this doesn't seem
- -- likely to actually happen.
- return (updateVisibilityMap wired_map plugin_vis_map2)
-
- let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
- | p <- pkgs2
- ]
- -- The explicitUnits accurately reflects the set of units we have turned
- -- on; as such, it also is the only way one can come up with requirements.
- -- The requirement context is directly based off of this: we simply
- -- look for nested unit IDs that are directly fed holes: the requirements
- -- of those units are precisely the ones we need to track
- let explicit_pkgs = [(k, uv_explicit v) | (k, v) <- nonDetUniqMapToList vis_map]
- req_ctx = mapUniqMap (Set.toList)
- $ plusUniqMapListWith Set.union (map uv_requirements (nonDetEltsUniqMap vis_map))
-
-
- --
- -- Here we build up a set of the packages mentioned in -package
- -- flags on the command line; these are called the "preload"
- -- packages. we link these packages in eagerly. The preload set
- -- should contain at least rts & base, which is why we pretend that
- -- the command line contains -package rts & -package base.
- --
- -- NB: preload IS important even for type-checking, because we
- -- need the correct include path to be set.
- --
- let preload1 = nonDetKeysUniqMap (filterUniqMap (isJust . uv_explicit) vis_map)
-
- -- add default preload units if they can be found in the db
- basicLinkedUnits = fmap (RealUnit . Definite)
- $ filter (flip elemUniqMap pkg_db)
- $ unitConfigAutoLink cfg
- preload3 = ordNub $ (basicLinkedUnits ++ preload1)
-
- -- Close the preload packages with their dependencies
- dep_preload <- mayThrowUnitErr
- $ closeUnitDeps pkg_db
- $ zip (map toUnitId preload3) (repeat Nothing)
-
- let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
- mod_map2 = mkUnusableModuleNameProvidersMap unusable
- mod_map = mod_map2 `plusUniqMap` mod_map1
+ (moduleNameProvidersMap, pluginModuleNameProvidersMap, pkg_db, explicit_pkgs, dep_preload, req_ctx, pkgname_map, wired_map) <- index.update logger unit cfg raw_dbs other_flags
-- Force the result to avoid leaking input parameters
let !state = UnitState
@@ -1722,8 +1577,8 @@ mkUnitState logger cfg = do
, homeUnitDepends = home_unit_deps
, unitInfoMap = pkg_db
, preloadClosure = emptyUniqSet
- , moduleNameProvidersMap = mod_map
- , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
+ , moduleNameProvidersMap
+ , pluginModuleNameProvidersMap
, packageNameMap = pkgname_map
, wireMap = wired_map
, unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ]
@@ -1896,6 +1751,263 @@ addListTo = foldl' merge
mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin
mkModMap pkg mod = unitUniqMap (mkModule pkg mod)
+-- -----------------------------------------------------------------------------
+-- Index
+
+data UnitIndexQuery =
+ UnitIndexQuery {
+ findOrigin :: UnitState -> ModuleName -> Bool -> Maybe (UniqMap Module ModuleOrigin),
+ index_all :: UnitState -> ModuleNameProvidersMap
+ }
+
+data UnitIndex =
+ UnitIndex {
+ query :: UnitId -> IO UnitIndexQuery,
+ readDatabases :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId],
+ update ::
+ Logger ->
+ UnitId ->
+ UnitConfig ->
+ [UnitDatabase UnitId] ->
+ [PackageFlag] ->
+ IO (
+ ModuleNameProvidersMap,
+ ModuleNameProvidersMap,
+ UnitInfoMap,
+ [(Unit, Maybe PackageArg)],
+ [UnitId],
+ UniqMap ModuleName [InstantiatedModule],
+ UniqFM PackageName UnitId,
+ WiringMap
+ )
+ }
+
+unitIndexQuery ::
+ MonadIO m =>
+ UnitId ->
+ UnitIndex ->
+ m UnitIndexQuery
+unitIndexQuery unit index = liftIO (index.query unit)
+
+data UnitIndexBackend =
+ UnitIndexBackend {
+ moduleNameProviders :: !ModuleNameProvidersMap,
+ pluginModuleNameProviders :: !ModuleNameProvidersMap
+ }
+
+newUnitIndexBackend :: UnitIndexBackend
+newUnitIndexBackend =
+ UnitIndexBackend {
+ moduleNameProviders = mempty,
+ pluginModuleNameProviders = mempty
+ }
+
+queryFindOriginDefault ::
+ UnitIndexBackend ->
+ UnitState ->
+ ModuleName ->
+ Bool ->
+ Maybe (UniqMap Module ModuleOrigin)
+queryFindOriginDefault _ UnitState {moduleNameProvidersMap, pluginModuleNameProvidersMap} name plugins =
+ lookupUniqMap source name
+ where
+ source = if plugins then pluginModuleNameProvidersMap else moduleNameProvidersMap
+
+newUnitIndexQuery ::
+ MonadIO m =>
+ IORef UnitIndexBackend ->
+ UnitId ->
+ m UnitIndexQuery
+newUnitIndexQuery ref _ = do
+ state <- liftIO $ readIORef ref
+ pure UnitIndexQuery {
+ findOrigin = queryFindOriginDefault state,
+ index_all = \ s -> s.moduleNameProvidersMap
+ }
+
+updateIndexDefault ::
+ Logger ->
+ UnitId ->
+ UnitConfig ->
+ [UnitDatabase UnitId] ->
+ [PackageFlag] ->
+ IO (ModuleNameProvidersMap, ModuleNameProvidersMap, UnitInfoMap, [(Unit, Maybe PackageArg)], [UnitId], UniqMap ModuleName [InstantiatedModule], UniqFM PackageName UnitId, WiringMap)
+updateIndexDefault logger _ cfg raw_dbs other_flags = do
+
+ -- distrust all units if the flag is set
+ let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) }
+ dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs
+ | otherwise = raw_dbs
+
+
+ -- Merge databases together, without checking validity
+ (pkg_map1, prec_map) <- mergeDatabases logger dbs
+
+ -- Now that we've merged everything together, prune out unusable
+ -- packages.
+ let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
+
+ reportCycles logger sccs
+ reportUnusable logger unusable
+
+ -- Apply trust flags (these flags apply regardless of whether
+ -- or not packages are visible or not)
+ pkgs1 <- mayThrowUnitErr
+ $ foldM (applyTrustFlag prec_map unusable)
+ (nonDetEltsUniqMap pkg_map2) (reverse (unitConfigFlagsTrusted cfg))
+ let prelim_pkg_db = mkUnitInfoMap pkgs1
+
+ --
+ -- Calculate the initial set of units from package databases, prior to any package flags.
+ --
+ -- Conceptually, we select the latest versions of all valid (not unusable) *packages*
+ -- (not units). This is empty if we have -hide-all-packages.
+ --
+ -- Then we create an initial visibility map with default visibilities for all
+ -- exposed, definite units which belong to the latest valid packages.
+ --
+ let preferLater unit unit' =
+ case compareByPreference prec_map unit unit' of
+ GT -> unit
+ _ -> unit'
+ addIfMorePreferable m unit = addToUDFM_C preferLater m (fsPackageName unit) unit
+ -- This is the set of maximally preferable packages. In fact, it is a set of
+ -- most preferable *units* keyed by package name, which act as stand-ins in
+ -- for "a package in a database". We use units here because we don't have
+ -- "a package in a database" as a type currently.
+ mostPreferablePackageReps = if unitConfigHideAll cfg
+ then emptyUDFM
+ else foldl' addIfMorePreferable emptyUDFM pkgs1
+ -- When exposing units, we want to consider all of those in the most preferable
+ -- packages. We can implement that by looking for units that are equi-preferable
+ -- with the most preferable unit for package. Being equi-preferable means that
+ -- they must be in the same database, with the same version, and the same package name.
+ --
+ -- We must take care to consider all these units and not just the most
+ -- preferable one, otherwise we can end up with problems like #16228.
+ mostPreferable u =
+ case lookupUDFM mostPreferablePackageReps (fsPackageName u) of
+ Nothing -> False
+ Just u' -> compareByPreference prec_map u u' == EQ
+ vis_map1 = foldl' (\vm p ->
+ -- Note: we NEVER expose indefinite packages by
+ -- default, because it's almost assuredly not
+ -- what you want (no mix-in linking has occurred).
+ if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p
+ then addToUniqMap vm (mkUnit p)
+ UnitVisibility {
+ uv_expose_all = True,
+ uv_renamings = [],
+ uv_package_name = First (Just (fsPackageName p)),
+ uv_requirements = emptyUniqMap,
+ uv_explicit = Nothing
+ }
+ else vm)
+ emptyUniqMap pkgs1
+
+ --
+ -- Compute a visibility map according to the command-line flags (-package,
+ -- -hide-package). This needs to know about the unusable packages, since if a
+ -- user tries to enable an unusable package, we should let them know.
+ --
+ vis_map2 <- mayThrowUnitErr
+ $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
+ (unitConfigHideAll cfg) pkgs1)
+ vis_map1 other_flags
+
+ --
+ -- Sort out which packages are wired in. This has to be done last, since
+ -- it modifies the unit ids of wired in packages, but when we process
+ -- package arguments we need to key against the old versions.
+ --
+ (pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2
+ let pkg_db = mkUnitInfoMap pkgs2
+
+ -- Update the visibility map, so we treat wired packages as visible.
+ let vis_map = updateVisibilityMap wired_map vis_map2
+
+ let hide_plugin_pkgs = unitConfigHideAllPlugins cfg
+ plugin_vis_map <-
+ case unitConfigFlagsPlugins cfg of
+ -- common case; try to share the old vis_map
+ [] | not hide_plugin_pkgs -> return vis_map
+ | otherwise -> return emptyUniqMap
+ _ -> do let plugin_vis_map1
+ | hide_plugin_pkgs = emptyUniqMap
+ -- Use the vis_map PRIOR to wired in,
+ -- because otherwise applyPackageFlag
+ -- won't work.
+ | otherwise = vis_map2
+ plugin_vis_map2
+ <- mayThrowUnitErr
+ $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
+ hide_plugin_pkgs pkgs1)
+ plugin_vis_map1
+ (reverse (unitConfigFlagsPlugins cfg))
+ -- Updating based on wired in packages is mostly
+ -- good hygiene, because it won't matter: no wired in
+ -- package has a compiler plugin.
+ -- TODO: If a wired in package had a compiler plugin,
+ -- and you tried to pick different wired in packages
+ -- with the plugin flags and the normal flags... what
+ -- would happen? I don't know! But this doesn't seem
+ -- likely to actually happen.
+ return (updateVisibilityMap wired_map plugin_vis_map2)
+
+ let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
+ | p <- pkgs2
+ ]
+ -- The explicitUnits accurately reflects the set of units we have turned
+ -- on; as such, it also is the only way one can come up with requirements.
+ -- The requirement context is directly based off of this: we simply
+ -- look for nested unit IDs that are directly fed holes: the requirements
+ -- of those units are precisely the ones we need to track
+ let explicit_pkgs = [(k, uv_explicit v) | (k, v) <- nonDetUniqMapToList vis_map]
+ req_ctx = mapUniqMap (Set.toList)
+ $ plusUniqMapListWith Set.union (map uv_requirements (nonDetEltsUniqMap vis_map))
+
+
+ --
+ -- Here we build up a set of the packages mentioned in -package
+ -- flags on the command line; these are called the "preload"
+ -- packages. we link these packages in eagerly. The preload set
+ -- should contain at least rts & base, which is why we pretend that
+ -- the command line contains -package rts & -package base.
+ --
+ -- NB: preload IS important even for type-checking, because we
+ -- need the correct include path to be set.
+ --
+ let preload1 = nonDetKeysUniqMap (filterUniqMap (isJust . uv_explicit) vis_map)
+
+ -- add default preload units if they can be found in the db
+ basicLinkedUnits = fmap (RealUnit . Definite)
+ $ filter (flip elemUniqMap pkg_db)
+ $ unitConfigAutoLink cfg
+ preload3 = ordNub $ (basicLinkedUnits ++ preload1)
+
+ -- Close the preload packages with their dependencies
+ dep_preload <- mayThrowUnitErr
+ $ closeUnitDeps pkg_db
+ $ zip (map toUnitId preload3) (repeat Nothing)
+
+ let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
+ mod_map2 = mkUnusableModuleNameProvidersMap unusable
+ mod_map = mod_map2 `plusUniqMap` mod_map1
+ pluginModuleNameProviders = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
+ pure (mod_map, pluginModuleNameProviders, pkg_db, explicit_pkgs, dep_preload, req_ctx, pkgname_map, wired_map)
+
+readDatabasesDefault :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId]
+readDatabasesDefault logger _ cfg =
+ readUnitDatabases logger cfg
+
+newUnitIndex :: MonadIO m => m UnitIndex
+newUnitIndex = do
+ ref <- liftIO $ newIORef newUnitIndexBackend
+ pure UnitIndex {
+ query = newUnitIndexQuery ref,
+ readDatabases = readDatabasesDefault,
+ update = updateIndexDefault
+ }
-- -----------------------------------------------------------------------------
-- Package Utils
@@ -1903,10 +2015,11 @@ mkModMap pkg mod = unitUniqMap (mkModule pkg mod)
-- | Takes a 'ModuleName', and if the module is in any package returns
-- list of modules which take that name.
lookupModuleInAllUnits :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> [(Module, UnitInfo)]
-lookupModuleInAllUnits pkgs m
- = case lookupModuleWithSuggestions pkgs m NoPkgQual of
+lookupModuleInAllUnits pkgs query m
+ = case lookupModuleWithSuggestions pkgs query m NoPkgQual of
LookupFound a b -> [(a,fst b)]
LookupMultiple rs -> map f rs
where f (m,_) = (m, expectJust "lookupModule" (lookupUnit pkgs
@@ -1933,18 +2046,24 @@ data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin
| SuggestHidden ModuleName Module ModuleOrigin
lookupModuleWithSuggestions :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> PkgQual
-> LookupResult
-lookupModuleWithSuggestions pkgs
- = lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs)
+lookupModuleWithSuggestions pkgs query name
+ = lookupModuleWithSuggestions' pkgs query name False
-- | The package which the module **appears** to come from, this could be
-- the one which reexports the module from it's original package. This function
-- is currently only used for -Wunused-packages
-lookupModulePackage :: UnitState -> ModuleName -> PkgQual -> Maybe [UnitInfo]
-lookupModulePackage pkgs mn mfs =
- case lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs) mn mfs of
+lookupModulePackage ::
+ UnitState ->
+ UnitIndexQuery ->
+ ModuleName ->
+ PkgQual ->
+ Maybe [UnitInfo]
+lookupModulePackage pkgs query mn mfs =
+ case lookupModuleWithSuggestions' pkgs query mn False mfs of
LookupFound _ (orig_unit, origin) ->
case origin of
ModOrigin {fromOrigUnit, fromExposedReexport} ->
@@ -1960,19 +2079,21 @@ lookupModulePackage pkgs mn mfs =
_ -> Nothing
lookupPluginModuleWithSuggestions :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> PkgQual
-> LookupResult
-lookupPluginModuleWithSuggestions pkgs
- = lookupModuleWithSuggestions' pkgs (pluginModuleNameProvidersMap pkgs)
+lookupPluginModuleWithSuggestions pkgs query name
+ = lookupModuleWithSuggestions' pkgs query name True
lookupModuleWithSuggestions' :: UnitState
- -> ModuleNameProvidersMap
+ -> UnitIndexQuery
-> ModuleName
+ -> Bool
-> PkgQual
-> LookupResult
-lookupModuleWithSuggestions' pkgs mod_map m mb_pn
- = case lookupUniqMap mod_map m of
+lookupModuleWithSuggestions' pkgs query m onlyPlugins mb_pn
+ = case query.findOrigin pkgs m onlyPlugins of
Nothing -> LookupNotFound suggestions
Just xs ->
case foldl' classify ([],[],[], []) (sortOn fst $ nonDetUniqMapToList xs) of
@@ -2033,16 +2154,16 @@ lookupModuleWithSuggestions' pkgs mod_map m mb_pn
all_mods :: [(String, ModuleSuggestion)] -- All modules
all_mods = sortBy (comparing fst) $
[ (moduleNameString m, suggestion)
- | (m, e) <- nonDetUniqMapToList (moduleNameProvidersMap pkgs)
+ | (m, e) <- nonDetUniqMapToList (query.index_all pkgs)
, suggestion <- map (getSuggestion m) (nonDetUniqMapToList e)
]
getSuggestion name (mod, origin) =
(if originVisible origin then SuggestVisible else SuggestHidden)
name mod origin
-listVisibleModuleNames :: UnitState -> [ModuleName]
-listVisibleModuleNames state =
- map fst (filter visible (nonDetUniqMapToList (moduleNameProvidersMap state)))
+listVisibleModuleNames :: UnitState -> UnitIndexQuery -> [ModuleName]
+listVisibleModuleNames unit_state query =
+ map fst (filter visible (nonDetUniqMapToList (query.index_all unit_state)))
where visible (_, ms) = anyUniqMap originVisible ms
-- | Takes a list of UnitIds (and their "parent" dependency, used for error
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -3695,19 +3695,21 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000
completeModule = wrapIdentCompleterMod $ \w -> do
hsc_env <- GHC.getSession
- let pkg_mods = allVisibleModules (hsc_units hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let pkg_mods = allVisibleModules (hsc_units hsc_env) query
loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
return $ filter (w `isPrefixOf`)
$ map (showPpr (hsc_dflags hsc_env)) $ loaded_mods ++ pkg_mods
completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
hsc_env <- GHC.getSession
+ query <- liftIO $ hscUnitIndexQuery hsc_env
modules <- case m of
Just '-' -> do
imports <- GHC.getContext
return $ map iiModuleName imports
_ -> do
- let pkg_mods = allVisibleModules (hsc_units hsc_env)
+ let pkg_mods = allVisibleModules (hsc_units hsc_env) query
loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
return $ loaded_mods ++ pkg_mods
return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) modules
@@ -3775,8 +3777,8 @@ wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing wor
-- | Return a list of visible module names for autocompletion.
-- (NB: exposed != visible)
-allVisibleModules :: UnitState -> [ModuleName]
-allVisibleModules unit_state = listVisibleModuleNames unit_state
+allVisibleModules :: UnitState -> UnitIndexQuery -> [ModuleName]
+allVisibleModules us query = listVisibleModuleNames us query
completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
completeIdentifier
=====================================
ghc/GHCi/UI/Monad.hs
=====================================
@@ -374,10 +374,11 @@ printForUserGlobalRdrEnv mb_rdr_env doc = do
where
mkNamePprCtxFromGlobalRdrEnv _ Nothing = GHC.getNamePprCtx
mkNamePprCtxFromGlobalRdrEnv dflags (Just rdr_env) =
- withSession $ \ hsc_env ->
+ withSession $ \ hsc_env -> do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
let unit_env = hsc_unit_env hsc_env
ptc = initPromotionTickContext dflags
- in return $ Ppr.mkNamePprCtx ptc unit_env rdr_env
+ return $ Ppr.mkNamePprCtx ptc unit_env query rdr_env
printForUser :: GhcMonad m => SDoc -> m ()
printForUser doc = do
=====================================
ghc/Main.hs
=====================================
@@ -844,7 +844,8 @@ initMulti unitArgsFiles = do
let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
hue_flags = homeUnitEnv_dflags homeUnitEnv
dflags = homeUnitEnv_dflags homeUnitEnv
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units
+ index = hscUnitIndex hsc_env
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags index cached_unit_dbs home_units
updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
pure $ HomeUnitEnv
@@ -859,7 +860,7 @@ initMulti unitArgsFiles = do
let dflags = homeUnitEnv_dflags $ unitEnv_lookup mainUnitId home_unit_graph
unitEnv <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags))
- let final_hsc_env = hsc_env { hsc_unit_env = unitEnv }
+ let final_hsc_env = hsc_env { hsc_unit_env = unitEnv {ue_index = hscUnitIndex hsc_env} }
GHC.setSession final_hsc_env
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b705a78d51b8d05aa51d3b0f43921a4…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b705a78d51b8d05aa51d3b0f43921a4…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: NCG/LA64: Simplify genCCall into two parts
by Marge Bot (＠marge-bot) 06 Dec '25
by Marge Bot (＠marge-bot) 06 Dec '25
06 Dec '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
ac200723 by Peng Fan at 2025-12-06T06:35:34-05:00
NCG/LA64: Simplify genCCall into two parts
genCCall is too long, so it's been simplified into two parts:
genPrim and genLibCCall.
Suggested by Andreas Klebinger
- - - - -
479d99bb by Matthew Pickering at 2025-12-06T06:35:35-05:00
hadrian: Use a response file to invoke GHC for dep gathering.
In some cases we construct an argument list too long for GHC to
handle directly on windows. This happens when we generate
the dependency file because the command line will contain
references to a large number of .hs files.
To avoid this we now invoke GHC using a response file when
generating dependencies to sidestep length limitations.
Note that we only pass the actual file names in the dependency
file. Why? Because this side-steps #26560
- - - - -
0c97523e by Marc Scholten at 2025-12-06T06:35:43-05:00
update xhtml to 3000.4.0.0
haddock-api: bump xhtml bounds
haddock-api: use lazy text instead of string to support xhtml 3000.4.0.0
Bumping submodule xhtml to 3000.4.0.0
add xhtml to stage0Packages
remove unused import of writeUtf8File
Remove redundant import
Update haddock golden files for xhtml 3000.4.0.0
Metric Decrease:
haddock.Cabal
haddock.base
- - - - -
3df97eb7 by Julian Ospald at 2025-12-06T06:35:48-05:00
rts: Fix object file format detection in loadArchive
Commit 76d1041dfa4b96108cfdd22b07f2b3feb424dcbe seems to
have introduced this bug, ultimately leading to failure of
test T11788. I can only theorize that this test isn't run
in upstream's CI, because they don't build a static GHC.
The culprit is that we go through the thin archive, trying
to follow the members on the filesystem, but don't
re-identify the new object format of the member. This pins
`object_fmt` to `NotObject` from the thin archive.
Thanks to @angerman for spotting this.
- - - - -
c4d1f182 by mangoiv at 2025-12-06T06:35:53-05:00
users' guide: don't use f strings in the python script to ensure compatibility with python 3.5
- - - - -
29 changed files:
- compiler/GHC/CmmToAsm/LA64/CodeGen.hs
- docs/users_guide/conf.py
- hadrian/src/Builder.hs
- hadrian/src/Rules/ToolArgs.hs
- hadrian/src/Settings/Builders/Ghc.hs
- hadrian/src/Settings/Default.hs
- libraries/xhtml
- rts/linker/LoadArchive.c
- utils/haddock/cabal.project
- utils/haddock/haddock-api/haddock-api.cabal
- utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
- utils/haddock/haddock-api/src/Haddock/Doc.hs
- utils/haddock/haddock-api/src/Haddock/Utils.hs
- utils/haddock/html-test/ref/Bug26.html
- utils/haddock/html-test/ref/Bug298.html
- utils/haddock/html-test/ref/Bug458.html
- utils/haddock/html-test/ref/Nesting.html
- utils/haddock/html-test/ref/TitledPicture.html
- utils/haddock/html-test/ref/Unicode.html
- utils/haddock/html-test/ref/Unicode2.html
Changes:
=====================================
compiler/GHC/CmmToAsm/LA64/CodeGen.hs
=====================================
@@ -3,6 +3,7 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE MultiWayIf #-}
module GHC.CmmToAsm.LA64.CodeGen (
cmmTopCodeGen
, generateJumpTableForInstr
@@ -268,8 +269,10 @@ stmtToInstrs stmt = do
config <- getConfig
platform <- getPlatform
case stmt of
- CmmUnsafeForeignCall target result_regs args
- -> genCCall target result_regs args
+ CmmUnsafeForeignCall target result_regs args ->
+ case target of
+ PrimTarget primOp -> genPrim primOp result_regs args
+ ForeignTarget addr conv -> genCCall addr conv result_regs args
CmmComment s -> return (unitOL (COMMENT (ftext s)))
CmmTick {} -> return nilOL
@@ -1631,6 +1634,319 @@ genCondBranch true false expr = do
b2 <- genBranch false
return (b1 `appOL` b2)
+genPrim
+ :: CallishMachOp -- MachOp
+ -> [CmmFormal] -- where to put the result
+ -> [CmmActual] -- arguments (of mixed type)
+ -> NatM InstrBlock
+
+genPrim MO_F32_Fabs [dst] [src] = genFloatAbs W32 dst src
+genPrim MO_F64_Fabs [dst] [src] = genFloatAbs W64 dst src
+genPrim MO_F32_Sqrt [dst] [src] = genFloatSqrt FF32 dst src
+genPrim MO_F64_Sqrt [dst] [src] = genFloatSqrt FF64 dst src
+genPrim (MO_Clz width) [dst] [src] = genClz width dst src
+genPrim (MO_Ctz width) [dst] [src] = genCtz width dst src
+genPrim (MO_BSwap width) [dst] [src] = genByteSwap width dst src
+genPrim (MO_BRev width) [dst] [src] = genBitRev width dst src
+genPrim MO_AcquireFence [] [] = return $ unitOL (DBAR HintAcquire)
+genPrim MO_ReleaseFence [] [] = return $ unitOL (DBAR HintRelease)
+genPrim MO_SeqCstFence [] [] = return $ unitOL (DBAR HintSeqcst)
+genPrim MO_Touch [] [_] = return nilOL
+genPrim (MO_Prefetch_Data _n) [] [_] = return nilOL
+genPrim (MO_AtomicRead w mo) [dst] [addr] = genAtomicRead w mo dst addr
+genPrim (MO_AtomicWrite w mo) [] [addr,val] = genAtomicWrite w mo addr val
+
+genPrim mop@(MO_S_Mul2 _w) _ _ = unsupported mop
+genPrim mop@(MO_S_QuotRem _w) _ _ = unsupported mop
+genPrim mop@(MO_U_QuotRem _w) _ _ = unsupported mop
+genPrim mop@(MO_U_QuotRem2 _w) _ _ = unsupported mop
+genPrim mop@(MO_Add2 _w) _ _ = unsupported mop
+genPrim mop@(MO_AddWordC _w) _ _ = unsupported mop
+genPrim mop@(MO_SubWordC _w) _ _ = unsupported mop
+genPrim mop@(MO_AddIntC _w) _ _ = unsupported mop
+genPrim mop@(MO_SubIntC _w) _ _ = unsupported mop
+genPrim mop@(MO_U_Mul2 _w) _ _ = unsupported mop
+genPrim mop@MO_I64X2_Min _ _ = unsupported mop
+genPrim mop@MO_I64X2_Max _ _ = unsupported mop
+genPrim mop@MO_W64X2_Min _ _ = unsupported mop
+genPrim mop@MO_W64X2_Max _ _ = unsupported mop
+genPrim mop@MO_VS_Quot {} _ _ = unsupported mop
+genPrim mop@MO_VS_Rem {} _ _ = unsupported mop
+genPrim mop@MO_VU_Quot {} _ _ = unsupported mop
+genPrim mop@MO_VU_Rem {} _ _ = unsupported mop
+
+genPrim (MO_PopCnt width) [dst] [src] = genLibCCall (popCntLabel width) [dst] [src]
+genPrim (MO_Pdep width) [dst] [src,mask] = genLibCCall (pdepLabel width) [dst] [src,mask]
+genPrim (MO_Pext width) [dst] [src,mask] = genLibCCall (pextLabel width) [dst] [src,mask]
+genPrim (MO_UF_Conv width) [dst] [src] = genLibCCall (word2FloatLabel width) [dst] [src]
+genPrim (MO_AtomicRMW width amop) [dst] [addr,n] = genLibCCall (atomicRMWLabel width amop) [dst] [addr,n]
+genPrim (MO_Cmpxchg width) [dst] [addr,old,new] = genLibCCall (cmpxchgLabel width) [dst] [addr,old,new]
+genPrim (MO_Xchg width) [dst] [addr,val] = genLibCCall (xchgLabel width) [dst] [addr,val]
+genPrim (MO_Memcpy _align) [] [dst,src,n] = genLibCCall (fsLit "memcpy") [] [dst,src,n]
+genPrim (MO_Memmove _align) [] [dst,src,n] = genLibCCall (fsLit "memmove") [] [dst,src,n]
+genPrim (MO_Memcmp _align) [rst] [dst,src,n] = genLibCCall (fsLit "memcmp") [rst] [dst,src,n]
+genPrim (MO_Memset _align) [] [dst,cnt,n] = genLibCCall (fsLit "memset") [] [dst,cnt,n]
+genPrim MO_F32_Sin [dst] [src] = genLibCCall (fsLit "sinf") [dst] [src]
+genPrim MO_F32_Cos [dst] [src] = genLibCCall (fsLit "cosf") [dst] [src]
+genPrim MO_F32_Tan [dst] [src] = genLibCCall (fsLit "tanf") [dst] [src]
+genPrim MO_F32_Exp [dst] [src] = genLibCCall (fsLit "expf") [dst] [src]
+genPrim MO_F32_ExpM1 [dst] [src] = genLibCCall (fsLit "expm1f") [dst] [src]
+genPrim MO_F32_Log [dst] [src] = genLibCCall (fsLit "logf") [dst] [src]
+genPrim MO_F32_Log1P [dst] [src] = genLibCCall (fsLit "log1pf") [dst] [src]
+genPrim MO_F32_Asin [dst] [src] = genLibCCall (fsLit "asinf") [dst] [src]
+genPrim MO_F32_Acos [dst] [src] = genLibCCall (fsLit "acosf") [dst] [src]
+genPrim MO_F32_Atan [dst] [src] = genLibCCall (fsLit "atanf") [dst] [src]
+genPrim MO_F32_Sinh [dst] [src] = genLibCCall (fsLit "sinhf") [dst] [src]
+genPrim MO_F32_Cosh [dst] [src] = genLibCCall (fsLit "coshf") [dst] [src]
+genPrim MO_F32_Tanh [dst] [src] = genLibCCall (fsLit "tanhf") [dst] [src]
+genPrim MO_F32_Pwr [dst] [x,y] = genLibCCall (fsLit "powf") [dst] [x,y]
+genPrim MO_F32_Asinh [dst] [src] = genLibCCall (fsLit "asinhf") [dst] [src]
+genPrim MO_F32_Acosh [dst] [src] = genLibCCall (fsLit "acoshf") [dst] [src]
+genPrim MO_F32_Atanh [dst] [src] = genLibCCall (fsLit "atanhf") [dst] [src]
+genPrim MO_F64_Sin [dst] [src] = genLibCCall (fsLit "sin") [dst] [src]
+genPrim MO_F64_Cos [dst] [src] = genLibCCall (fsLit "cos") [dst] [src]
+genPrim MO_F64_Tan [dst] [src] = genLibCCall (fsLit "tan") [dst] [src]
+genPrim MO_F64_Exp [dst] [src] = genLibCCall (fsLit "exp") [dst] [src]
+genPrim MO_F64_ExpM1 [dst] [src] = genLibCCall (fsLit "expm1") [dst] [src]
+genPrim MO_F64_Log [dst] [src] = genLibCCall (fsLit "log") [dst] [src]
+genPrim MO_F64_Log1P [dst] [src] = genLibCCall (fsLit "log1p") [dst] [src]
+genPrim MO_F64_Asin [dst] [src] = genLibCCall (fsLit "asin") [dst] [src]
+genPrim MO_F64_Acos [dst] [src] = genLibCCall (fsLit "acos") [dst] [src]
+genPrim MO_F64_Atan [dst] [src] = genLibCCall (fsLit "atan") [dst] [src]
+genPrim MO_F64_Sinh [dst] [src] = genLibCCall (fsLit "sinh") [dst] [src]
+genPrim MO_F64_Cosh [dst] [src] = genLibCCall (fsLit "cosh") [dst] [src]
+genPrim MO_F64_Tanh [dst] [src] = genLibCCall (fsLit "tanh") [dst] [src]
+genPrim MO_F64_Pwr [dst] [x,y] = genLibCCall (fsLit "pow") [dst] [x,y]
+genPrim MO_F64_Asinh [dst] [src] = genLibCCall (fsLit "asinh") [dst] [src]
+genPrim MO_F64_Acosh [dst] [src] = genLibCCall (fsLit "acosh") [dst] [src]
+genPrim MO_F64_Atanh [dst] [src] = genLibCCall (fsLit "atanh") [dst] [src]
+genPrim MO_SuspendThread [tok] [rs,i] = genLibCCall (fsLit "suspendThread") [tok] [rs,i]
+genPrim MO_ResumeThread [rs] [tok] = genLibCCall (fsLit "resumeThread") [rs] [tok]
+genPrim MO_I64_ToI [dst] [src] = genLibCCall (fsLit "hs_int64ToInt") [dst] [src]
+genPrim MO_I64_FromI [dst] [src] = genLibCCall (fsLit "hs_intToInt64") [dst] [src]
+genPrim MO_W64_ToW [dst] [src] = genLibCCall (fsLit "hs_word64ToWord") [dst] [src]
+genPrim MO_W64_FromW [dst] [src] = genLibCCall (fsLit "hs_wordToWord64") [dst] [src]
+genPrim MO_x64_Neg [dst] [src] = genLibCCall (fsLit "hs_neg64") [dst] [src]
+genPrim MO_x64_Add [dst] [src] = genLibCCall (fsLit "hs_add64") [dst] [src]
+genPrim MO_x64_Sub [dst] [src] = genLibCCall (fsLit "hs_sub64") [dst] [src]
+genPrim MO_x64_Mul [dst] [src] = genLibCCall (fsLit "hs_mul64") [dst] [src]
+genPrim MO_I64_Quot [dst] [src] = genLibCCall (fsLit "hs_quotInt64") [dst] [src]
+genPrim MO_I64_Rem [dst] [src] = genLibCCall (fsLit "hs_remInt64") [dst] [src]
+genPrim MO_W64_Quot [dst] [src] = genLibCCall (fsLit "hs_quotWord64") [dst] [src]
+genPrim MO_W64_Rem [dst] [src] = genLibCCall (fsLit "hs_remWord64") [dst] [src]
+genPrim MO_x64_And [dst] [src] = genLibCCall (fsLit "hs_and64") [dst] [src]
+genPrim MO_x64_Or [dst] [src] = genLibCCall (fsLit "hs_or64") [dst] [src]
+genPrim MO_x64_Xor [dst] [src] = genLibCCall (fsLit "hs_xor64") [dst] [src]
+genPrim MO_x64_Not [dst] [src] = genLibCCall (fsLit "hs_not64") [dst] [src]
+genPrim MO_x64_Shl [dst] [src] = genLibCCall (fsLit "hs_uncheckedShiftL64") [dst] [src]
+genPrim MO_I64_Shr [dst] [src] = genLibCCall (fsLit "hs_uncheckedIShiftRA64") [dst] [src]
+genPrim MO_W64_Shr [dst] [src] = genLibCCall (fsLit "hs_uncheckedShiftRL64") [dst] [src]
+genPrim MO_x64_Eq [dst] [src] = genLibCCall (fsLit "hs_eq64") [dst] [src]
+genPrim MO_x64_Ne [dst] [src] = genLibCCall (fsLit "hs_ne64") [dst] [src]
+genPrim MO_I64_Ge [dst] [src] = genLibCCall (fsLit "hs_geInt64") [dst] [src]
+genPrim MO_I64_Gt [dst] [src] = genLibCCall (fsLit "hs_gtInt64") [dst] [src]
+genPrim MO_I64_Le [dst] [src] = genLibCCall (fsLit "hs_leInt64") [dst] [src]
+genPrim MO_I64_Lt [dst] [src] = genLibCCall (fsLit "hs_ltInt64") [dst] [src]
+genPrim MO_W64_Ge [dst] [src] = genLibCCall (fsLit "hs_geWord64") [dst] [src]
+genPrim MO_W64_Gt [dst] [src] = genLibCCall (fsLit "hs_gtWord64") [dst] [src]
+genPrim MO_W64_Le [dst] [src] = genLibCCall (fsLit "hs_leWord64") [dst] [src]
+genPrim MO_W64_Lt [dst] [src] = genLibCCall (fsLit "hs_ltWord64") [dst] [src]
+genPrim op dst args = do
+ platform <- ncgPlatform <$> getConfig
+ pprPanic "genPrim: unknown primOp" (ppr (pprCallishMachOp op, dst, fmap (pdoc platform) args))
+
+
+genFloatAbs :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock
+genFloatAbs w dst src = do
+ platform <- getPlatform
+ (reg_fx, _, code_fx) <- getFloatReg src
+ let dst_reg = getRegisterReg platform (CmmLocal dst)
+ return (code_fx `appOL` toOL
+ [
+ FABS (OpReg w dst_reg) (OpReg w reg_fx)
+ ]
+ )
+
+genFloatSqrt :: Format -> LocalReg -> CmmExpr -> NatM InstrBlock
+genFloatSqrt f dst src = do
+ platform <- getPlatform
+ (reg_fx, _, code_fx) <- getFloatReg src
+ let dst_reg = getRegisterReg platform (CmmLocal dst)
+ return (code_fx `appOL` toOL
+ [
+ FSQRT (OpReg w dst_reg) (OpReg w reg_fx)
+ ]
+ )
+ where
+ w = case f of
+ FF32 -> W32
+ _ -> W64
+
+genClz :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock
+genClz w dst src = do
+ platform <- getPlatform
+ (reg_x, _, code_x) <- getSomeReg src
+ let dst_reg = getRegisterReg platform (CmmLocal dst)
+ if w `elem` [W32, W64] then do
+ return (code_x `snocOL` CLZ (OpReg w dst_reg) (OpReg w reg_x))
+ else if w `elem` [W8, W16] then do
+ return (code_x `appOL` toOL
+ [
+ MOV (OpReg W64 dst_reg) (OpImm (ImmInt 1)),
+ SLL (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpImm (ImmInt (31-shift))),
+ SLL (OpReg W64 reg_x) (OpReg W64 reg_x) (OpImm (ImmInt (32-shift))),
+ OR (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpReg W64 reg_x),
+ CLZ (OpReg W64 dst_reg) (OpReg W32 dst_reg)
+ ]
+ )
+ else do
+ pprPanic "genClz: invalid width: " (ppr w)
+ where
+ shift = widthToInt w
+
+genCtz :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock
+genCtz w dst src = do
+ platform <- getPlatform
+ (reg_x, _, code_x) <- getSomeReg src
+ let dst_reg = getRegisterReg platform (CmmLocal dst)
+ if w `elem` [W32, W64] then do
+ return (code_x `snocOL` CTZ (OpReg w dst_reg) (OpReg w reg_x))
+ else if w `elem` [W8, W16] then do
+ return (code_x `appOL` toOL
+ [
+ MOV (OpReg W64 dst_reg) (OpImm (ImmInt 1)),
+ SLL (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpImm (ImmInt shift)),
+ BSTRPICK II64 (OpReg W64 reg_x) (OpReg W64 reg_x) (OpImm (ImmInt (shift-1))) (OpImm (ImmInt 0)),
+ OR (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpReg W64 reg_x),
+ CTZ (OpReg W64 dst_reg) (OpReg W64 dst_reg)
+ ]
+ )
+ else do
+ pprPanic "genCtz: invalid width: " (ppr w)
+ where
+ shift = (widthToInt w)
+
+genByteSwap :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock
+genByteSwap w dst src = do
+ platform <- getPlatform
+ (reg_x, _, code_x) <- getSomeReg src
+ let dst_reg = getRegisterReg platform (CmmLocal dst)
+ case w of
+ W64 ->
+ return (code_x `appOL` toOL
+ [
+ REVBD (OpReg w dst_reg) (OpReg w reg_x)
+ ]
+ )
+ W32 ->
+ return (code_x `appOL` toOL
+ [
+ REVB2W (OpReg w dst_reg) (OpReg w reg_x)
+ ]
+ )
+ W16 ->
+ return (code_x `appOL` toOL
+ [
+ REVB2H (OpReg w dst_reg) (OpReg w reg_x)
+ ]
+ )
+ _ -> pprPanic "genBSwap: invalid width: " (ppr w)
+
+genBitRev :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock
+genBitRev w dst src = do
+ platform <- getPlatform
+ (reg_x, _, code_x) <- getSomeReg src
+ let dst_reg = getRegisterReg platform (CmmLocal dst)
+ case w of
+ W8 ->
+ return (code_x `appOL` toOL
+ [
+ BITREV4B (OpReg W32 reg_x) (OpReg W32 reg_x),
+ AND (OpReg W64 dst_reg) (OpReg W64 reg_x) (OpImm (ImmInt 255))
+ ]
+ )
+ W16 ->
+ return (code_x `appOL` toOL
+ [
+ BITREV (OpReg W64 reg_x) (OpReg W64 reg_x),
+ SRL (OpReg W64 dst_reg) (OpReg W64 reg_x) (OpImm (ImmInt 48))
+ ]
+ )
+ _ -> return ( code_x `snocOL` BITREV (OpReg w dst_reg) (OpReg w reg_x))
+
+-- Generate C call to the given function in libc
+genLibCCall :: FastString -> [CmmFormal] -> [CmmActual] -> NatM InstrBlock
+genLibCCall name dsts args = do
+ config <- getConfig
+ target <-
+ cmmMakeDynamicReference config CallReference
+ $ mkForeignLabel name ForeignLabelInThisPackage IsFunction
+ let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn
+ genCCall target cconv dsts args
+
+unsupported :: Show a => a -> b
+unsupported mop = panic ("outOfLineCmmOp: " ++ show mop
+ ++ " not supported here")
+
+-- AMSWAP_DB* insns implentment a fully functional synchronization barrier, like DBAR 0x0.
+-- This is terrible. And AMSWAPDB only supports ISA version greater than LA64V1_0. So,
+-- implement with DBAR
+genAtomicRead :: Width -> MemoryOrdering -> LocalReg -> CmmExpr -> NatM InstrBlock
+genAtomicRead w mo dst arg = do
+ (addr_p, _, code_p) <- getSomeReg arg
+ platform <- getPlatform
+ let d = getRegisterReg platform (CmmLocal dst)
+ case mo of
+ MemOrderRelaxed ->
+ return (code_p `appOL` toOL
+ [
+ LD (intFormat w) (OpReg w d) (OpAddr $ AddrReg addr_p)
+ ]
+ )
+
+ MemOrderAcquire ->
+ return (code_p `appOL` toOL
+ [
+ LD (intFormat w) (OpReg w d) (OpAddr $ AddrReg addr_p),
+ DBAR HintAcquire
+ ]
+ )
+ MemOrderSeqCst ->
+ return (code_p `appOL` toOL
+ [
+ LD (intFormat w) (OpReg w d) (OpAddr $ AddrReg addr_p),
+ DBAR HintSeqcst
+ ]
+ )
+ _ -> panic $ "Unexpected MemOrderRelease on an AtomicRead: " ++ show mo
+
+genAtomicWrite :: Width -> MemoryOrdering -> CmmExpr -> CmmExpr -> NatM InstrBlock
+genAtomicWrite w mo addr val = do
+ (addr_p, _, code_p) <- getSomeReg addr
+ (val_reg, fmt_val, code_val) <- getSomeReg val
+ case mo of
+ MemOrderRelaxed ->
+ return (code_p `appOL`code_val `appOL` toOL
+ [
+ ST fmt_val (OpReg w val_reg) (OpAddr $ AddrReg addr_p)
+ ]
+ )
+ MemOrderRelease ->
+ return (code_p `appOL`code_val `appOL` toOL
+ [
+ DBAR HintRelease,
+ ST fmt_val (OpReg w val_reg) (OpAddr $ AddrReg addr_p)
+ ]
+ )
+ MemOrderSeqCst ->
+ return (code_p `appOL`code_val `appOL` toOL
+ [
+ DBAR HintSeqcst,
+ ST fmt_val (OpReg w val_reg) (OpAddr $ AddrReg addr_p)
+ ]
+ )
+ _ -> panic $ "Unexpected MemOrderAcquire on an AtomicWrite" ++ show mo
+
-- -----------------------------------------------------------------------------
{-
Generating C calls
@@ -1664,393 +1980,68 @@ wider than FRLEN may be passed in a GAR.
-}
genCCall
- :: ForeignTarget -- function to call
- -> [CmmFormal] -- where to put the result
- -> [CmmActual] -- arguments (of mixed type)
- -> NatM InstrBlock
-
--- TODO: Specialize where we can.
--- Generic impl
-genCCall target dest_regs arg_regs = do
- case target of
- -- The target :: ForeignTarget call can either
- -- be a foreign procedure with an address expr
- -- and a calling convention.
- ForeignTarget expr _cconv -> do
- (call_target, call_target_code) <- case expr of
- -- if this is a label, let's just directly to it.
- (CmmLit (CmmLabel lbl)) -> pure (TLabel lbl, nilOL)
- -- if it's not a label, let's compute the expression into a
- -- register and jump to that.
- _ -> do
- (reg, _format, reg_code) <- getSomeReg expr
- pure (TReg reg, reg_code)
- -- compute the code and register logic for all arg_regs.
- -- this will give us the format information to match on.
- arg_regs' <- mapM getSomeReg arg_regs
-
- -- Now this is stupid. Our Cmm expressions doesn't carry the proper sizes
- -- so while in Cmm we might get W64 incorrectly for an int, that is W32 in
- -- STG; this thenn breaks packing of stack arguments, if we need to pack
- -- for the pcs, e.g. darwinpcs. Option one would be to fix the Int type
- -- in Cmm proper. Option two, which we choose here is to use extended Hint
- -- information to contain the size information and use that when packing
- -- arguments, spilled onto the stack.
- let (_res_hints, arg_hints) = foreignTargetHints target
- arg_regs'' = zipWith (\(r, f, c) h -> (r,f,h,c)) arg_regs' arg_hints
-
- (stackSpaceWords, passRegs, passArgumentsCode) <- passArguments allGpArgRegs allFpArgRegs arg_regs'' 0 [] nilOL
-
- readResultsCode <- readResults allGpArgRegs allFpArgRegs dest_regs [] nilOL
-
- let moveStackDown 0 = toOL [ PUSH_STACK_FRAME
- , DELTA (-16)
- ]
- moveStackDown i | odd i = moveStackDown (i + 1)
- moveStackDown i = toOL [ PUSH_STACK_FRAME
- , SUB (OpReg W64 (spMachReg)) (OpReg W64 (spMachReg)) (OpImm (ImmInt (8 * i)))
- , DELTA (-8 * i - 16)
- ]
- moveStackUp 0 = toOL [ POP_STACK_FRAME
- , DELTA 0
- ]
- moveStackUp i | odd i = moveStackUp (i + 1)
- moveStackUp i = toOL [ ADD (OpReg W64 (spMachReg)) (OpReg W64 (spMachReg)) (OpImm (ImmInt (8 * i)))
- , POP_STACK_FRAME
- , DELTA 0
- ]
-
- let code =
- call_target_code -- compute the label (possibly into a register)
- `appOL` moveStackDown (stackSpaceWords)
- `appOL` passArgumentsCode -- put the arguments into x0, ...
- `snocOL` CALL call_target passRegs -- branch and link (C calls aren't tail calls, but return)
- `appOL` readResultsCode -- parse the results into registers
- `appOL` moveStackUp (stackSpaceWords)
- return code
-
- PrimTarget MO_F32_Fabs
- | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->
- unaryFloatOp W32 (\d x -> unitOL $ FABS d x) arg_reg dest_reg
- | otherwise -> panic "mal-formed MO_F32_Fabs"
- PrimTarget MO_F64_Fabs
- | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->
- unaryFloatOp W64 (\d x -> unitOL $ FABS d x) arg_reg dest_reg
- | otherwise -> panic "mal-formed MO_F64_Fabs"
-
- PrimTarget MO_F32_Sqrt
- | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->
- unaryFloatOp W32 (\d x -> unitOL $ FSQRT d x) arg_reg dest_reg
- | otherwise -> panic "mal-formed MO_F32_Sqrt"
- PrimTarget MO_F64_Sqrt
- | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->
- unaryFloatOp W64 (\d x -> unitOL $ FSQRT d x) arg_reg dest_reg
- | otherwise -> panic "mal-formed MO_F64_Sqrt"
-
- PrimTarget (MO_Clz w)
- | w `elem` [W32, W64],
- [arg_reg] <- arg_regs,
- [dest_reg] <- dest_regs -> do
- platform <- getPlatform
- (reg_x, _format_x, code_x) <- getSomeReg arg_reg
- let dst_reg = getRegisterReg platform (CmmLocal dest_reg)
- return ( code_x `snocOL`
- CLZ (OpReg w dst_reg) (OpReg w reg_x)
- )
- | w `elem` [W8, W16],
- [arg_reg] <- arg_regs,
- [dest_reg] <- dest_regs -> do
- platform <- getPlatform
- (reg_x, _format_x, code_x) <- getSomeReg arg_reg
- let dst_reg = getRegisterReg platform (CmmLocal dest_reg)
- return ( code_x `appOL` toOL
- [
- MOV (OpReg W64 dst_reg) (OpImm (ImmInt 1)),
- SLL (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpImm (ImmInt (31-shift))),
- SLL (OpReg W64 reg_x) (OpReg W64 reg_x) (OpImm (ImmInt (32-shift))),
- OR (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpReg W64 reg_x),
- CLZ (OpReg W64 dst_reg) (OpReg W32 dst_reg)
- ]
- )
- | otherwise -> unsupported (MO_Clz w)
- where
- shift = widthToInt w
-
- PrimTarget (MO_Ctz w)
- | w `elem` [W32, W64],
- [arg_reg] <- arg_regs,
- [dest_reg] <- dest_regs -> do
- platform <- getPlatform
- (reg_x, _format_x, code_x) <- getSomeReg arg_reg
- let dst_reg = getRegisterReg platform (CmmLocal dest_reg)
- return ( code_x `snocOL`
- CTZ (OpReg w dst_reg) (OpReg w reg_x)
- )
- | w `elem` [W8, W16],
- [arg_reg] <- arg_regs,
- [dest_reg] <- dest_regs -> do
- platform <- getPlatform
- (reg_x, _format_x, code_x) <- getSomeReg arg_reg
- let dst_reg = getRegisterReg platform (CmmLocal dest_reg)
- return ( code_x `appOL` toOL
- [
- MOV (OpReg W64 dst_reg) (OpImm (ImmInt 1)),
- SLL (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpImm (ImmInt shift)),
- BSTRPICK II64 (OpReg W64 reg_x) (OpReg W64 reg_x) (OpImm (ImmInt (shift-1))) (OpImm (ImmInt 0)),
- OR (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpReg W64 reg_x),
- CTZ (OpReg W64 dst_reg) (OpReg W64 dst_reg)
- ]
- )
- | otherwise -> unsupported (MO_Ctz w)
- where
- shift = (widthToInt w)
+ :: CmmExpr -- address of func call
+ -> ForeignConvention -- calling convention
+ -> [CmmFormal] -- results
+ -> [CmmActual] -- arguments
+ -> NatM InstrBlock
+
+
+genCCall expr _conv@(ForeignConvention _ argHints _resHints _) dest_regs arg_regs = do
+ (call_target, call_target_code) <- case expr of
+ -- if this is a label, let's just directly to it.
+ (CmmLit (CmmLabel lbl)) -> pure (TLabel lbl, nilOL)
+ -- if it's not a label, let's compute the expression into a
+ -- register and jump to that.
+ _ -> do
+ (reg, _format, reg_code) <- getSomeReg expr
+ pure (TReg reg, reg_code)
+ -- compute the code and register logic for all arg_regs.
+ -- this will give us the format information to match on.
+ arg_regs' <- mapM getSomeReg arg_regs
+
+ -- Now this is stupid. Our Cmm expressions doesn't carry the proper sizes
+ -- so while in Cmm we might get W64 incorrectly for an int, that is W32 in
+ -- STG; this thenn breaks packing of stack arguments, if we need to pack
+ -- for the pcs, e.g. darwinpcs. Option one would be to fix the Int type
+ -- in Cmm proper. Option two, which we choose here is to use extended Hint
+ -- information to contain the size information and use that when packing
+ -- arguments, spilled onto the stack.
+ let
+ arg_hints = take (length arg_regs) (argHints ++ repeat NoHint)
+ arg_regs'' = zipWith (\(r, f, c) h -> (r,f,h,c)) arg_regs' arg_hints
+
+ (stackSpaceWords, passRegs, passArgumentsCode) <- passArguments allGpArgRegs allFpArgRegs arg_regs'' 0 [] nilOL
+
+ readResultsCode <- readResults allGpArgRegs allFpArgRegs dest_regs [] nilOL
+
+ let moveStackDown 0 = toOL [ PUSH_STACK_FRAME
+ , DELTA (-16)
+ ]
+ moveStackDown i | odd i = moveStackDown (i + 1)
+ moveStackDown i = toOL [ PUSH_STACK_FRAME
+ , SUB (OpReg W64 (spMachReg)) (OpReg W64 (spMachReg)) (OpImm (ImmInt (8 * i)))
+ , DELTA (-8 * i - 16)
+ ]
+ moveStackUp 0 = toOL [ POP_STACK_FRAME
+ , DELTA 0
+ ]
+ moveStackUp i | odd i = moveStackUp (i + 1)
+ moveStackUp i = toOL [ ADD (OpReg W64 (spMachReg)) (OpReg W64 (spMachReg)) (OpImm (ImmInt (8 * i)))
+ , POP_STACK_FRAME
+ , DELTA 0
+ ]
- PrimTarget (MO_BSwap w)
- | w `elem` [W16, W32, W64],
- [arg_reg] <- arg_regs,
- [dest_reg] <- dest_regs -> do
- platform <- getPlatform
- (reg_x, _, code_x) <- getSomeReg arg_reg
- let dst_reg = getRegisterReg platform (CmmLocal dest_reg)
- case w of
- W64 -> return ( code_x `appOL` toOL
- [
- REVBD (OpReg w dst_reg) (OpReg w reg_x)
- ])
- W32 -> return ( code_x `appOL` toOL
- [
- REVB2W (OpReg w dst_reg) (OpReg w reg_x)
- ])
- _ -> return ( code_x `appOL` toOL
- [
- REVB2H (OpReg w dst_reg) (OpReg w reg_x)
- ])
- | otherwise -> unsupported (MO_BSwap w)
-
- PrimTarget (MO_BRev w)
- | w `elem` [W8, W16, W32, W64],
- [arg_reg] <- arg_regs,
- [dest_reg] <- dest_regs -> do
- platform <- getPlatform
- (reg_x, _, code_x) <- getSomeReg arg_reg
- let dst_reg = getRegisterReg platform (CmmLocal dest_reg)
- case w of
- W8 -> return ( code_x `appOL` toOL
- [
- BITREV4B (OpReg W32 reg_x) (OpReg W32 reg_x),
- AND (OpReg W64 dst_reg) (OpReg W64 reg_x) (OpImm (ImmInt 255))
- ])
- W16 -> return ( code_x `appOL` toOL
- [
- BITREV (OpReg W64 reg_x) (OpReg W64 reg_x),
- SRL (OpReg W64 dst_reg) (OpReg W64 reg_x) (OpImm (ImmInt 48))
- ])
- _ -> return ( code_x `snocOL` BITREV (OpReg w dst_reg) (OpReg w reg_x))
- | otherwise -> unsupported (MO_BRev w)
-
- -- mop :: CallishMachOp (see GHC.Cmm.MachOp)
- PrimTarget mop -> do
- -- We'll need config to construct forien targets
- case mop of
- -- 64 bit float ops
- MO_F64_Pwr -> mkCCall "pow"
-
- MO_F64_Sin -> mkCCall "sin"
- MO_F64_Cos -> mkCCall "cos"
- MO_F64_Tan -> mkCCall "tan"
-
- MO_F64_Sinh -> mkCCall "sinh"
- MO_F64_Cosh -> mkCCall "cosh"
- MO_F64_Tanh -> mkCCall "tanh"
-
- MO_F64_Asin -> mkCCall "asin"
- MO_F64_Acos -> mkCCall "acos"
- MO_F64_Atan -> mkCCall "atan"
-
- MO_F64_Asinh -> mkCCall "asinh"
- MO_F64_Acosh -> mkCCall "acosh"
- MO_F64_Atanh -> mkCCall "atanh"
-
- MO_F64_Log -> mkCCall "log"
- MO_F64_Log1P -> mkCCall "log1p"
- MO_F64_Exp -> mkCCall "exp"
- MO_F64_ExpM1 -> mkCCall "expm1"
-
- -- 32 bit float ops
- MO_F32_Pwr -> mkCCall "powf"
-
- MO_F32_Sin -> mkCCall "sinf"
- MO_F32_Cos -> mkCCall "cosf"
- MO_F32_Tan -> mkCCall "tanf"
- MO_F32_Sinh -> mkCCall "sinhf"
- MO_F32_Cosh -> mkCCall "coshf"
- MO_F32_Tanh -> mkCCall "tanhf"
- MO_F32_Asin -> mkCCall "asinf"
- MO_F32_Acos -> mkCCall "acosf"
- MO_F32_Atan -> mkCCall "atanf"
- MO_F32_Asinh -> mkCCall "asinhf"
- MO_F32_Acosh -> mkCCall "acoshf"
- MO_F32_Atanh -> mkCCall "atanhf"
- MO_F32_Log -> mkCCall "logf"
- MO_F32_Log1P -> mkCCall "log1pf"
- MO_F32_Exp -> mkCCall "expf"
- MO_F32_ExpM1 -> mkCCall "expm1f"
-
- -- 64-bit primops
- MO_I64_ToI -> mkCCall "hs_int64ToInt"
- MO_I64_FromI -> mkCCall "hs_intToInt64"
- MO_W64_ToW -> mkCCall "hs_word64ToWord"
- MO_W64_FromW -> mkCCall "hs_wordToWord64"
- MO_x64_Neg -> mkCCall "hs_neg64"
- MO_x64_Add -> mkCCall "hs_add64"
- MO_x64_Sub -> mkCCall "hs_sub64"
- MO_x64_Mul -> mkCCall "hs_mul64"
- MO_I64_Quot -> mkCCall "hs_quotInt64"
- MO_I64_Rem -> mkCCall "hs_remInt64"
- MO_W64_Quot -> mkCCall "hs_quotWord64"
- MO_W64_Rem -> mkCCall "hs_remWord64"
- MO_x64_And -> mkCCall "hs_and64"
- MO_x64_Or -> mkCCall "hs_or64"
- MO_x64_Xor -> mkCCall "hs_xor64"
- MO_x64_Not -> mkCCall "hs_not64"
- MO_x64_Shl -> mkCCall "hs_uncheckedShiftL64"
- MO_I64_Shr -> mkCCall "hs_uncheckedIShiftRA64"
- MO_W64_Shr -> mkCCall "hs_uncheckedShiftRL64"
- MO_x64_Eq -> mkCCall "hs_eq64"
- MO_x64_Ne -> mkCCall "hs_ne64"
- MO_I64_Ge -> mkCCall "hs_geInt64"
- MO_I64_Gt -> mkCCall "hs_gtInt64"
- MO_I64_Le -> mkCCall "hs_leInt64"
- MO_I64_Lt -> mkCCall "hs_ltInt64"
- MO_W64_Ge -> mkCCall "hs_geWord64"
- MO_W64_Gt -> mkCCall "hs_gtWord64"
- MO_W64_Le -> mkCCall "hs_leWord64"
- MO_W64_Lt -> mkCCall "hs_ltWord64"
-
- -- Conversion
- MO_UF_Conv w -> mkCCall (word2FloatLabel w)
-
- -- Optional MachOps
- -- These are enabled/disabled by backend flags: GHC.StgToCmm.Config
- MO_S_Mul2 _w -> unsupported mop
- MO_S_QuotRem _w -> unsupported mop
- MO_U_QuotRem _w -> unsupported mop
- MO_U_QuotRem2 _w -> unsupported mop
- MO_Add2 _w -> unsupported mop
- MO_AddWordC _w -> unsupported mop
- MO_SubWordC _w -> unsupported mop
- MO_AddIntC _w -> unsupported mop
- MO_SubIntC _w -> unsupported mop
- MO_U_Mul2 _w -> unsupported mop
-
- MO_VS_Quot {} -> unsupported mop
- MO_VS_Rem {} -> unsupported mop
- MO_VU_Quot {} -> unsupported mop
- MO_VU_Rem {} -> unsupported mop
- MO_I64X2_Min -> unsupported mop
- MO_I64X2_Max -> unsupported mop
- MO_W64X2_Min -> unsupported mop
- MO_W64X2_Max -> unsupported mop
-
- -- Memory Ordering
- -- Support finer-grained DBAR hints for LA664 and newer uarchs.
- -- These are treated as DBAR 0 on older uarchs, so we can start
- -- to unconditionally emit the new hints right away.
- MO_AcquireFence -> pure (unitOL (DBAR HintAcquire))
- MO_ReleaseFence -> pure (unitOL (DBAR HintRelease))
- MO_SeqCstFence -> pure (unitOL (DBAR HintSeqcst))
-
- MO_Touch -> pure nilOL -- Keep variables live (when using interior pointers)
- -- Prefetch
- MO_Prefetch_Data _n -> pure nilOL -- Prefetch hint.
-
- -- Memory copy/set/move/cmp, with alignment for optimization
-
- -- TODO Optimize and use e.g. quad registers to move memory around instead
- -- of offloading this to memcpy. For small memcpys we can utilize
- -- the 128bit quad registers in NEON to move block of bytes around.
- -- Might also make sense of small memsets? Use xzr? What's the function
- -- call overhead?
- MO_Memcpy _align -> mkCCall "memcpy"
- MO_Memset _align -> mkCCall "memset"
- MO_Memmove _align -> mkCCall "memmove"
- MO_Memcmp _align -> mkCCall "memcmp"
-
- MO_SuspendThread -> mkCCall "suspendThread"
- MO_ResumeThread -> mkCCall "resumeThread"
-
- MO_PopCnt w -> mkCCall (popCntLabel w)
- MO_Pdep w -> mkCCall (pdepLabel w)
- MO_Pext w -> mkCCall (pextLabel w)
-
- -- or a possibly side-effecting machine operation
- mo@(MO_AtomicRead w ord)
- | [p_reg] <- arg_regs
- , [dst_reg] <- dest_regs -> do
- (p, _fmt_p, code_p) <- getSomeReg p_reg
- platform <- getPlatform
- let instrs = case ord of
- MemOrderRelaxed -> unitOL $ ann moDescr (LD (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p))
-
- MemOrderAcquire -> toOL [
- ann moDescr (LD (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p)),
- DBAR HintAcquire
- ]
- MemOrderSeqCst -> toOL [
- ann moDescr (LD (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p)),
- DBAR HintSeqcst
- ]
- _ -> panic $ "Unexpected MemOrderRelease on an AtomicRead: " ++ show mo
- dst = getRegisterReg platform (CmmLocal dst_reg)
- moDescr = (text . show) mo
- code = code_p `appOL` instrs
- pure code
- | otherwise -> panic "mal-formed AtomicRead"
-
- mo@(MO_AtomicWrite w ord)
- | [p_reg, val_reg] <- arg_regs -> do
- (p, _fmt_p, code_p) <- getSomeReg p_reg
- (val, fmt_val, code_val) <- getSomeReg val_reg
- let instrs = case ord of
- MemOrderRelaxed -> unitOL $ ann moDescr (ST fmt_val (OpReg w val) (OpAddr $ AddrReg p))
- -- AMSWAP_DB* insns implentment a fully functional synchronization barrier, like DBAR 0x0.
- -- This is terrible. And AMSWAPDB only supports ISA version greater than LA64V1_0. So,
- -- implement with DBAR
- MemOrderRelease -> toOL [
- ann moDescr (DBAR HintRelease),
- ST fmt_val (OpReg w val) (OpAddr $ AddrReg p)
- ]
- MemOrderSeqCst -> toOL [
- ann moDescr (DBAR HintSeqcst),
- ST fmt_val (OpReg w val) (OpAddr $ AddrReg p)
- ]
- _ -> panic $ "Unexpected MemOrderAcquire on an AtomicWrite" ++ show mo
- moDescr = (text . show) mo
- code =
- code_p `appOL`
- code_val `appOL`
- instrs
- pure code
- | otherwise -> panic "mal-formed AtomicWrite"
-
- MO_AtomicRMW w amop -> mkCCall (atomicRMWLabel w amop)
- MO_Cmpxchg w -> mkCCall (cmpxchgLabel w)
- MO_Xchg w -> mkCCall (xchgLabel w)
+ let code =
+ call_target_code -- compute the label (possibly into a register)
+ `appOL` moveStackDown (stackSpaceWords)
+ `appOL` passArgumentsCode -- put the arguments into x0, ...
+ `snocOL` CALL call_target passRegs -- branch and link (C calls aren't tail calls, but return)
+ `appOL` readResultsCode -- parse the results into registers
+ `appOL` moveStackUp (stackSpaceWords)
+ return code
where
- unsupported :: Show a => a -> b
- unsupported mop = panic ("outOfLineCmmOp: " ++ show mop
- ++ " not supported here")
-
- mkCCall :: FastString -> NatM InstrBlock
- mkCCall name = do
- config <- getConfig
- target <-
- cmmMakeDynamicReference config CallReference
- $ mkForeignLabel name ForeignLabelInThisPackage IsFunction
- let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn
- genCCall (ForeignTarget target cconv) dest_regs arg_regs
-
-- Implementiation of the LoongArch ABI calling convention.
-- https://github.com/loongson/la-abi-specs/blob/release/lapcs.adoc#passing-ar…
passArguments :: [Reg] -> [Reg] -> [(Reg, Format, ForeignHint, InstrBlock)] -> Int -> [Reg] -> InstrBlock -> NatM (Int, [Reg], InstrBlock)
@@ -2129,10 +2120,10 @@ genCCall target dest_regs arg_regs = do
readResults _ _ [] _ accumCode = return accumCode
readResults [] _ _ _ _ = do
platform <- getPlatform
- pprPanic "genCCall, out of gp registers when reading results" (pdoc platform target)
+ pprPanic "genCCall, out of gp registers when reading results" (pdoc platform expr)
readResults _ [] _ _ _ = do
platform <- getPlatform
- pprPanic "genCCall, out of fp registers when reading results" (pdoc platform target)
+ pprPanic "genCCall, out of fp registers when reading results" (pdoc platform expr)
readResults (gpReg:gpRegs) (fpReg:fpRegs) (dst:dsts) accumRegs accumCode = do
-- gp/fp reg -> dst
platform <- getPlatform
@@ -2150,13 +2141,6 @@ genCCall target dest_regs arg_regs = do
-- truncate, otherwise an unexpectedly big value might be used in upfollowing calculations
truncateReg W64 w r_dst
- unaryFloatOp w op arg_reg dest_reg = do
- platform <- getPlatform
- (reg_fx, _format_x, code_fx) <- getFloatReg arg_reg
- let dst = getRegisterReg platform (CmmLocal dest_reg)
- let code = code_fx `appOL` op (OpReg w dst) (OpReg w reg_fx)
- pure code
-
data BlockInRange = InRange | NotInRange BlockId
genCondFarJump :: (MonadGetUnique m) => Cond -> Operand -> Operand -> BlockId -> m InstrBlock
=====================================
docs/users_guide/conf.py
=====================================
@@ -45,7 +45,7 @@ rst_prolog = """
# General information about the project.
project = u'Glasgow Haskell Compiler'
-copyright = f"{datetime.now(timezone.utc).year}, GHC Team"
+copyright = "{}, GHC Team".format(datetime.now(timezone.utc).year)
# N.B. version comes from ghc_config
release = version # The full version, including alpha/beta/rc tags.
=====================================
hadrian/src/Builder.hs
=====================================
@@ -361,6 +361,12 @@ instance H.Builder Builder where
Haddock BuildPackage -> runHaddock path buildArgs buildInputs
+ Ghc FindHsDependencies _ -> do
+ -- Use a response file for ghc -M invocations, to
+ -- avoid issues with command line size limit on
+ -- Windows (#26637)
+ runGhcWithResponse path buildArgs buildInputs
+
HsCpp -> captureStdout
Make dir -> cmd' buildOptions path ["-C", dir] buildArgs
@@ -403,6 +409,17 @@ runHaddock haddockPath flagArgs fileInputs = withTempFile $ \tmp -> do
writeFile' tmp $ escapeArgs fileInputs
cmd [haddockPath] flagArgs ('@' : tmp)
+runGhcWithResponse :: FilePath -> [String] -> [FilePath] -> Action ()
+runGhcWithResponse ghcPath flagArgs fileInputs = withTempFile $ \tmp -> do
+
+ writeFile' tmp $ escapeArgs fileInputs
+
+ -- We can't put the flags in a response file, because some flags
+ -- require empty arguments (such as the -dep-suffix flag), but
+ -- that isn't supported yet due to #26560.
+ cmd [ghcPath] flagArgs ('@' : tmp)
+
+
-- TODO: Some builders are required only on certain platforms. For example,
-- 'Objdump' is only required on OpenBSD and AIX. Add support for platform
-- specific optional builders as soon as we can reliably test this feature.
=====================================
hadrian/src/Rules/ToolArgs.hs
=====================================
@@ -172,6 +172,7 @@ toolTargets = [ cabalSyntax
, time
, semaphoreCompat
, unlit -- # executable
+ , xhtml
] ++ if windowsHost then [ win32 ] else [ unix ]
-- | Create a mapping from files to which component it belongs to.
=====================================
hadrian/src/Settings/Builders/Ghc.hs
=====================================
@@ -182,7 +182,7 @@ findHsDependencies = builder (Ghc FindHsDependencies) ? do
, arg "-include-pkg-deps"
, arg "-dep-makefile", arg =<< getOutput
, pure $ concat [ ["-dep-suffix", wayPrefix w] | w <- Set.toList ways ]
- , getInputs ]
+ ]
haddockGhcArgs :: Args
haddockGhcArgs = mconcat [ commonGhcArgs
=====================================
hadrian/src/Settings/Default.hs
=====================================
@@ -109,6 +109,7 @@ stage0Packages = do
, thLift -- new library not yet present for boot compilers
, thQuasiquoter -- new library not yet present for boot compilers
, unlit
+ , xhtml -- new version is not backwards compat with latest
, if windowsHost then win32 else unix
-- We must use the in-tree `Win32` as the version
-- bundled with GHC 9.6 is too old for `semaphore-compat`.
=====================================
libraries/xhtml
=====================================
@@ -1 +1 @@
-Subproject commit 68353ccd1a2e776d6c2b11619265d8140bb7dc07
+Subproject commit cc203b9cc0a60c53a3bcbf2f38eb72cb7cf6098d
=====================================
rts/linker/LoadArchive.c
=====================================
@@ -592,6 +592,9 @@ HsInt loadArchive_ (pathchar *path)
if (!readThinArchiveMember(n, memberSize, path, fileName, image)) {
goto fail;
}
+ // Unlike for regular archives for thin archives we can only identify the object format
+ // after having read the file pointed to.
+ object_fmt = identifyObjectFile_(image, memberSize);
}
else
{
=====================================
utils/haddock/cabal.project
=====================================
@@ -12,4 +12,4 @@ package haddock-api
tests: False
-- Pinning the index-state helps to make reasonably CI deterministic
-index-state: 2024-06-18T11:54:44Z
+index-state: 2025-11-17T03:30:46Z
=====================================
utils/haddock/haddock-api/haddock-api.cabal
=====================================
@@ -51,6 +51,7 @@ common extensions
StrictData
TypeApplications
TypeOperators
+ OverloadedStrings
default-language: Haskell2010
@@ -81,7 +82,7 @@ library
build-depends: base >= 4.16 && < 4.23
, ghc ^>= 9.15
, haddock-library ^>= 1.11
- , xhtml ^>= 3000.2.2
+ , xhtml ^>= 3000.4.0.0
, parsec ^>= 3.1.13.0
-- Versions for the dependencies below are transitively pinned by
@@ -97,6 +98,7 @@ library
, ghc-boot
, mtl
, transformers
+ , text
hs-source-dirs: src
@@ -212,7 +214,7 @@ test-suite spec
build-depends: ghc ^>= 9.7
, ghc-paths ^>= 0.1.0.12
, haddock-library ^>= 1.11
- , xhtml ^>= 3000.2.2
+ , xhtml ^>= 3000.4.0.0
, hspec ^>= 2.9
, parsec ^>= 3.1.13.0
, QuickCheck >= 2.11 && ^>= 2.14
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
=====================================
@@ -134,7 +134,7 @@ out :: Outputable a => SDocContext -> a -> String
out sDocContext = outWith $ Outputable.renderWithContext sDocContext
operator :: String -> String
-operator (x : xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x : xs ++ ")"
+operator (x : xs) | not (isAlphaNum x) && x `notElem` ("_' ([{" :: String) = '(' : x : xs ++ ")"
operator x = x
commaSeparate :: Outputable a => SDocContext -> [a] -> String
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs
=====================================
@@ -28,10 +28,11 @@ import Haddock.Backends.Hyperlinker.Parser
import Haddock.Backends.Hyperlinker.Renderer
import Haddock.Backends.Hyperlinker.Types
import Haddock.Backends.Hyperlinker.Utils
-import Haddock.Backends.Xhtml.Utils (renderToString)
+import Haddock.Backends.Xhtml.Utils (renderToBuilder)
import Haddock.InterfaceFile
import Haddock.Types
-import Haddock.Utils (Verbosity, out, verbose, writeUtf8File)
+import Haddock.Utils (Verbosity, out, verbose)
+import qualified Data.ByteString.Builder as Builder
-- | Generate hyperlinked source for given interfaces.
--
@@ -117,7 +118,7 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do
let tokens = fmap (\tk -> tk{tkSpan = (tkSpan tk){srcSpanFile = srcSpanFile $ nodeSpan fullAst}}) tokens'
-- Produce and write out the hyperlinked sources
- writeUtf8File path . renderToString pretty . render' thisModule fullAst $ tokens
+ Builder.writeFile path . renderToBuilder pretty . render' thisModule fullAst $ tokens
where
dflags = ifaceDynFlags iface
sDocContext = DynFlags.initSDocContext dflags Outputable.defaultUserStyle
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
=====================================
@@ -24,7 +24,9 @@ import qualified Text.XHtml as Html
import Haddock.Backends.Hyperlinker.Types
import Haddock.Backends.Hyperlinker.Utils
-type StyleClass = String
+import qualified Data.Text.Lazy as LText
+
+type StyleClass = LText.Text
-- | Produce the HTML corresponding to a hyperlinked Haskell source
render
@@ -50,7 +52,7 @@ body thisModule srcs ast tokens = Html.body . Html.pre $ hypsrc
header :: Maybe FilePath -> Maybe FilePath -> Html
header Nothing Nothing = Html.noHtml
-header mcss mjs = Html.header $ css mcss <> js mjs
+header mcss mjs = Html.header $ css (LText.pack <$> mcss) <> js (LText.pack <$> mjs)
where
css Nothing = Html.noHtml
css (Just cssFile) =
@@ -225,7 +227,7 @@ tokenStyle TkPragma = ["hs-pragma"]
tokenStyle TkUnknown = []
multiclass :: [StyleClass] -> HtmlAttr
-multiclass = Html.theclass . unwords
+multiclass = Html.theclass . LText.unwords
externalAnchor :: Identifier -> Set.Set ContextInfo -> Html -> Html
externalAnchor (Right name) contexts content
@@ -250,11 +252,11 @@ internalAnchor (Right name) contexts content
Html.thespan content ! [Html.identifier $ internalAnchorIdent name]
internalAnchor _ _ content = content
-externalAnchorIdent :: Name -> String
-externalAnchorIdent = hypSrcNameUrl
+externalAnchorIdent :: Name -> LText.Text
+externalAnchorIdent name = LText.pack (hypSrcNameUrl name)
-internalAnchorIdent :: Name -> String
-internalAnchorIdent = ("l-" ++) . showUnique . nameUnique
+internalAnchorIdent :: Name -> LText.Text
+internalAnchorIdent = LText.pack . ("l-" ++) . showUnique . nameUnique
-- | Generate the HTML hyperlink for an identifier
hyperlink :: Module -> SrcMaps -> Identifier -> Html -> Html
@@ -269,16 +271,16 @@ hyperlink thisModule (srcs, srcs') ident = case ident of
makeHyperlinkUrl url = ".." </> url
internalHyperlink name content =
- Html.anchor content ! [Html.href $ "#" ++ internalAnchorIdent name]
+ Html.anchor content ! [Html.href $ "#" <> internalAnchorIdent name]
externalNameHyperlink name content = case Map.lookup mdl srcs of
Just SrcLocal ->
Html.anchor content
- ! [Html.href $ hypSrcModuleNameUrl' thisModule mdl name]
+ ! [Html.href $ LText.pack (hypSrcModuleNameUrl' thisModule mdl name)]
Just (SrcExternal path) ->
let hyperlinkUrl = hypSrcModuleUrlToNameFormat $ makeHyperlinkUrl path
in Html.anchor content
- ! [Html.href $ spliceURL (Just mdl) (Just name) Nothing hyperlinkUrl]
+ ! [Html.href $ LText.pack $ spliceURL (Just mdl) (Just name) Nothing hyperlinkUrl]
Nothing -> content
where
mdl = nameModule name
@@ -287,11 +289,11 @@ hyperlink thisModule (srcs, srcs') ident = case ident of
case Map.lookup moduleName srcs' of
Just SrcLocal ->
Html.anchor content
- ! [Html.href $ hypSrcModuleUrl' moduleName]
+ ! [Html.href $ LText.pack $ hypSrcModuleUrl' moduleName]
Just (SrcExternal path) ->
let hyperlinkUrl = makeHyperlinkUrl path
in Html.anchor content
- ! [Html.href $ spliceURL' (Just moduleName) Nothing Nothing hyperlinkUrl]
+ ! [Html.href $ LText.pack $ spliceURL' (Just moduleName) Nothing Nothing hyperlinkUrl]
Nothing -> content
renderSpace :: Int -> String -> Html
@@ -307,4 +309,4 @@ renderSpace line space =
in Html.toHtml hspace <> renderSpace line rest
lineAnchor :: Int -> Html
-lineAnchor line = Html.thespan Html.noHtml ! [Html.identifier $ hypSrcLineUrl line]
+lineAnchor line = Html.thespan Html.noHtml ! [Html.identifier $ LText.pack $ hypSrcLineUrl line]
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs
=====================================
@@ -51,6 +51,10 @@ import qualified System.IO as IO
import Text.XHtml hiding (name, p, quote, title)
import qualified Text.XHtml as XHtml
import Prelude hiding (div)
+import qualified Data.Text.Lazy as LText
+import qualified Data.Text.Encoding as Text
+import qualified Data.Text as Text
+import qualified Data.ByteString.Lazy as LBS
import Haddock.Backends.Xhtml.Decl
import Haddock.Backends.Xhtml.DocMarkup
@@ -221,7 +225,7 @@ copyHtmlBits odir libdir themes withQuickjump = do
headHtml :: String -> Themes -> Maybe String -> Maybe String -> Html
headHtml docTitle themes mathjax_url base_url =
header
- ! (maybe [] (\url -> [identifier "head", strAttr "data-base-url" url]) base_url)
+ ! (maybe [] (\url -> [identifier "head", strAttr "data-base-url" url]) (LText.pack <$> base_url))
<< [ meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"]
, meta ! [XHtml.name "viewport", content "width=device-width, initial-scale=1"]
, thetitle << docTitle
@@ -229,18 +233,18 @@ headHtml docTitle themes mathjax_url base_url =
, thelink
! [ rel "stylesheet"
, thetype "text/css"
- , href (withBaseURL base_url quickJumpCssFile)
+ , href (LText.pack $ withBaseURL base_url quickJumpCssFile)
]
<< noHtml
, thelink ! [rel "stylesheet", thetype "text/css", href fontUrl] << noHtml
, script
- ! [ src (withBaseURL base_url haddockJsFile)
+ ! [ src (LText.pack $ withBaseURL base_url haddockJsFile)
, emptyAttr "async"
, thetype "text/javascript"
]
<< noHtml
, script ! [thetype "text/x-mathjax-config"] << primHtml mjConf
- , script ! [src mjUrl, thetype "text/javascript"] << noHtml
+ , script ! [src (LText.pack mjUrl), thetype "text/javascript"] << noHtml
]
where
fontUrl = "https://fonts.googleapis.com/css?family=PT+Sans:400,400i,700"
@@ -257,31 +261,31 @@ headHtml docTitle themes mathjax_url base_url =
srcButton :: SourceURLs -> Maybe Interface -> Maybe Html
srcButton (Just src_base_url, _, _, _) Nothing =
- Just (anchor ! [href src_base_url] << "Source")
+ Just (anchor ! [href (LText.pack src_base_url)] << ("Source" :: LText))
srcButton (_, Just src_module_url, _, _) (Just iface) =
let url = spliceURL (Just $ ifaceMod iface) Nothing Nothing src_module_url
- in Just (anchor ! [href url] << "Source")
+ in Just (anchor ! [href (LText.pack url)] << ("Source" :: LText))
srcButton _ _ =
Nothing
wikiButton :: WikiURLs -> Maybe Module -> Maybe Html
wikiButton (Just wiki_base_url, _, _) Nothing =
- Just (anchor ! [href wiki_base_url] << "User Comments")
+ Just (anchor ! [href (LText.pack wiki_base_url)] << ("User Comments" :: LText))
wikiButton (_, Just wiki_module_url, _) (Just mdl) =
let url = spliceURL (Just mdl) Nothing Nothing wiki_module_url
- in Just (anchor ! [href url] << "User Comments")
+ in Just (anchor ! [href (LText.pack url)] << ("User Comments" :: LText))
wikiButton _ _ =
Nothing
contentsButton :: Maybe String -> Maybe Html
contentsButton maybe_contents_url =
- Just (anchor ! [href url] << "Contents")
+ Just (anchor ! [href (LText.pack url)] << ("Contents" :: LText))
where
url = fromMaybe contentsHtmlFile maybe_contents_url
indexButton :: Maybe String -> Maybe Html
indexButton maybe_index_url =
- Just (anchor ! [href url] << "Index")
+ Just (anchor ! [href (LText.pack url)] << ("Index" :: LText))
where
url = fromMaybe indexHtmlFile maybe_index_url
@@ -318,8 +322,8 @@ bodyHtml
, divContent << pageContent
, divFooter
<< paragraph
- << ( "Produced by "
- +++ (anchor ! [href projectUrl] << toHtml projectName)
+ << ( ("Produced by " :: LText)
+ +++ (anchor ! [href (LText.pack projectUrl)] << toHtml projectName)
+++ (" version " ++ projectVersion)
)
]
@@ -368,7 +372,7 @@ moduleInfo iface =
xs -> extField $ unordList xs ! [theclass "extension-list"]
| otherwise = []
where
- extField x = return $ th << "Extensions" <-> td << x
+ extField x = return $ th << ("Extensions" :: LText) <-> td << x
dropOpt x = if "Opt_" `isPrefixOf` x then drop 4 x else x
in
case entries of
@@ -454,7 +458,7 @@ ppHtmlContents
, ppModuleTrees pkg qual trees
]
createDirectoryIfMissing True odir
- writeUtf8File (joinPath [odir, contentsHtmlFile]) (renderToString debug html)
+ Builder.writeFile (joinPath [odir, contentsHtmlFile]) (renderToBuilder debug html)
where
-- Extract a module's short description.
toInstalledDescription :: InstalledInterface -> Maybe (MDoc Name)
@@ -472,11 +476,11 @@ ppPrologue pkg qual title (Just doc) =
ppSignatureTrees :: Maybe Package -> Qualification -> [(PackageInfo, [ModuleTree])] -> Html
ppSignatureTrees _ _ tss | all (null . snd) tss = mempty
ppSignatureTrees pkg qual [(info, ts)] =
- divPackageList << (sectionName << "Signatures" +++ ppSignatureTree pkg qual "n" info ts)
+ divPackageList << (sectionName << ("Signatures" :: LText) +++ ppSignatureTree pkg qual "n" info ts)
ppSignatureTrees pkg qual tss =
divModuleList
<< ( sectionName
- << "Signatures"
+ << ("Signatures" :: LText)
+++ concatHtml
[ ppSignatureTree pkg qual ("n." ++ show i ++ ".") info ts
| (i, (info, ts)) <- zip [(1 :: Int) ..] tss
@@ -491,11 +495,11 @@ ppSignatureTree pkg qual p info ts =
ppModuleTrees :: Maybe Package -> Qualification -> [(PackageInfo, [ModuleTree])] -> Html
ppModuleTrees _ _ tss | all (null . snd) tss = mempty
ppModuleTrees pkg qual [(info, ts)] =
- divModuleList << (sectionName << "Modules" +++ ppModuleTree pkg qual "n" info ts)
+ divModuleList << (sectionName << ("Modules" :: LText) +++ ppModuleTree pkg qual "n" info ts)
ppModuleTrees pkg qual tss =
divPackageList
<< ( sectionName
- << "Packages"
+ << ("Packages" :: LText)
+++ concatHtml
[ ppModuleTree pkg qual ("n." ++ show i ++ ".") info ts
| (i, (info, ts)) <- zip [(1 :: Int) ..] tss
@@ -519,11 +523,11 @@ mkNode pkg qual ss p (Node s leaf _pkg srcPkg short ts) =
htmlModule <+> shortDescr +++ htmlPkg +++ subtree
where
modAttrs = case (ts, leaf) of
- (_ : _, Nothing) -> collapseControl p "module"
+ (_ : _, Nothing) -> collapseControl (LText.pack p) "module"
(_, _) -> [theclass "module"]
cBtn = case (ts, leaf) of
- (_ : _, Just _) -> thespan ! collapseControl p "" << spaceHtml
+ (_ : _, Just _) -> thespan ! collapseControl (LText.pack p) "" << spaceHtml
([], Just _) -> thespan ! [theclass "noexpander"] << spaceHtml
(_, _) -> noHtml
-- We only need an explicit collapser button when the module name
@@ -547,11 +551,11 @@ mkNode pkg qual ss p (Node s leaf _pkg srcPkg short ts) =
then noHtml
else
collapseDetails
- p
+ (LText.pack p)
DetailsOpen
( thesummary
! [theclass "hide-when-js-enabled"]
- << "Submodules"
+ << ("Submodules" :: LText)
+++ mkNodeList pkg qual (s : ss) p ts
)
@@ -650,10 +654,10 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces ins
| Just item_html <- processExport True links_info unicode pkg qual item =
Just
JsonIndexEntry
- { jieHtmlFragment = showHtmlFragment item_html
+ { jieHtmlFragment = Text.unpack (Text.decodeUtf8Lenient (LBS.toStrict (Builder.toLazyByteString (showHtmlFragment item_html))))
, jieName = unwords (map getOccString names)
, jieModule = moduleString mdl
- , jieLink = fromMaybe "" (listToMaybe (map (nameLink mdl) names))
+ , jieLink = LText.unpack $ fromMaybe "" (listToMaybe (map (nameLink mdl) names))
}
| otherwise = Nothing
where
@@ -668,7 +672,7 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces ins
exportName ExportNoDecl{expItemName} = [expItemName]
exportName _ = []
- nameLink :: NamedThing name => Module -> name -> String
+ nameLink :: NamedThing name => Module -> name -> LText
nameLink mdl = moduleNameUrl' (moduleName mdl) . nameOccName . getName
links_info = (maybe_source_url, maybe_wiki_url)
@@ -720,9 +724,9 @@ ppHtmlIndex
mapM_ (do_sub_index index) initialChars
-- Let's add a single large index as well for those who don't know exactly what they're looking for:
let mergedhtml = indexPage False Nothing index
- writeUtf8File (joinPath [odir, subIndexHtmlFile merged_name]) (renderToString debug mergedhtml)
+ Builder.writeFile (joinPath [odir, subIndexHtmlFile merged_name]) (renderToBuilder debug mergedhtml)
- writeUtf8File (joinPath [odir, indexHtmlFile]) (renderToString debug html)
+ Builder.writeFile (joinPath [odir, indexHtmlFile]) (renderToBuilder debug html)
where
indexPage showLetters ch items =
headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url Nothing
@@ -754,7 +758,7 @@ ppHtmlIndex
indexInitialLetterLinks =
divAlphabet
<< unordList
- ( map (\str -> anchor ! [href (subIndexHtmlFile str)] << str) $
+ ( map (\str -> anchor ! [href (LText.pack $ subIndexHtmlFile str)] << str) $
[ [c] | c <- initialChars, any (indexStartsWith c) index
]
++ [merged_name]
@@ -773,7 +777,7 @@ ppHtmlIndex
do_sub_index this_ix c =
unless (null index_part) $
- writeUtf8File (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html)
+ Builder.writeFile (joinPath [odir, subIndexHtmlFile [c]]) (renderToBuilder debug html)
where
html = indexPage True (Just c) index_part
index_part = [(n, stuff) | (n@(headN : _), stuff) <- this_ix, toUpper headN == c]
@@ -844,9 +848,9 @@ ppHtmlIndex
<-> indexLinks nm entries
ppAnnot n
- | not (isValOcc n) = toHtml "Type/Class"
- | isDataOcc n = toHtml "Data Constructor"
- | otherwise = toHtml "Function"
+ | not (isValOcc n) = toHtml ("Type/Class" :: LText)
+ | isDataOcc n = toHtml ("Data Constructor" :: LText)
+ | otherwise = toHtml ("Function" :: LText)
indexLinks nm entries =
td
@@ -909,10 +913,10 @@ ppHtmlModule
mdl_str_linked
| ifaceIsSig iface =
mdl_str
- +++ " (signature"
+ +++ (" (signature" :: LText)
+++ sup
- << ("[" +++ anchor ! [href signatureDocURL] << "?" +++ "]")
- +++ ")"
+ << (("[" :: LText) +++ anchor ! [href (LText.pack signatureDocURL)] << ("?" :: LText) +++ ("]" :: LText))
+ +++ (")" :: LText)
| otherwise =
toHtml mdl_str
real_qual = makeModuleQual qual mdl
@@ -930,7 +934,7 @@ ppHtmlModule
]
createDirectoryIfMissing True odir
- writeUtf8File (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html)
+ Builder.writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToBuilder debug html)
signatureDocURL :: String
signatureDocURL = "https://wiki.haskell.org/Module_signature"
@@ -965,7 +969,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg qual =
description
| isNoHtml doc = doc
- | otherwise = divDescription $ sectionName << "Description" +++ doc
+ | otherwise = divDescription $ sectionName << ("Description" :: LText) +++ doc
where
doc = docSection Nothing pkg qual (ifaceRnDoc iface)
@@ -978,7 +982,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg qual =
"syn"
DetailsClosed
( thesummary
- << "Synopsis"
+ << ("Synopsis" :: LText)
+++ shortDeclList
( mapMaybe (processExport True linksInfo unicode pkg qual) exports
)
@@ -991,7 +995,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg qual =
case exports of
[] -> noHtml
ExportGroup{} : _ -> noHtml
- _ -> h1 << "Documentation"
+ _ -> h1 << ("Documentation" :: LText)
bdy =
foldr (+++) noHtml $
@@ -1017,7 +1021,7 @@ ppModuleContents pkg qual exports orphan
contentsDiv =
divTableOfContents
<< ( divContentsList
- << ( (sectionName << "Contents")
+ << ( (sectionName << ("Contents" :: LText))
! [strAttr "onclick" "window.scrollTo(0,0)"]
+++ unordList (sections ++ orphanSection)
)
@@ -1025,7 +1029,7 @@ ppModuleContents pkg qual exports orphan
(sections, _leftovers {-should be []-}) = process 0 exports
orphanSection
- | orphan = [linkedAnchor "section.orphans" << "Orphan instances"]
+ | orphan = [linkedAnchor "section.orphans" << ("Orphan instances" :: LText)]
| otherwise = []
process :: Int -> [ExportItem DocNameI] -> ([Html], [ExportItem DocNameI])
@@ -1035,7 +1039,7 @@ ppModuleContents pkg qual exports orphan
| otherwise = (html : secs, rest2)
where
html =
- linkedAnchor (groupId id0)
+ linkedAnchor (groupId (LText.pack id0))
<< docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc)
+++ mk_subsections ssecs
(ssecs, rest1) = process lev rest
@@ -1103,7 +1107,7 @@ processExport
) =
processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode pkg qual
processExport summary _ _ pkg qual (ExportGroup lev id0 doc) =
- nothingIf summary $ groupHeading lev id0 << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc)
+ nothingIf summary $ groupHeading lev (LText.pack id0) << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc)
processExport summary _ _ _ qual (ExportNoDecl y []) =
processDeclOneLiner summary $ ppDocName qual Prefix True y
processExport summary _ _ _ qual (ExportNoDecl y subs) =
@@ -1113,7 +1117,7 @@ processExport summary _ _ _ qual (ExportNoDecl y subs) =
processExport summary _ _ pkg qual (ExportDoc doc) =
nothingIf summary $ docSection_ Nothing pkg qual doc
processExport summary _ _ _ _ (ExportModule mdl) =
- processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl
+ processDeclOneLiner summary $ toHtml ("module" :: LText) <+> ppModule mdl
nothingIf :: Bool -> a -> Maybe a
nothingIf True _ = Nothing
@@ -1132,7 +1136,7 @@ processDeclOneLiner :: Bool -> Html -> Maybe Html
processDeclOneLiner True = Just
processDeclOneLiner False = Just . divTopDecl . declElem
-groupHeading :: Int -> String -> Html -> Html
+groupHeading :: Int -> LText -> Html -> Html
groupHeading lev id0 = linkedAnchor grpId . groupTag lev ! [identifier grpId]
where
grpId = groupId id0
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
=====================================
@@ -45,6 +45,7 @@ import Haddock.Backends.Xhtml.Utils
import Haddock.Doc (combineDocumentation)
import Haddock.GhcUtils
import Haddock.Types
+import qualified Data.Text.Lazy as LText
-- | Pretty print a declaration
ppDecl
@@ -352,9 +353,9 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_sig_args 0 sep
-- We need 'gadtComma' and 'gadtEnd' to line up with the `{` from
-- 'gadtOpen', so we add 3 spaces to cover for `-> `/`:: ` (3 in unicode
-- mode since `->` and `::` are rendered as single characters.
- gadtComma = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml ","
- gadtEnd = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml "}"
- gadtOpen = toHtml "{"
+ gadtComma = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml ("," :: LText)
+ gadtEnd = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml ("}" :: LText)
+ gadtOpen = toHtml ("{" :: LText)
ppFixities :: [(DocName, Fixity)] -> Qualification -> Html
ppFixities [] _ = noHtml
@@ -365,7 +366,7 @@ ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge
! [theclass "fixity"]
<< (toHtml d <+> toHtml (show p) <+> ppNames ns)
- ppDir InfixR = "infixr"
+ ppDir InfixR = ("infixr" :: LText)
ppDir InfixL = "infixl"
ppDir InfixN = "infix"
@@ -730,7 +731,7 @@ ppContextNoLocsMaybe :: [HsType DocNameI] -> Unicode -> Qualification -> HideEmp
ppContextNoLocsMaybe [] _ _ emptyCtxts =
case emptyCtxts of
HideEmptyContexts -> Nothing
- ShowEmptyToplevelContexts -> Just (toHtml "()")
+ ShowEmptyToplevelContexts -> Just (toHtml ("()" :: LText))
ppContextNoLocsMaybe cxt unicode qual _ = Just $ ppHsContext cxt unicode qual
ppContext :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
@@ -1006,13 +1007,13 @@ ppClassDecl
== [getName n' | ClassOpSig _ _ ns _ <- sigs, L _ n' <- ns] ->
noHtml
-- Minimal complete definition = nothing
- And [] : _ -> subMinimal $ toHtml "Nothing"
+ And [] : _ -> subMinimal $ toHtml ("Nothing" :: LText)
m : _ -> subMinimal $ ppMinimal False m
_ -> noHtml
ppMinimal _ (Var (L _ n)) = ppDocName qual Prefix True n
- ppMinimal _ (And fs) = foldr1 (\a b -> a +++ ", " +++ b) $ map (ppMinimal True . unLoc) fs
- ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a +++ " | " +++ b) $ map (ppMinimal False . unLoc) fs
+ ppMinimal _ (And fs) = foldr1 (\a b -> a +++ (", " :: LText) +++ b) $ map (ppMinimal True . unLoc) fs
+ ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a +++ (" | " :: LText) +++ b) $ map (ppMinimal False . unLoc) fs
where
wrap | p = parens | otherwise = id
ppMinimal p (Parens x) = ppMinimal p (unLoc x)
@@ -1115,7 +1116,7 @@ ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead{..}) md
pdecl = pdata <+> ppShortDataDecl False True dd [] unicode qual
DataInst {} -> error "ppInstHead"
where
- mname = maybe noHtml (\m -> toHtml "Defined in" <+> ppModule m) mdl
+ mname = maybe noHtml (\m -> toHtml ("Defined in" :: LText) <+> ppModule m) mdl
iid = instanceId origin no orphan ihd
typ = ppAppNameTypes ihdClsName ihdTypes unicode qual
@@ -1163,9 +1164,9 @@ ppInstanceSigs links splice unicode qual sigs = do
lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
lookupAnySubdoc n = Maybe.fromMaybe noDocForDecl . lookup n
-instanceId :: InstOrigin DocName -> Int -> Bool -> InstHead DocNameI -> String
+instanceId :: InstOrigin DocName -> Int -> Bool -> InstHead DocNameI -> LText
instanceId origin no orphan ihd =
- concat $
+ LText.pack $ concat $
["o:" | orphan]
++ [ qual origin
, ":" ++ getOccString origin
@@ -1529,7 +1530,7 @@ ppConstrHdr forall_ tvs ctxt unicode qual = ppForall +++ ppCtxt
| otherwise =
ppContextNoArrow ctxt unicode qual HideEmptyContexts
<+> darrow unicode
- +++ toHtml " "
+ +++ toHtml (" " :: LText)
-- | Pretty-print a record field
ppSideBySideField
@@ -1564,7 +1565,7 @@ ppSideBySideField subdocs unicode qual (HsConDeclRecField _ names ltype) =
ppRecFieldMultAnn :: Unicode -> Qualification -> HsConDeclField DocNameI -> Html
ppRecFieldMultAnn unicode qual (CDF { cdf_multiplicity = ann }) = case ann of
HsUnannotated _ -> noHtml
- HsLinearAnn _ -> toHtml "%1"
+ HsLinearAnn _ -> toHtml ("%1" :: LText)
HsExplicitMult _ mult -> multAnnotation <> ppr_mono_lty mult unicode qual HideEmptyContexts
ppShortField :: Bool -> Unicode -> Qualification -> HsConDeclRecField DocNameI -> Html
@@ -1668,8 +1669,8 @@ ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument"
--------------------------------------------------------------------------------
ppBang :: HsSrcBang -> Html
-ppBang (HsSrcBang _ _ SrcStrict) = toHtml "!"
-ppBang (HsSrcBang _ _ SrcLazy) = toHtml "~"
+ppBang (HsSrcBang _ _ SrcStrict) = toHtml ("!" :: LText)
+ppBang (HsSrcBang _ _ SrcLazy) = toHtml ("~" :: LText)
ppBang _ = noHtml
tupleParens :: HsTupleSort -> [Html] -> Html
@@ -1707,7 +1708,7 @@ ppSigType unicode qual emptyCtxts sig_ty = ppr_sig_ty (reparenSigType sig_ty) un
ppLHsTypeArg :: Unicode -> Qualification -> HideEmptyContexts -> LHsTypeArg DocNameI -> Html
ppLHsTypeArg unicode qual emptyCtxts (HsValArg _ ty) = ppLParendType unicode qual emptyCtxts ty
ppLHsTypeArg unicode qual emptyCtxts (HsTypeArg _ ki) = atSign <> ppLParendType unicode qual emptyCtxts ki
-ppLHsTypeArg _ _ _ (HsArgPar _) = toHtml ""
+ppLHsTypeArg _ _ _ (HsArgPar _) = toHtml ("" :: LText)
class RenderableBndrFlag flag where
ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr flag DocNameI -> Html
@@ -1814,12 +1815,12 @@ ppr_mono_ty (HsQualTy _ ctxt ty) unicode qual emptyCtxts =
ppLContext (Just ctxt) unicode qual emptyCtxts <+> ppr_mono_lty ty unicode qual emptyCtxts
-- UnicodeSyntax alternatives
ppr_mono_ty (HsTyVar _ _ (L _ name)) True _ _
- | getOccString (getName name) == "(->)" = toHtml "(→)"
+ | getOccString (getName name) == "(->)" = toHtml ("(→)" :: LText)
ppr_mono_ty (HsTyVar _ prom (L _ name)) _ q _
| isPromoted prom = promoQuote (ppDocName q Prefix True name)
| otherwise = ppDocName q Prefix True name
ppr_mono_ty (HsStarTy _ isUni) u _ _ =
- toHtml (if u || isUni then "★" else "*")
+ toHtml (if u || isUni then "★" else "*" :: LText)
ppr_mono_ty (HsFunTy _ mult ty1 ty2) u q e =
hsep
[ ppr_mono_lty ty1 u q HideEmptyContexts
@@ -1842,7 +1843,7 @@ ppr_mono_ty (HsIParamTy _ (L _ n) ty) u q _ =
ppr_mono_ty (HsSpliceTy v _) _ _ _ = dataConCantHappen v
ppr_mono_ty (XHsType (HsBangTy b ty)) u q _ =
ppBang b +++ ppLParendType u q HideEmptyContexts ty
-ppr_mono_ty (XHsType (HsRecTy{})) _ _ _ = toHtml "{..}"
+ppr_mono_ty (XHsType (HsRecTy{})) _ _ _ = toHtml ("{..}" :: LText)
-- Can now legally occur in ConDeclGADT, the output here is to provide a
-- placeholder in the signature, which is followed by the field
-- declarations.
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
=====================================
@@ -39,6 +39,7 @@ import Haddock.Doc
)
import Haddock.Types
import Haddock.Utils
+import qualified Data.Text.Lazy as LText
parHtmlMarkup
:: Qualification
@@ -60,7 +61,7 @@ parHtmlMarkup qual insertAnchors ppId =
mdl' = case reverse mdl of
'\\' : _ -> init mdl
_ -> mdl
- in ppModuleRef lbl (mkModuleName mdl') ref
+ in ppModuleRef lbl (mkModuleName mdl') (LText.pack ref)
, markupWarning = thediv ! [theclass "warning"]
, markupEmphasis = emphasize
, markupBold = strong
@@ -73,14 +74,14 @@ parHtmlMarkup qual insertAnchors ppId =
if insertAnchors
then
anchor
- ! [href url]
+ ! [href (LText.pack url)]
<< fromMaybe (toHtml url) mLabel
else fromMaybe (toHtml url) mLabel
, markupAName = \aname ->
if insertAnchors
- then namedAnchor aname << ""
+ then namedAnchor (LText.pack aname) << ("" :: LText.Text)
else noHtml
- , markupPic = \(Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t))
+ , markupPic = \(Picture uri t) -> image ! ([src (LText.pack uri)] ++ fromMaybe [] (return . title <$> (LText.pack <$> t)))
, markupMathInline = \mathjax -> thespan ! [theclass "mathjax"] << toHtml ("\\(" ++ mathjax ++ "\\)")
, markupMathDisplay = \mathjax -> thespan ! [theclass "mathjax"] << toHtml ("\\[" ++ mathjax ++ "\\]")
, markupProperty = pre . toHtml
@@ -121,7 +122,7 @@ parHtmlMarkup qual insertAnchors ppId =
exampleToHtml (Example expression result) = htmlExample
where
htmlExample = htmlPrompt +++ htmlExpression +++ toHtml (unlines result)
- htmlPrompt = (thecode . toHtml $ ">>> ") ! [theclass "prompt"]
+ htmlPrompt = (thecode . toHtml $ (">>> " :: LText.Text)) ! [theclass "prompt"]
htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"]
makeOrdList :: HTML a => [(Int, a)] -> Html
@@ -204,9 +205,9 @@ hackMarkup fmt' currPkg h' =
hackMarkup' fmt h = case h of
UntouchedDoc d -> (markup fmt $ _doc d, [_meta d])
CollapsingHeader (Header lvl titl) par n nm ->
- let id_ = makeAnchorId $ "ch:" ++ fromMaybe "noid:" nm ++ show n
+ let id_ = makeAnchorId $ "ch:" <> fromMaybe "noid:" (LText.pack <$> nm) <> LText.pack (show n)
col' = collapseControl id_ "subheading"
- summary = thesummary ! [theclass "hide-when-js-enabled"] << "Expand"
+ summary = thesummary ! [theclass "hide-when-js-enabled"] << ("Expand" :: LText.Text)
instTable contents = collapseDetails id_ DetailsClosed (summary +++ contents)
lvs = zip [1 ..] [h1, h2, h3, h4, h5, h6]
getHeader = fromMaybe caption (lookup lvl lvs)
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
=====================================
@@ -63,6 +63,7 @@ import Haddock.Backends.Xhtml.Types
import Haddock.Backends.Xhtml.Utils
import Haddock.Types
import Haddock.Utils (makeAnchorId, nameAnchorId)
+import qualified Data.Text.Lazy as LText
--------------------------------------------------------------------------------
@@ -73,7 +74,7 @@ import Haddock.Utils (makeAnchorId, nameAnchorId)
miniBody :: Html -> Html
miniBody = body ! [identifier "mini"]
-sectionDiv :: String -> Html -> Html
+sectionDiv :: LText -> Html -> Html
sectionDiv i = thediv ! [identifier i]
sectionName :: Html -> Html
@@ -138,11 +139,11 @@ divTopDecl = thediv ! [theclass "top"]
type SubDecl = (Html, Maybe (MDoc DocName), [Html])
-divSubDecls :: HTML a => String -> a -> Maybe Html -> Html
+divSubDecls :: LText -> LText -> Maybe Html -> Html
divSubDecls cssClass captionName = maybe noHtml wrap
where
wrap = (subSection <<) . (subCaption +++)
- subSection = thediv ! [theclass $ unwords ["subs", cssClass]]
+ subSection = thediv ! [theclass $ LText.unwords ["subs", cssClass]]
subCaption = paragraph ! [theclass "caption"] << captionName
subDlist :: Maybe Package -> Qualification -> [SubDecl] -> Maybe Html
@@ -232,9 +233,9 @@ subInstances pkg qual nm lnks splice = maybe noHtml wrap . instTable
wrap contents = subSection (hdr +++ collapseDetails id_ DetailsOpen (summary +++ contents))
instTable = subTableSrc pkg qual lnks splice
subSection = thediv ! [theclass "subs instances"]
- hdr = h4 ! collapseControl id_ "instances" << "Instances"
- summary = thesummary ! [theclass "hide-when-js-enabled"] << "Instances details"
- id_ = makeAnchorId $ "i:" ++ nm
+ hdr = h4 ! collapseControl id_ "instances" << ("Instances" :: LText)
+ summary = thesummary ! [theclass "hide-when-js-enabled"] << ("Instances details" :: LText)
+ id_ = makeAnchorId $ "i:" <> (LText.pack nm)
subOrphanInstances
:: Maybe Package
@@ -245,12 +246,12 @@ subOrphanInstances
-> Html
subOrphanInstances pkg qual lnks splice = maybe noHtml wrap . instTable
where
- wrap = ((h1 << "Orphan instances") +++)
- instTable = fmap (thediv ! [identifier ("section." ++ id_)] <<) . subTableSrc pkg qual lnks splice
+ wrap = ((h1 << ("Orphan instances" :: LText)) +++)
+ instTable = fmap (thediv ! [identifier ("section." <> id_)] <<) . subTableSrc pkg qual lnks splice
id_ = makeAnchorId "orphans"
subInstHead
- :: String
+ :: LText
-- ^ Instance unique id (for anchor generation)
-> Html
-- ^ Header content (instance name and type)
@@ -261,7 +262,7 @@ subInstHead iid hdr =
expander = thespan ! collapseControl (instAnchorId iid) "instance"
subInstDetails
- :: String
+ :: LText
-- ^ Instance unique id (for anchor generation)
-> [Html]
-- ^ Associated type contents
@@ -274,7 +275,7 @@ subInstDetails iid ats mets mdl =
subInstSection iid << (p mdl <+> subAssociatedTypes ats <+> subMethods mets)
subFamInstDetails
- :: String
+ :: LText
-- ^ Instance unique id (for anchor generation)
-> Html
-- ^ Type or data family instance
@@ -285,16 +286,16 @@ subFamInstDetails iid fi mdl =
subInstSection iid << (p mdl <+> (thediv ! [theclass "src"] << fi))
subInstSection
- :: String
+ :: LText
-- ^ Instance unique id (for anchor generation)
-> Html
-> Html
subInstSection iid contents = collapseDetails (instAnchorId iid) DetailsClosed (summary +++ contents)
where
- summary = thesummary ! [theclass "hide-when-js-enabled"] << "Instance details"
+ summary = thesummary ! [theclass "hide-when-js-enabled"] << ("Instance details" :: LText)
-instAnchorId :: String -> String
-instAnchorId iid = makeAnchorId $ "i:" ++ iid
+instAnchorId :: LText -> LText
+instAnchorId iid = makeAnchorId $ "i:" <> iid
subMethods :: [Html] -> Html
subMethods = divSubDecls "methods" "Methods" . subBlock
@@ -321,7 +322,7 @@ topDeclElem lnks loc splice name html =
-- Name must be documented, otherwise we wouldn't get here.
links :: LinksInfo -> SrcSpan -> Bool -> Maybe Module -> DocName -> Html
links ((_, _, sourceMap, lineMap), (_, _, maybe_wiki_url)) loc splice mdl' docName@(Documented n mdl) =
- srcLink <+> wikiLink <+> (selfLink ! [theclass "selflink"] << "#")
+ srcLink <+> wikiLink <+> (selfLink ! [theclass "selflink"] << ("#" :: LText))
where
selfLink = linkedAnchor (nameAnchorId (nameOccName (getName docName)))
@@ -335,15 +336,15 @@ links ((_, _, sourceMap, lineMap), (_, _, maybe_wiki_url)) loc splice mdl' docNa
in case mUrl of
Nothing -> noHtml
Just url ->
- let url' = spliceURL (Just origMod) (Just n) (Just loc) url
- in anchor ! [href url', theclass "link"] << "Source"
+ let url' = LText.pack $ spliceURL (Just origMod) (Just n) (Just loc) url
+ in anchor ! [href url', theclass "link"] << ("Source" :: LText)
wikiLink =
case maybe_wiki_url of
Nothing -> noHtml
Just url ->
- let url' = spliceURL (Just mdl) (Just n) (Just loc) url
- in anchor ! [href url', theclass "link"] << "Comments"
+ let url' = LText.pack $ spliceURL (Just mdl) (Just n) (Just loc) url
+ in anchor ! [href url', theclass "link"] << ("Comments" :: LText)
-- For source links, we want to point to the original module,
-- because only that will have the source.
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
=====================================
@@ -41,6 +41,7 @@ import Haddock.Backends.Xhtml.Utils
import Haddock.GhcUtils
import Haddock.Types
import Haddock.Utils
+import qualified Data.Text.Lazy as LText
-- | Indicator of how to render a 'DocName' into 'Html'
data Notation
@@ -171,7 +172,7 @@ linkIdOcc mdl mbName insertAnchors =
then anchor ! [href url, title ttl]
else id
where
- ttl = moduleNameString (moduleName mdl)
+ ttl = LText.pack (moduleNameString (moduleName mdl))
url = case mbName of
Nothing -> moduleUrl mdl
Just name -> moduleNameUrl mdl name
@@ -179,9 +180,9 @@ linkIdOcc mdl mbName insertAnchors =
linkIdOcc' :: ModuleName -> Maybe OccName -> Html -> Html
linkIdOcc' mdl mbName = anchor ! [href url, title ttl]
where
- ttl = moduleNameString mdl
+ ttl = LText.pack (moduleNameString mdl)
url = case mbName of
- Nothing -> moduleHtmlFile' mdl
+ Nothing -> LText.pack (moduleHtmlFile' mdl)
Just name -> moduleNameUrl' mdl name
ppModule :: Module -> Html
@@ -190,14 +191,14 @@ ppModule mdl =
! [href (moduleUrl mdl)]
<< toHtml (moduleString mdl)
-ppModuleRef :: Maybe Html -> ModuleName -> String -> Html
+ppModuleRef :: Maybe Html -> ModuleName -> LText -> Html
ppModuleRef Nothing mdl ref =
anchor
- ! [href (moduleHtmlFile' mdl ++ ref)]
+ ! [href (LText.pack (moduleHtmlFile' mdl) <> ref)]
<< toHtml (moduleNameString mdl)
ppModuleRef (Just lbl) mdl ref =
anchor
- ! [href (moduleHtmlFile' mdl ++ ref)]
+ ! [href (LText.pack (moduleHtmlFile' mdl) <> ref)]
<< lbl
-- NB: The ref parameter already includes the '#'.
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs
=====================================
@@ -27,6 +27,7 @@ import System.Directory
import System.FilePath
import Text.XHtml hiding (name, p, quote, title, (</>))
import qualified Text.XHtml as XHtml
+import qualified Data.Text.Lazy as LText
import Haddock.Backends.Xhtml.Types (BaseURL, withBaseURL)
import Haddock.Options
@@ -185,10 +186,10 @@ styleSheet base_url ts = toHtml $ zipWith mkLink rels ts
rels = "stylesheet" : repeat "alternate stylesheet"
mkLink aRel t =
thelink
- ! [ href (withBaseURL base_url (themeHref t))
+ ! [ href (LText.pack (withBaseURL base_url (themeHref t)))
, rel aRel
, thetype "text/css"
- , XHtml.title (themeName t)
+ , XHtml.title (LText.pack (themeName t))
]
<< noHtml
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
=====================================
@@ -13,7 +13,7 @@
-- Stability : experimental
-- Portability : portable
module Haddock.Backends.Xhtml.Utils
- ( renderToString
+ ( renderToBuilder
, namedAnchor
, linkedAnchor
, spliceURL
@@ -58,6 +58,7 @@ import GHC.Types.Name (getOccString, isValOcc, nameOccName)
import GHC.Unit.Module (Module, ModuleName, moduleName, moduleNameString)
import Text.XHtml hiding (name, p, quote, title)
import qualified Text.XHtml as XHtml
+import qualified Data.Text.Lazy as LText
import Haddock.Utils
@@ -118,8 +119,8 @@ spliceURL' maybe_mod maybe_name maybe_loc = run
run ('%' : '{' : 'L' : 'I' : 'N' : 'E' : '}' : rest) = line ++ run rest
run (c : rest) = c : run rest
-renderToString :: Bool -> Html -> String
-renderToString debug html
+renderToBuilder :: Bool -> Html -> Builder
+renderToBuilder debug html
| debug = renderHtml html
| otherwise = showHtml html
@@ -136,7 +137,7 @@ infixr 8 <+>
(<+>) :: Html -> Html -> Html
a <+> b = a +++ sep +++ b
where
- sep = if isNoHtml a || isNoHtml b then noHtml else toHtml " "
+ sep = if isNoHtml a || isNoHtml b then noHtml else toHtml (" " :: LText)
-- | Join two 'Html' values together with a linebreak in between.
-- Has 'noHtml' as left identity.
@@ -167,7 +168,7 @@ promoQuote h = char '\'' +++ h
parens, brackets, pabrackets, braces :: Html -> Html
parens h = char '(' +++ h +++ char ')'
brackets h = char '[' +++ h +++ char ']'
-pabrackets h = toHtml "[:" +++ h +++ toHtml ":]"
+pabrackets h = toHtml ("[:" :: LText) +++ h +++ toHtml (":]" :: LText)
braces h = char '{' +++ h +++ char '}'
punctuate :: Html -> [Html] -> [Html]
@@ -188,37 +189,37 @@ ubxParenList :: [Html] -> Html
ubxParenList = ubxparens . hsep . punctuate comma
ubxSumList :: [Html] -> Html
-ubxSumList = ubxparens . hsep . punctuate (toHtml " | ")
+ubxSumList = ubxparens . hsep . punctuate (toHtml (" | " :: LText))
ubxparens :: Html -> Html
-ubxparens h = toHtml "(#" <+> h <+> toHtml "#)"
+ubxparens h = toHtml ("(#" :: LText) <+> h <+> toHtml ("#)" :: LText)
dcolon, arrow, lollipop, darrow, forallSymbol :: Bool -> Html
-dcolon unicode = toHtml (if unicode then "∷" else "::")
-arrow unicode = toHtml (if unicode then "→" else "->")
-lollipop unicode = toHtml (if unicode then "⊸" else "%1 ->")
-darrow unicode = toHtml (if unicode then "⇒" else "=>")
-forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall"
+dcolon unicode = toHtml (if unicode then "∷" :: LText else "::")
+arrow unicode = toHtml (if unicode then "→" :: LText else "->")
+lollipop unicode = toHtml (if unicode then "⊸" :: LText else "%1 ->")
+darrow unicode = toHtml (if unicode then "⇒" :: LText else "=>")
+forallSymbol unicode = if unicode then toHtml ("∀" :: LText) else keyword "forall"
atSign :: Html
-atSign = toHtml "@"
+atSign = toHtml ("@" :: LText)
multAnnotation :: Html
-multAnnotation = toHtml "%"
+multAnnotation = toHtml ("%" :: LText)
dot :: Html
-dot = toHtml "."
+dot = toHtml ("." :: LText)
-- | Generate a named anchor
-namedAnchor :: String -> Html -> Html
+namedAnchor :: LText -> Html -> Html
namedAnchor n = anchor ! [XHtml.identifier n]
-linkedAnchor :: String -> Html -> Html
-linkedAnchor n = anchor ! [href ('#' : n)]
+linkedAnchor :: LText -> Html -> Html
+linkedAnchor n = anchor ! [href ("#" <> n)]
-- | generate an anchor identifier for a group
-groupId :: String -> String
-groupId g = makeAnchorId ("g:" ++ g)
+groupId :: LText -> LText
+groupId g = makeAnchorId ("g:" <> g)
--
-- A section of HTML which is collapsible.
@@ -226,7 +227,7 @@ groupId g = makeAnchorId ("g:" ++ g)
data DetailsState = DetailsOpen | DetailsClosed
-collapseDetails :: String -> DetailsState -> Html -> Html
+collapseDetails :: LText -> DetailsState -> Html -> Html
collapseDetails id_ state = tag "details" ! (identifier id_ : openAttrs)
where
openAttrs = case state of DetailsOpen -> [emptyAttr "open"]; DetailsClosed -> []
@@ -235,14 +236,14 @@ thesummary :: Html -> Html
thesummary = tag "summary"
-- | Attributes for an area that toggles a collapsed area
-collapseToggle :: String -> String -> [HtmlAttr]
+collapseToggle :: LText -> LText -> [HtmlAttr]
collapseToggle id_ classes = [theclass cs, strAttr "data-details-id" id_]
where
- cs = unwords (words classes ++ ["details-toggle"])
+ cs = LText.unwords (LText.words classes <> ["details-toggle"])
-- | Attributes for an area that toggles a collapsed area,
-- and displays a control.
-collapseControl :: String -> String -> [HtmlAttr]
+collapseControl :: LText -> LText -> [HtmlAttr]
collapseControl id_ classes = collapseToggle id_ cs
where
- cs = unwords (words classes ++ ["details-toggle-control"])
+ cs = LText.unwords (LText.words classes <> ["details-toggle-control"])
=====================================
utils/haddock/haddock-api/src/Haddock/Doc.hs
=====================================
@@ -32,7 +32,7 @@ combineDocumentation (Documentation mDoc mWarning) =
--
docCodeBlock :: DocH mod id -> DocH mod id
docCodeBlock (DocString s) =
- DocString (reverse $ dropWhile (`elem` " \t") $ reverse s)
+ DocString (reverse $ dropWhile (`elem` (" \t" :: String)) $ reverse s)
docCodeBlock (DocAppend l r) =
DocAppend l (docCodeBlock r)
docCodeBlock d = d
=====================================
utils/haddock/haddock-api/src/Haddock/Utils.hs
=====================================
@@ -83,6 +83,8 @@ import System.IO.Unsafe (unsafePerformIO)
import Documentation.Haddock.Doc (emptyMetaDoc)
import Haddock.Types
+import Data.Text.Lazy (Text)
+import qualified Data.Text.Lazy as LText
--------------------------------------------------------------------------------
@@ -184,35 +186,43 @@ subIndexHtmlFile ls = "doc-index-" ++ b ++ ".html"
-- before being matched with IDs in the target document.
-------------------------------------------------------------------------------
-moduleUrl :: Module -> String
-moduleUrl = moduleHtmlFile
+moduleUrl :: Module -> Text
+moduleUrl module_ = LText.pack (moduleHtmlFile module_)
-moduleNameUrl :: Module -> OccName -> String
-moduleNameUrl mdl n = moduleUrl mdl ++ '#' : nameAnchorId n
+moduleNameUrl :: Module -> OccName -> Text
+moduleNameUrl mdl n = moduleUrl mdl <> "#" <> nameAnchorId n
-moduleNameUrl' :: ModuleName -> OccName -> String
-moduleNameUrl' mdl n = moduleHtmlFile' mdl ++ '#' : nameAnchorId n
+moduleNameUrl' :: ModuleName -> OccName -> Text
+moduleNameUrl' mdl n = LText.pack (moduleHtmlFile' mdl) <> "#" <> nameAnchorId n
-nameAnchorId :: OccName -> String
-nameAnchorId name = makeAnchorId (prefix : ':' : occNameString name)
+nameAnchorId :: OccName -> Text
+nameAnchorId name = makeAnchorId (prefix <> ":" <> LText.pack (occNameString name))
where
prefix
- | isValOcc name = 'v'
- | otherwise = 't'
+ | isValOcc name = "v"
+ | otherwise = "t"
-- | Takes an arbitrary string and makes it a valid anchor ID. The mapping is
-- identity preserving.
-makeAnchorId :: String -> String
-makeAnchorId [] = []
-makeAnchorId (f : r) = escape isAlpha f ++ concatMap (escape isLegal) r
+makeAnchorId :: Text -> Text
+makeAnchorId input =
+ case LText.uncons input of
+ Nothing -> LText.empty
+ Just (f, rest) ->
+ escape isAlpha f <> LText.concatMap (escape isLegal) rest
where
+ escape :: (Char -> Bool) -> Char -> Text
escape p c
- | p c = [c]
- | otherwise = '-' : show (ord c) ++ "-"
+ | p c = LText.singleton c
+ | otherwise =
+ -- "-" <> show (ord c) <> "-"
+ LText.cons '-' (LText.pack (show (ord c) <> "-"))
+
+ isLegal :: Char -> Bool
isLegal ':' = True
isLegal '_' = True
isLegal '.' = True
- isLegal c = isAscii c && isAlphaNum c
+ isLegal c = isAscii c && isAlphaNum c
-- NB: '-' is legal in IDs, but we use it as the escape char
@@ -272,7 +282,7 @@ escapeURIString :: (Char -> Bool) -> String -> String
escapeURIString = concatMap . escapeURIChar
isUnreserved :: Char -> Bool
-isUnreserved c = isAlphaNumChar c || (c `elem` "-_.~")
+isUnreserved c = isAlphaNumChar c || (c `elem` ("-_.~" :: String))
isAlphaChar, isDigitChar, isAlphaNumChar :: Char -> Bool
isAlphaChar c = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')
=====================================
utils/haddock/html-test/ref/Bug26.html
=====================================
@@ -53,7 +53,7 @@
>Description</p
><div class="doc"
><p
- >This module tests the ‘@since …’ annotation.</p
+ >This module tests the ‘@since …’ annotation.</p
><p
><em
>Since: 1.2.3</em
=====================================
utils/haddock/html-test/ref/Bug298.html
=====================================
@@ -67,7 +67,7 @@
> :: a -> a -> a</li
><li class="src short"
><a href="#"
- >(⋆^)</a
+ >(⋆^)</a
> :: a -> a -> a</li
><li class="src short"
><a href="#"
@@ -106,7 +106,7 @@
><div class="top"
><p class="src"
><a id="v:-8902--94-" class="def"
- >(⋆^)</a
+ >(⋆^)</a
> :: a -> a -> a <a href="#" class="selflink"
>#</a
></p
@@ -134,7 +134,7 @@
></code
> and <code
><a href="#" title="Bug298"
- >⋆^</a
+ >⋆^</a
></code
>.</p
></div
=====================================
utils/haddock/html-test/ref/Bug458.html
=====================================
@@ -55,7 +55,7 @@
><ul class="details-toggle" data-details-id="syn"
><li class="src short"
><a href="#"
- >(⊆)</a
+ >(⊆)</a
> :: () -> () -> ()</li
></ul
></details
@@ -66,7 +66,7 @@
><div class="top"
><p class="src"
><a id="v:-8838-" class="def"
- >(⊆)</a
+ >(⊆)</a
> :: () -> () -> () <a href="#" class="selflink"
>#</a
></p
@@ -75,7 +75,7 @@
>See the defn of <code class="inline-code"
><code
><a href="#" title="Bug458"
- >⊆</a
+ >⊆</a
></code
></code
>.</p
=====================================
utils/haddock/html-test/ref/Nesting.html
=====================================
@@ -317,7 +317,7 @@ with more of the indented list content.</p
><h3
>Level 3 header</h3
><p
- >with some content…</p
+ >with some content…</p
><ul
><li
>and even more lists inside</li
=====================================
utils/haddock/html-test/ref/TitledPicture.html
=====================================
@@ -105,7 +105,7 @@
><a href="#" title="TitledPicture"
>bar</a
></code
- > with title <img src="un∣∁∘" title="δ∈"
+ > with title <img src="un∣∁∘" title="δ∈"
/></p
></div
></div
=====================================
utils/haddock/html-test/ref/Unicode.html
=====================================
@@ -76,7 +76,7 @@
></p
><div class="doc"
><p
- >γλώσσα</p
+ >γλώσσα</p
></div
></div
></div
=====================================
utils/haddock/html-test/ref/Unicode2.html
=====================================
@@ -55,7 +55,7 @@
><ul class="details-toggle" data-details-id="syn"
><li class="src short"
><a href="#"
- >ü</a
+ >ü</a
> :: ()</li
></ul
></details
@@ -66,36 +66,36 @@
><div class="top"
><p class="src"
><a id="v:-252-" class="def"
- >ü</a
+ >ü</a
> :: () <a href="#" class="selflink"
>#</a
></p
><div class="doc"
><p
- >All of the following work with a unicode character ü:</p
+ >All of the following work with a unicode character ü:</p
><ul
><li
>an italicized <em
- >ü</em
+ >ü</em
></li
><li
>inline code <code class="inline-code"
- >ü</code
+ >ü</code
></li
><li
>a code block:</li
></ul
><pre
- >ü</pre
+ >ü</pre
><ul
><li
>a url <a href="#"
- >https://www.google.com/search?q=ü</a
+ >https://www.google.com/search?q=ü</a
></li
><li
>a link to <code
><a href="#" title="Unicode2"
- >ü</a
+ >ü</a
></code
></li
></ul
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/491937ecbd217d834d7653757cd33c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/491937ecbd217d834d7653757cd33c…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/torsten.schmits/unit-index-debug] 3 commits: Use a name provider map for home packages
by Torsten Schmits (＠torsten.schmits) 06 Dec '25
by Torsten Schmits (＠torsten.schmits) 06 Dec '25
06 Dec '25
Torsten Schmits pushed to branch wip/torsten.schmits/unit-index-debug at Glasgow Haskell Compiler / GHC
Commits:
e35e4d46 by Matthew Pickering at 2025-12-06T12:21:42+01:00
Use a name provider map for home packages
- - - - -
bd870269 by Torsten Schmits at 2025-12-06T12:21:42+01:00
disable home unit closure check
- - - - -
a012026c by Torsten Schmits at 2025-12-06T12:22:14+01:00
WIP: unit index
- - - - -
23 changed files:
- compiler/GHC.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Runtime/Context.hs
- compiler/GHC/Runtime/Loader.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/Name/Ppr.hs
- compiler/GHC/Unit/Env.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Module/Graph.hs
- compiler/GHC/Unit/State.hs
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Monad.hs
- ghc/Main.hs
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -341,7 +341,7 @@ import GHC.Builtin.Types.Prim ( alphaTyVars )
import GHC.Data.StringBuffer
import GHC.Data.FastString
import qualified GHC.LanguageExtensions as LangExt
-import GHC.Rename.Names (renamePkgQual, renameRawPkgQual, gresFromAvails)
+import GHC.Rename.Names (gresFromAvails, hscRenamePkgQual, hscRenameRawPkgQual)
import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
import GHC.Tc.Types
@@ -625,7 +625,8 @@ setUnitDynFlagsNoCheck uid dflags1 = do
let old_hue = ue_findHomeUnitEnv uid (hsc_unit_env hsc_env)
let cached_unit_dbs = homeUnitEnv_unit_dbs old_hue
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs (hsc_all_home_unit_ids hsc_env)
+ index <- hscUnitIndex <$> getSession
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 index cached_unit_dbs (hsc_all_home_unit_ids hsc_env)
updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants
let upd hue =
@@ -760,6 +761,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
then do
-- additionally, set checked dflags so we don't lose fixes
old_unit_env <- ue_setFlags dflags0 . hsc_unit_env <$> getSession
+ ue_index <- hscUnitIndex <$> getSession
home_unit_graph <- forM (ue_home_unit_graph old_unit_env) $ \homeUnitEnv -> do
let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
@@ -767,7 +769,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
old_hpt = homeUnitEnv_hpt homeUnitEnv
home_units = unitEnv_keys (ue_home_unit_graph old_unit_env)
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags ue_index cached_unit_dbs home_units
updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
pure HomeUnitEnv
@@ -785,6 +787,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
, ue_home_unit_graph = home_unit_graph
, ue_current_unit = ue_currentUnit old_unit_env
, ue_eps = ue_eps old_unit_env
+ , ue_index
}
modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env }
else modifySession (hscSetFlags dflags0)
@@ -1379,7 +1382,8 @@ getInsts = withSession $ \hsc_env ->
getNamePprCtx :: GhcMonad m => m NamePprCtx
getNamePprCtx = withSession $ \hsc_env -> do
- return $ icNamePprCtx (hsc_unit_env hsc_env) (hsc_IC hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ return $ icNamePprCtx (hsc_unit_env hsc_env) query (hsc_IC hsc_env)
-- | Container for information about a 'Module'.
data ModuleInfo = ModuleInfo {
@@ -1474,7 +1478,8 @@ mkNamePprCtxForModule ::
ModuleInfo ->
m NamePprCtx
mkNamePprCtxForModule mod minf = withSession $ \hsc_env -> do
- let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (availsToGlobalRdrEnv hsc_env mod (minf_exports minf))
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (availsToGlobalRdrEnv hsc_env mod (minf_exports minf))
ptc = initPromotionTickContext (hsc_dflags hsc_env)
return name_ppr_ctx
@@ -1711,10 +1716,10 @@ modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc d
parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))
renamePkgQualM :: GhcMonad m => ModuleName -> Maybe FastString -> m PkgQual
-renamePkgQualM mn p = withSession $ \hsc_env -> pure (renamePkgQual (hsc_unit_env hsc_env) mn p)
+renamePkgQualM mn p = withSession $ \hsc_env -> hscRenamePkgQual hsc_env mn p
renameRawPkgQualM :: GhcMonad m => ModuleName -> RawPkgQual -> m PkgQual
-renameRawPkgQualM mn p = withSession $ \hsc_env -> pure (renameRawPkgQual (hsc_unit_env hsc_env) mn p)
+renameRawPkgQualM mn p = withSession $ \hsc_env -> hscRenameRawPkgQual hsc_env mn p
-- | Like 'findModule', but differs slightly when the module refers to
-- a source file, and the file has not been loaded via 'load'. In
@@ -1738,7 +1743,8 @@ lookupQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do
let units = hsc_units hsc_env
let dflags = hsc_dflags hsc_env
let fopts = initFinderOpts dflags
- res <- findExposedPackageModule fc fopts units mod_name NoPkgQual
+ query <- hscUnitIndexQuery hsc_env
+ res <- findExposedPackageModule fc fopts units query mod_name NoPkgQual
case res of
Found _ m -> return m
err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err
=====================================
compiler/GHC/Core/Opt/Pipeline.hs
=====================================
@@ -78,6 +78,8 @@ core2core hsc_env guts@(ModGuts { mg_module = mod
, mg_rdr_env = rdr_env })
= do { let builtin_passes = getCoreToDo dflags hpt_rule_base extra_vars
uniq_tag = 's'
+ ; query <- hscUnitIndexQuery hsc_env
+ ; let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env
; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_tag mod
name_ppr_ctx loc $
@@ -100,7 +102,6 @@ core2core hsc_env guts@(ModGuts { mg_module = mod
home_pkg_rules = hptRules hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod
, gwib_isBoot = NotBoot })
hpt_rule_base = mkRuleBase home_pkg_rules
- name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env
ptc = initPromotionTickContext dflags
-- mod: get the module out of the current HscEnv so we can retrieve it from the monad.
-- This is very convienent for the users of the monad (e.g. plugins do not have to
@@ -459,6 +460,7 @@ doCorePass pass guts = do
dflags <- getDynFlags
us <- getUniqueSupplyM
p_fam_env <- getPackageFamInstEnv
+ query <- liftIO $ hscUnitIndexQuery hsc_env
let platform = targetPlatform dflags
let fam_envs = (p_fam_env, mg_fam_inst_env guts)
let updateBinds f = return $ guts { mg_binds = f (mg_binds guts) }
@@ -471,6 +473,7 @@ doCorePass pass guts = do
mkNamePprCtx
(initPromotionTickContext dflags)
(hsc_unit_env hsc_env)
+ query
rdr_env
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -429,6 +429,7 @@ addUnit u = do
logger <- getLogger
let dflags0 = hsc_dflags hsc_env
let old_unit_env = hsc_unit_env hsc_env
+ ue_index = hscUnitIndex hsc_env
newdbs <- case ue_unit_dbs old_unit_env of
Nothing -> panic "addUnit: called too early"
Just dbs ->
@@ -437,7 +438,7 @@ addUnit u = do
, unitDatabaseUnits = [u]
}
in return (dbs ++ [newdb]) -- added at the end because ordering matters
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs) (hsc_all_home_unit_ids hsc_env)
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 ue_index (Just newdbs) (hsc_all_home_unit_ids hsc_env)
-- update platform constants
dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
@@ -452,6 +453,7 @@ addUnit u = do
(homeUnitId home_unit)
(mkHomeUnitEnv dflags (ue_hpt old_unit_env) (Just home_unit))
, ue_eps = ue_eps old_unit_env
+ , ue_index
}
setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env }
@@ -870,6 +872,8 @@ hsModuleToModSummary home_keys pn hsc_src modname
hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+
-- Also copied from 'getImports'
let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps
@@ -882,7 +886,7 @@ hsModuleToModSummary home_keys pn hsc_src modname
implicit_imports = mkPrelImports modname loc
implicit_prelude imps
- rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) modname
+ rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query modname
convImport (L _ i) = (rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i)
extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname
=====================================
compiler/GHC/Driver/Env.hs
=====================================
@@ -7,6 +7,8 @@ module GHC.Driver.Env
, hsc_home_unit
, hsc_home_unit_maybe
, hsc_units
+ , hscUnitIndex
+ , hscUnitIndexQuery
, hsc_HPT
, hsc_HUE
, hsc_HUG
@@ -118,6 +120,13 @@ hsc_home_unit_maybe = ue_homeUnit . hsc_unit_env
hsc_units :: HasDebugCallStack => HscEnv -> UnitState
hsc_units = ue_units . hsc_unit_env
+hscUnitIndex :: HscEnv -> UnitIndex
+hscUnitIndex = ue_index . hsc_unit_env
+
+hscUnitIndexQuery :: HscEnv -> IO UnitIndexQuery
+hscUnitIndexQuery hsc_env =
+ unitIndexQuery (hscActiveUnitId hsc_env) (hscUnitIndex hsc_env)
+
hsc_HPT :: HscEnv -> HomePackageTable
hsc_HPT = ue_hpt . hsc_unit_env
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -2665,9 +2665,10 @@ hscTidy hsc_env guts = do
$! {-# SCC "CoreTidy" #-} tidyProgram opts guts
-- post tidy pretty-printing and linting...
+ query <- hscUnitIndexQuery hsc_env
let tidy_rules = md_rules details
let all_tidy_binds = cg_binds cgguts
- let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (mg_rdr_env guts)
+ let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (mg_rdr_env guts)
ptc = initPromotionTickContext (hsc_dflags hsc_env)
endPassHscEnvIO hsc_env name_ppr_ctx CoreTidy all_tidy_binds tidy_rules
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -148,6 +148,7 @@ import GHC.Utils.Constants
import GHC.Types.Unique.DFM (udfmRestrictKeysSet)
import GHC.Types.Unique
import GHC.Iface.Errors.Types
+import GHC.Unit.State (UnitIndexQuery)
import qualified GHC.Data.Word64Set as W
import GHC.Data.Graph.Directed.Reachability
@@ -190,12 +191,13 @@ depanalE excluded_mods allow_dup_roots = do
if isEmptyMessages errs
then do
hsc_env <- getSession
+ query <- liftIO $ hscUnitIndexQuery hsc_env
let one_unit_messages get_mod_errs k hue = do
errs <- get_mod_errs
unknown_module_err <- warnUnknownModules (hscSetActiveUnitId k hsc_env) (homeUnitEnv_dflags hue) mod_graph
let unused_home_mod_err = warnMissingHomeModules (homeUnitEnv_dflags hue) (hsc_targets hsc_env) mod_graph
- unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) (homeUnitEnv_dflags hue) mod_graph
+ unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) query (homeUnitEnv_dflags hue) mod_graph
return $ errs `unionMessages` unused_home_mod_err
@@ -513,15 +515,15 @@ loadWithCache cache diag_wrapper how_much = do
-- actually loaded packages. All the packages, specified on command line,
-- but never loaded, are probably unused dependencies.
-warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages
-warnUnusedPackages us dflags mod_graph =
+warnUnusedPackages :: UnitState -> UnitIndexQuery -> DynFlags -> ModuleGraph -> DriverMessages
+warnUnusedPackages us query dflags mod_graph =
let diag_opts = initDiagOpts dflags
home_mod_sum = filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph)
-- Only need non-source imports here because SOURCE imports are always HPT
loadedPackages = concat $
- mapMaybe (\(fs, mn) -> lookupModulePackage us (unLoc mn) fs)
+ mapMaybe (\(fs, mn) -> lookupModulePackage us query (unLoc mn) fs)
$ concatMap ms_imps home_mod_sum
any_import_ghc_prim = any ms_ghc_prim_import home_mod_sum
@@ -1603,7 +1605,6 @@ downsweep_imports hsc_env old_summaries old_graph excl_mods allow_dup_roots (roo
checkDuplicates root_map
let done0 = maybe M.empty moduleGraphNodeMap old_graph
(deps, map0) <- loopSummaries rootSummariesOk (done0, root_map)
- let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env)
let unit_env = hsc_unit_env hsc_env
let tmpfs = hsc_tmpfs hsc_env
@@ -1613,7 +1614,7 @@ downsweep_imports hsc_env old_summaries old_graph excl_mods allow_dup_roots (roo
(other_errs, unit_nodes) = partitionEithers $ unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] (hsc_HUG hsc_env)
all_nodes = downsweep_nodes ++ unit_nodes
all_errs = all_root_errs ++ downsweep_errs ++ other_errs
- all_root_errs = closure_errs ++ map snd root_errs
+ all_root_errs = map snd root_errs
-- if we have been passed -fno-code, we enable code generation
-- for dependencies of modules that have -XTemplateHaskell,
@@ -2400,7 +2401,8 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn
let mopts = map unLoc $ snd $ getOptions popts pi_hspp_buf src_fn
pure $ ((, mopts) <$>) $ first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps
- let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query
let rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn))
let pi_srcimps = rn_imps pi_srcimps'
let pi_theimps = rn_imps pi_theimps'
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -692,9 +692,10 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do
-- gather the imports and module name
(hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do
buf <- hGetStringBuffer input_fn
+ query <- hscUnitIndexQuery hsc_env
let imp_prelude = xopt LangExt.ImplicitPrelude dflags
popts = initParserOpts dflags
- rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
+ rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query
rn_imps = fmap (\(rpk, lmn@(L _ mn)) -> (rn_pkg_qual mn rpk, lmn))
eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff)
case eimps of
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -149,7 +149,8 @@ deSugar hsc_env
= do { let dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
ptc = initPromotionTickContext (hsc_dflags hsc_env)
- name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env
+ ; query <- hscUnitIndexQuery hsc_env
+ ; let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env
; withTiming logger
(text "Desugar"<+>brackets (ppr mod))
(const ()) $
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -89,6 +89,7 @@ import GHC.Data.FastString
import GHC.Unit.Env
import GHC.Unit.External
+import GHC.Unit.State (UnitIndexQuery)
import GHC.Unit.Module
import GHC.Unit.Module.ModGuts
@@ -264,7 +265,8 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
++ eps_complete_matches eps -- from imports
-- re-use existing next_wrapper_num to ensure uniqueness
next_wrapper_num_var = tcg_next_wrapper_num tcg_env
- ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env ptc
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+ ; return $ mkDsEnvs unit_env query this_mod rdr_env type_env fam_inst_env ptc
msg_var cc_st_var next_wrapper_num_var complete_matches
}
@@ -292,6 +294,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
; next_wrapper_num <- newIORef emptyModuleEnv
; msg_var <- newIORef emptyMessages
; eps <- liftIO $ hscEPS hsc_env
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
; let unit_env = hsc_unit_env hsc_env
type_env = typeEnvFromEntities ids tycons patsyns fam_insts
ptc = initPromotionTickContext (hsc_dflags hsc_env)
@@ -303,7 +306,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
bindsToIds (Rec binds) = map fst binds
ids = concatMap bindsToIds binds
- envs = mkDsEnvs unit_env this_mod rdr_env type_env
+ envs = mkDsEnvs unit_env query this_mod rdr_env type_env
fam_inst_env ptc msg_var cc_st_var
next_wrapper_num complete_matches
; runDs hsc_env envs thing_inside
@@ -342,12 +345,12 @@ initTcDsForSolver thing_inside
Just ret -> pure ret
Nothing -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLocDefault (getErrorMessages msgs)) }
-mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
+mkDsEnvs :: UnitEnv -> UnitIndexQuery -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> PromotionTickContext
-> IORef (Messages DsMessage) -> IORef CostCentreState
-> IORef (ModuleEnv Int) -> CompleteMatches
-> (DsGblEnv, DsLclEnv)
-mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
+mkDsEnvs unit_env query mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
next_wrapper_num complete_matches
= let if_genv = IfGblEnv { if_doc = text "mkDsEnvs"
-- Failing tests here are `ghci` and `T11985` if you get this wrong.
@@ -364,7 +367,7 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
, ds_fam_inst_env = fam_inst_env
, ds_gbl_rdr_env = rdr_env
, ds_if_env = (if_genv, if_lenv)
- , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env rdr_env
+ , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env query rdr_env
, ds_msgs = msg_var
, ds_complete_matches = complete_matches
, ds_cc_st = cc_st_var
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -588,7 +588,8 @@ checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
checkDependencies hsc_env summary iface
= do
res_normal <- classify_import (findImportedModule hsc_env) (ms_textual_imps summary ++ ms_srcimps summary)
- res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units mhome_unit mod) (ms_plugin_imps summary)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units query mhome_unit mod) (ms_plugin_imps summary)
case sequence (res_normal ++ res_plugin ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of
Left recomp -> return $ NeedsRecompile recomp
Right es -> do
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -27,6 +27,7 @@ module GHC.Rename.Names (
getMinimalImports,
printMinimalImports,
renamePkgQual, renameRawPkgQual,
+ hscRenamePkgQual, hscRenameRawPkgQual,
classifyGREs,
ImportDeclUsage,
) where
@@ -337,7 +338,8 @@ rnImportDecl this_mod
hsc_env <- getTopEnv
unit_env <- hsc_unit_env <$> getTopEnv
- let pkg_qual = renameRawPkgQual unit_env imp_mod_name raw_pkg_qual
+ query <- hscUnitIndexQuery unit_env
+ let pkg_qual = renameRawPkgQual unit_env query imp_mod_name raw_pkg_qual
-- Check for self-import, which confuses the typechecker (#9032)
-- ghc --make rejects self-import cycles already, but batch-mode may not
@@ -447,14 +449,14 @@ rnImportDecl this_mod
-- | Rename raw package imports
-renameRawPkgQual :: UnitEnv -> ModuleName -> RawPkgQual -> PkgQual
-renameRawPkgQual unit_env mn = \case
+renameRawPkgQual :: UnitEnv -> UnitIndexQuery -> ModuleName -> RawPkgQual -> PkgQual
+renameRawPkgQual unit_env query mn = \case
NoRawPkgQual -> NoPkgQual
- RawPkgQual p -> renamePkgQual unit_env mn (Just (sl_fs p))
+ RawPkgQual p -> renamePkgQual unit_env query mn (Just (sl_fs p))
-- | Rename raw package imports
-renamePkgQual :: UnitEnv -> ModuleName -> Maybe FastString -> PkgQual
-renamePkgQual unit_env mn mb_pkg = case mb_pkg of
+renamePkgQual :: UnitEnv -> UnitIndexQuery -> ModuleName -> Maybe FastString -> PkgQual
+renamePkgQual unit_env query mn mb_pkg = case mb_pkg of
Nothing -> NoPkgQual
Just pkg_fs
| Just uid <- homeUnitId <$> ue_homeUnit unit_env
@@ -464,7 +466,7 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of
| Just (uid, _) <- find (fromMaybe False . fmap (== pkg_fs) . snd) home_names
-> ThisPkg uid
- | Just uid <- resolvePackageImport (ue_units unit_env) mn (PackageName pkg_fs)
+ | Just uid <- resolvePackageImport (ue_units unit_env) query mn (PackageName pkg_fs)
-> OtherPkg uid
| otherwise
@@ -482,6 +484,25 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of
hpt_deps :: S.Set UnitId
hpt_deps = homeUnitDepends units
+hscRenameRawPkgQual ::
+ MonadIO m =>
+ HscEnv ->
+ ModuleName ->
+ RawPkgQual ->
+ m PkgQual
+hscRenameRawPkgQual hsc_env name raw = do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ pure (renameRawPkgQual (hsc_unit_env hsc_env) query name raw)
+
+hscRenamePkgQual ::
+ MonadIO m =>
+ HscEnv ->
+ ModuleName ->
+ Maybe FastString ->
+ m PkgQual
+hscRenamePkgQual hsc_env name package = do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ pure (renamePkgQual (hsc_unit_env hsc_env) query name package)
-- | Calculate the 'ImportAvails' induced by an import of a particular
-- interface, but without 'imp_mods'.
=====================================
compiler/GHC/Runtime/Context.hs
=====================================
@@ -26,6 +26,7 @@ import GHC.Runtime.Eval.Types ( IcGlobalRdrEnv(..), Resume )
import GHC.Unit
import GHC.Unit.Env
+import GHC.Unit.State (UnitIndexQuery)
import GHC.Core.FamInstEnv
import GHC.Core.InstEnv
@@ -351,8 +352,8 @@ icInScopeTTs ictxt = filter in_scope_unqualified (ic_tythings ictxt)
]
-- | Get the NamePprCtx function based on the flags and this InteractiveContext
-icNamePprCtx :: UnitEnv -> InteractiveContext -> NamePprCtx
-icNamePprCtx unit_env ictxt = mkNamePprCtx ptc unit_env (icReaderEnv ictxt)
+icNamePprCtx :: UnitEnv -> UnitIndexQuery -> InteractiveContext -> NamePprCtx
+icNamePprCtx unit_env query ictxt = mkNamePprCtx ptc unit_env query (icReaderEnv ictxt)
where ptc = initPromotionTickContext (ic_dflags ictxt)
-- | extendInteractiveContext is called with new TyThings recently defined to update the
=====================================
compiler/GHC/Runtime/Loader.hs
=====================================
@@ -348,7 +348,8 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
let unit_state = ue_units unit_env
let mhome_unit = hsc_home_unit_maybe hsc_env
-- First find the unit the module resides in by searching exposed units and home modules
- found_module <- findPluginModule fc fopts unit_state mhome_unit mod_name
+ query <- hscUnitIndexQuery hsc_env
+ found_module <- findPluginModule fc fopts unit_state query mhome_unit mod_name
case found_module of
Found _ mod -> do
-- Find the exports of the module
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -266,9 +266,11 @@ tcRnModuleTcRnM hsc_env mod_sum
; when (notNull prel_imports) $ do
addDiagnostic TcRnImplicitImportOfPrelude
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+
; -- TODO This is a little skeevy; maybe handle a bit more directly
let { simplifyImport (L _ idecl) =
- ( renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName idecl) (ideclPkgQual idecl)
+ ( renameRawPkgQual (hsc_unit_env hsc_env) query (unLoc $ ideclName idecl) (ideclPkgQual idecl)
, reLoc $ ideclName idecl)
}
; raw_sig_imports <- liftIO
@@ -1996,11 +1998,13 @@ runTcInteractive hsc_env thing_inside
(loadSrcInterface (text "runTcInteractive") m
NotBoot mb_pkg)
+
; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i ->
case i of -- force above: see #15111
IIModule n -> getOrphans n NoPkgQual
- IIDecl i -> getOrphans (unLoc (ideclName i))
- (renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i))
+ IIDecl i -> do
+ qual <- hscRenameRawPkgQual hsc_env (unLoc $ ideclName i) (ideclPkgQual i)
+ getOrphans (unLoc (ideclName i)) qual
; let imports = emptyImportAvails { imp_orphs = orphs }
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -869,7 +869,8 @@ getNamePprCtx
= do { ptc <- initPromotionTickContext <$> getDynFlags
; rdr_env <- getGlobalRdrEnv
; hsc_env <- getTopEnv
- ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env }
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+ ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env }
-- | Like logInfoTcRn, but for user consumption
printForUserTcRn :: SDoc -> TcRn ()
=====================================
compiler/GHC/Types/Name/Ppr.hs
=====================================
@@ -13,6 +13,7 @@ import GHC.Data.FastString
import GHC.Unit
import GHC.Unit.Env
+import GHC.Unit.State (UnitIndexQuery)
import GHC.Types.Name
import GHC.Types.Name.Reader
@@ -68,11 +69,11 @@ with some holes, we should try to give the user some more useful information.
-- | Creates some functions that work out the best ways to format
-- names for the user according to a set of heuristics.
-mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> GlobalRdrEnvX info -> NamePprCtx
-mkNamePprCtx ptc unit_env env
+mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> UnitIndexQuery -> GlobalRdrEnvX info -> NamePprCtx
+mkNamePprCtx ptc unit_env index env
= QueryQualify
(mkQualName env)
- (mkQualModule unit_state home_unit)
+ (mkQualModule unit_state index home_unit)
(mkQualPackage unit_state)
(mkPromTick ptc env)
where
@@ -206,8 +207,8 @@ Side note (int-index):
-- | Creates a function for formatting modules based on two heuristics:
-- (1) if the module is the current module, don't qualify, and (2) if there
-- is only one exposed package which exports this module, don't qualify.
-mkQualModule :: UnitState -> Maybe HomeUnit -> QueryQualifyModule
-mkQualModule unit_state mhome_unit mod
+mkQualModule :: UnitState -> UnitIndexQuery -> Maybe HomeUnit -> QueryQualifyModule
+mkQualModule unit_state index mhome_unit mod
| Just home_unit <- mhome_unit
, isHomeModule home_unit mod = False
@@ -218,7 +219,7 @@ mkQualModule unit_state mhome_unit mod
= False
| otherwise = True
- where lookup = lookupModuleInAllUnits unit_state (moduleName mod)
+ where lookup = lookupModuleInAllUnits unit_state index (moduleName mod)
-- | Creates a function for formatting packages based on two heuristics:
-- (1) don't qualify if the package in question is "main", and (2) only qualify
=====================================
compiler/GHC/Unit/Env.hs
=====================================
@@ -100,6 +100,8 @@ data UnitEnv = UnitEnv
, ue_namever :: !GhcNameVersion
-- ^ GHC name/version (used for dynamic library suffix)
+
+ , ue_index :: !UnitIndex
}
ueEPS :: UnitEnv -> IO ExternalPackageState
@@ -108,12 +110,14 @@ ueEPS = eucEPS . ue_eps
initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv
initUnitEnv cur_unit hug namever platform = do
eps <- initExternalUnitCache
+ ue_index <- newUnitIndex
return $ UnitEnv
{ ue_eps = eps
, ue_home_unit_graph = hug
, ue_current_unit = cur_unit
, ue_platform = platform
, ue_namever = namever
+ , ue_index
}
-- | Get home-unit
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -36,6 +36,7 @@ module GHC.Unit.Finder (
lookupFileCache
) where
+import GHC.Driver.Env (hscUnitIndexQuery, hsc_mod_graph)
import GHC.Prelude
import GHC.Platform.Ways
@@ -69,6 +70,7 @@ import qualified Data.Map as M
import GHC.Driver.Env
( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env) )
import GHC.Driver.Config.Finder
+import GHC.Unit.Module.Graph (mgHomeModuleMap, ModuleNameHomeMap)
import qualified Data.Set as Set
import qualified Data.List.NonEmpty as NE
@@ -162,28 +164,36 @@ findImportedModule hsc_env mod pkg_qual =
dflags = hsc_dflags hsc_env
fopts = initFinderOpts dflags
in do
- findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) mhome_unit mod pkg_qual
+ query <- hscUnitIndexQuery hsc_env
+ let home_module_map = mgHomeModuleMap (hsc_mod_graph hsc_env)
+ findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) query home_module_map mhome_unit mod pkg_qual
findImportedModuleNoHsc
:: FinderCache
-> FinderOpts
-> UnitEnv
+ -> UnitIndexQuery
+ -> ModuleNameHomeMap
-> Maybe HomeUnit
-> ModuleName
-> PkgQual
-> IO FindResult
-findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
+findImportedModuleNoHsc fc fopts ue query home_module_map mhome_unit mod_name mb_pkg =
case mb_pkg of
NoPkgQual -> unqual_import
ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import
- | Just os <- lookup uid other_fopts -> home_pkg_import (uid, os)
+ | Just os <- M.lookup uid other_fopts_map -> home_pkg_import (uid, os)
| otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mhome_unit) $$ ppr uid $$ ppr (map fst all_opts))
OtherPkg _ -> pkg_import
where
+ (complete_units, module_name_map) = home_module_map
+ module_home_units = M.findWithDefault Set.empty mod_name module_name_map
+ current_unit_id = homeUnitId <$> mhome_unit
all_opts = case mhome_unit of
- Nothing -> other_fopts
- Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts
+ Nothing -> other_fopts_list
+ Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts_list
+ other_fopts_map = M.fromList other_fopts_list
home_import = case mhome_unit of
Just home_unit -> findHomeModule fc fopts home_unit mod_name
@@ -194,7 +204,7 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
-- If the module is reexported, then look for it as if it was from the perspective
-- of that package which reexports it.
| mod_name `Set.member` finder_reexportedModules opts =
- findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
+ findImportedModuleNoHsc fc opts ue query home_module_map (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
| mod_name `Set.member` finder_hiddenModules opts =
return (mkHomeHidden uid)
| otherwise =
@@ -203,35 +213,44 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
-- Do not be smart and change this to `foldr orIfNotFound home_import hs` as
-- that is not the same!! home_import is first because we need to look within ourselves
-- first before looking at the packages in order.
- any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts)
+ any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts_list)
- pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg
+ pkg_import = findExposedPackageModule fc fopts units query mod_name mb_pkg
unqual_import = any_home_import
`orIfNotFound`
- findExposedPackageModule fc fopts units mod_name NoPkgQual
+ findExposedPackageModule fc fopts units query mod_name NoPkgQual
units = case mhome_unit of
Nothing -> ue_units ue
Just home_unit -> homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue
hpt_deps :: Set.Set UnitId
hpt_deps = homeUnitDepends units
- other_fopts =
+ dep_providers = Set.intersection module_home_units hpt_deps
+ known_other_uids =
+ let providers = maybe dep_providers (\u -> Set.delete u dep_providers) current_unit_id
+ in Set.toList providers
+ unknown_units =
+ let candidates = Set.difference hpt_deps complete_units
+ excluded = maybe dep_providers (\u -> Set.insert u dep_providers) current_unit_id
+ in Set.toList (Set.difference candidates excluded)
+ other_home_uids = known_other_uids ++ unknown_units
+ other_fopts_list =
[ (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))
- | uid <- Set.toList hpt_deps
+ | uid <- other_home_uids
]
-- | Locate a plugin module requested by the user, for a compiler
-- plugin. This consults the same set of exposed packages as
-- 'findImportedModule', unless @-hide-all-plugin-packages@ or
-- @-plugin-package@ are specified.
-findPluginModule :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult
-findPluginModule fc fopts units (Just home_unit) mod_name =
+findPluginModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> Maybe HomeUnit -> ModuleName -> IO FindResult
+findPluginModule fc fopts units query (Just home_unit) mod_name =
findHomeModule fc fopts home_unit mod_name
`orIfNotFound`
- findExposedPluginPackageModule fc fopts units mod_name
-findPluginModule fc fopts units Nothing mod_name =
- findExposedPluginPackageModule fc fopts units mod_name
+ findExposedPluginPackageModule fc fopts units query mod_name
+findPluginModule fc fopts units query Nothing mod_name =
+ findExposedPluginPackageModule fc fopts units query mod_name
-- | Locate a specific 'Module'. The purpose of this function is to
-- create a 'ModLocation' for a given 'Module', that is to find out
@@ -287,15 +306,15 @@ homeSearchCache fc home_unit mod_name do_this = do
let mod = mkModule home_unit mod_name
modLocationCache fc mod do_this
-findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult
-findExposedPackageModule fc fopts units mod_name mb_pkg =
+findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> ModuleName -> PkgQual -> IO FindResult
+findExposedPackageModule fc fopts units query mod_name mb_pkg =
findLookupResult fc fopts
- $ lookupModuleWithSuggestions units mod_name mb_pkg
+ $ lookupModuleWithSuggestions units query mod_name mb_pkg
-findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> IO FindResult
-findExposedPluginPackageModule fc fopts units mod_name =
+findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> ModuleName -> IO FindResult
+findExposedPluginPackageModule fc fopts units query mod_name =
findLookupResult fc fopts
- $ lookupPluginModuleWithSuggestions units mod_name NoPkgQual
+ $ lookupPluginModuleWithSuggestions units query mod_name NoPkgQual
findLookupResult :: FinderCache -> FinderOpts -> LookupResult -> IO FindResult
findLookupResult fc fopts r = case r of
=====================================
compiler/GHC/Unit/Module/Graph.hs
=====================================
@@ -18,6 +18,7 @@ module GHC.Unit.Module.Graph
, mgModSummaries
, mgModSummaries'
, mgLookupModule
+ , ModuleNameHomeMap
, mgHomeModuleMap
, showModMsg
, moduleGraphNodeModule
@@ -154,14 +155,16 @@ instance Outputable ModNodeKeyWithUid where
-- check that the module and its hs-boot agree.
--
-- The graph is not necessarily stored in topologically-sorted order. Use
+type ModuleNameHomeMap = (Set UnitId, Map.Map ModuleName (Set UnitId))
+
-- 'GHC.topSortModuleGraph' and 'GHC.Data.Graph.Directed.flattenSCC' to achieve this.
data ModuleGraph = ModuleGraph
{ mg_mss :: [ModuleGraphNode]
, mg_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
-- A cached transitive dependency calculation so that a lot of work is not
-- repeated whenever the transitive dependencies need to be calculated (for example, hptInstances)
- , mg_home_map :: Map.Map ModuleName (Set UnitId)
- -- ^ For each module name, which home-unit UnitIds define it.
+ , mg_home_map :: ModuleNameHomeMap
+ -- ^ For each module name, which home-unit UnitIds define it together with the set of units for which the listing is complete.
}
-- | Map a function 'f' over all the 'ModSummaries'.
@@ -190,12 +193,20 @@ unionMG a b =
mkTransDeps :: [ModuleGraphNode] -> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mkTransDeps = first graphReachability {- module graph is acyclic -} . moduleGraphNodes False
-mkHomeModuleMap :: [ModuleGraphNode] -> Map.Map ModuleName (Set UnitId)
+mkHomeModuleMap :: [ModuleGraphNode] -> ModuleNameHomeMap
mkHomeModuleMap nodes =
- Map.fromListWith Set.union
- [ (ms_mod_name ms, Set.singleton (ms_unitid ms))
- | ModuleNode _ ms <- nodes
- ]
+ (complete_units, provider_map)
+ where
+ provider_map =
+ Map.fromListWith Set.union
+ [ (ms_mod_name ms, Set.singleton (ms_unitid ms))
+ | ModuleNode _ ms <- nodes
+ ]
+ complete_units =
+ Set.fromList
+ [ ms_unitid ms
+ | ModuleNode _ ms <- nodes
+ ]
mgModSummaries :: ModuleGraph -> [ModSummary]
mgModSummaries mg = [ m | ModuleNode _ m <- mgModSummaries' mg ]
@@ -215,11 +226,11 @@ mgLookupModule ModuleGraph{..} m = listToMaybe $ mapMaybe go mg_mss
= Just ms
go _ = Nothing
-mgHomeModuleMap :: ModuleGraph -> Map.Map ModuleName (Set UnitId)
+mgHomeModuleMap :: ModuleGraph -> ModuleNameHomeMap
mgHomeModuleMap = mg_home_map
emptyMG :: ModuleGraph
-emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing) Map.empty
+emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing) (Set.empty, Map.empty)
isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool
isTemplateHaskellOrQQNonBoot ms =
=====================================
compiler/GHC/Unit/State.hs
=====================================
@@ -1,6 +1,6 @@
-- (c) The University of Glasgow, 2006
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase, OverloadedRecordDot, RecordWildCards #-}
-- | Unit manipulation
module GHC.Unit.State (
@@ -49,6 +49,15 @@ module GHC.Unit.State (
closeUnitDeps',
mayThrowUnitErr,
+ UnitConfig (..),
+ UnitIndex (..),
+ UnitIndexQuery (..),
+ UnitVisibility (..),
+ VisibilityMap,
+ ModuleNameProvidersMap,
+ newUnitIndex,
+ unitIndexQuery,
+
-- * Module hole substitution
ShHoleSubst,
renameHoleUnit,
@@ -121,6 +130,8 @@ import qualified Data.Semigroup as Semigroup
import qualified Data.Set as Set
import GHC.LanguageExtensions
import Control.Applicative
+import Control.Monad.IO.Class (MonadIO (..))
+import Data.IORef (IORef, newIORef, readIORef)
-- ---------------------------------------------------------------------------
-- The Unit state
@@ -577,10 +588,10 @@ searchPackageId pkgstate pid = filter ((pid ==) . unitPackageId)
-- | Find the UnitId which an import qualified by a package import comes from.
-- Compared to 'lookupPackageName', this function correctly accounts for visibility,
-- renaming and thinning.
-resolvePackageImport :: UnitState -> ModuleName -> PackageName -> Maybe UnitId
-resolvePackageImport unit_st mn pn = do
+resolvePackageImport :: UnitState -> UnitIndexQuery -> ModuleName -> PackageName -> Maybe UnitId
+resolvePackageImport unit_st query mn pn = do
-- 1. Find all modules providing the ModuleName (this accounts for visibility/thinning etc)
- providers <- filterUniqMap originVisible <$> lookupUniqMap (moduleNameProvidersMap unit_st) mn
+ providers <- filterUniqMap originVisible <$> query.findOrigin unit_st mn False
-- 2. Get the UnitIds of the candidates
let candidates_uid = concatMap to_uid $ sortOn fst $ nonDetUniqMapToList providers
-- 3. Get the package names of the candidates
@@ -638,14 +649,14 @@ listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state)
-- 'initUnits' can be called again subsequently after updating the
-- 'packageFlags' field of the 'DynFlags', and it will update the
-- 'unitState' in 'DynFlags'.
-initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
-initUnits logger dflags cached_dbs home_units = do
+initUnits :: Logger -> DynFlags -> UnitIndex -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
+initUnits logger dflags index cached_dbs home_units = do
let forceUnitInfoMap (state, _) = unitInfoMap state `seq` ()
(unit_state,dbs) <- withTiming logger (text "initializing unit database")
forceUnitInfoMap
- $ mkUnitState logger (initUnitConfig dflags cached_dbs home_units)
+ $ mkUnitState logger (homeUnitId_ dflags) (initUnitConfig dflags cached_dbs home_units) index
putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map"
FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})
@@ -1021,7 +1032,7 @@ selectPackages prec_map arg pkgs unusable
= let matches = matching arg
(ps,rest) = partition matches pkgs
in if null ps
- then Left (filter (matches.fst) (nonDetEltsUniqMap unusable))
+ then Left (filter (matches . fst) (nonDetEltsUniqMap unusable))
else Right (sortByPreference prec_map ps, rest)
-- | Rename a 'UnitInfo' according to some module instantiation.
@@ -1484,9 +1495,11 @@ validateDatabase cfg pkg_map1 =
mkUnitState
:: Logger
+ -> UnitId
-> UnitConfig
+ -> UnitIndex
-> IO (UnitState,[UnitDatabase UnitId])
-mkUnitState logger cfg = do
+mkUnitState logger unit cfg index = do
{-
Plan.
@@ -1542,15 +1555,9 @@ mkUnitState logger cfg = do
-- if databases have not been provided, read the database flags
raw_dbs <- case unitConfigDBCache cfg of
- Nothing -> readUnitDatabases logger cfg
+ Nothing -> index.readDatabases logger unit cfg
Just dbs -> return dbs
- -- distrust all units if the flag is set
- let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) }
- dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs
- | otherwise = raw_dbs
-
-
-- This, and the other reverse's that you will see, are due to the fact that
-- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order
-- than they are on the command line.
@@ -1561,159 +1568,7 @@ mkUnitState logger cfg = do
let home_unit_deps = selectHomeUnits (unitConfigHomeUnits cfg) hpt_flags
- -- Merge databases together, without checking validity
- (pkg_map1, prec_map) <- mergeDatabases logger dbs
-
- -- Now that we've merged everything together, prune out unusable
- -- packages.
- let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
-
- reportCycles logger sccs
- reportUnusable logger unusable
-
- -- Apply trust flags (these flags apply regardless of whether
- -- or not packages are visible or not)
- pkgs1 <- mayThrowUnitErr
- $ foldM (applyTrustFlag prec_map unusable)
- (nonDetEltsUniqMap pkg_map2) (reverse (unitConfigFlagsTrusted cfg))
- let prelim_pkg_db = mkUnitInfoMap pkgs1
-
- --
- -- Calculate the initial set of units from package databases, prior to any package flags.
- --
- -- Conceptually, we select the latest versions of all valid (not unusable) *packages*
- -- (not units). This is empty if we have -hide-all-packages.
- --
- -- Then we create an initial visibility map with default visibilities for all
- -- exposed, definite units which belong to the latest valid packages.
- --
- let preferLater unit unit' =
- case compareByPreference prec_map unit unit' of
- GT -> unit
- _ -> unit'
- addIfMorePreferable m unit = addToUDFM_C preferLater m (fsPackageName unit) unit
- -- This is the set of maximally preferable packages. In fact, it is a set of
- -- most preferable *units* keyed by package name, which act as stand-ins in
- -- for "a package in a database". We use units here because we don't have
- -- "a package in a database" as a type currently.
- mostPreferablePackageReps = if unitConfigHideAll cfg
- then emptyUDFM
- else foldl' addIfMorePreferable emptyUDFM pkgs1
- -- When exposing units, we want to consider all of those in the most preferable
- -- packages. We can implement that by looking for units that are equi-preferable
- -- with the most preferable unit for package. Being equi-preferable means that
- -- they must be in the same database, with the same version, and the same package name.
- --
- -- We must take care to consider all these units and not just the most
- -- preferable one, otherwise we can end up with problems like #16228.
- mostPreferable u =
- case lookupUDFM mostPreferablePackageReps (fsPackageName u) of
- Nothing -> False
- Just u' -> compareByPreference prec_map u u' == EQ
- vis_map1 = foldl' (\vm p ->
- -- Note: we NEVER expose indefinite packages by
- -- default, because it's almost assuredly not
- -- what you want (no mix-in linking has occurred).
- if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p
- then addToUniqMap vm (mkUnit p)
- UnitVisibility {
- uv_expose_all = True,
- uv_renamings = [],
- uv_package_name = First (Just (fsPackageName p)),
- uv_requirements = emptyUniqMap,
- uv_explicit = Nothing
- }
- else vm)
- emptyUniqMap pkgs1
-
- --
- -- Compute a visibility map according to the command-line flags (-package,
- -- -hide-package). This needs to know about the unusable packages, since if a
- -- user tries to enable an unusable package, we should let them know.
- --
- vis_map2 <- mayThrowUnitErr
- $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
- (unitConfigHideAll cfg) pkgs1)
- vis_map1 other_flags
-
- --
- -- Sort out which packages are wired in. This has to be done last, since
- -- it modifies the unit ids of wired in packages, but when we process
- -- package arguments we need to key against the old versions.
- --
- (pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2
- let pkg_db = mkUnitInfoMap pkgs2
-
- -- Update the visibility map, so we treat wired packages as visible.
- let vis_map = updateVisibilityMap wired_map vis_map2
-
- let hide_plugin_pkgs = unitConfigHideAllPlugins cfg
- plugin_vis_map <-
- case unitConfigFlagsPlugins cfg of
- -- common case; try to share the old vis_map
- [] | not hide_plugin_pkgs -> return vis_map
- | otherwise -> return emptyUniqMap
- _ -> do let plugin_vis_map1
- | hide_plugin_pkgs = emptyUniqMap
- -- Use the vis_map PRIOR to wired in,
- -- because otherwise applyPackageFlag
- -- won't work.
- | otherwise = vis_map2
- plugin_vis_map2
- <- mayThrowUnitErr
- $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
- hide_plugin_pkgs pkgs1)
- plugin_vis_map1
- (reverse (unitConfigFlagsPlugins cfg))
- -- Updating based on wired in packages is mostly
- -- good hygiene, because it won't matter: no wired in
- -- package has a compiler plugin.
- -- TODO: If a wired in package had a compiler plugin,
- -- and you tried to pick different wired in packages
- -- with the plugin flags and the normal flags... what
- -- would happen? I don't know! But this doesn't seem
- -- likely to actually happen.
- return (updateVisibilityMap wired_map plugin_vis_map2)
-
- let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
- | p <- pkgs2
- ]
- -- The explicitUnits accurately reflects the set of units we have turned
- -- on; as such, it also is the only way one can come up with requirements.
- -- The requirement context is directly based off of this: we simply
- -- look for nested unit IDs that are directly fed holes: the requirements
- -- of those units are precisely the ones we need to track
- let explicit_pkgs = [(k, uv_explicit v) | (k, v) <- nonDetUniqMapToList vis_map]
- req_ctx = mapUniqMap (Set.toList)
- $ plusUniqMapListWith Set.union (map uv_requirements (nonDetEltsUniqMap vis_map))
-
-
- --
- -- Here we build up a set of the packages mentioned in -package
- -- flags on the command line; these are called the "preload"
- -- packages. we link these packages in eagerly. The preload set
- -- should contain at least rts & base, which is why we pretend that
- -- the command line contains -package rts & -package base.
- --
- -- NB: preload IS important even for type-checking, because we
- -- need the correct include path to be set.
- --
- let preload1 = nonDetKeysUniqMap (filterUniqMap (isJust . uv_explicit) vis_map)
-
- -- add default preload units if they can be found in the db
- basicLinkedUnits = fmap (RealUnit . Definite)
- $ filter (flip elemUniqMap pkg_db)
- $ unitConfigAutoLink cfg
- preload3 = ordNub $ (basicLinkedUnits ++ preload1)
-
- -- Close the preload packages with their dependencies
- dep_preload <- mayThrowUnitErr
- $ closeUnitDeps pkg_db
- $ zip (map toUnitId preload3) (repeat Nothing)
-
- let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
- mod_map2 = mkUnusableModuleNameProvidersMap unusable
- mod_map = mod_map2 `plusUniqMap` mod_map1
+ (moduleNameProvidersMap, pluginModuleNameProvidersMap, pkg_db, explicit_pkgs, dep_preload, req_ctx, pkgname_map, wired_map) <- index.update logger unit cfg raw_dbs other_flags
-- Force the result to avoid leaking input parameters
let !state = UnitState
@@ -1722,8 +1577,8 @@ mkUnitState logger cfg = do
, homeUnitDepends = home_unit_deps
, unitInfoMap = pkg_db
, preloadClosure = emptyUniqSet
- , moduleNameProvidersMap = mod_map
- , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
+ , moduleNameProvidersMap
+ , pluginModuleNameProvidersMap
, packageNameMap = pkgname_map
, wireMap = wired_map
, unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ]
@@ -1896,6 +1751,263 @@ addListTo = foldl' merge
mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin
mkModMap pkg mod = unitUniqMap (mkModule pkg mod)
+-- -----------------------------------------------------------------------------
+-- Index
+
+data UnitIndexQuery =
+ UnitIndexQuery {
+ findOrigin :: UnitState -> ModuleName -> Bool -> Maybe (UniqMap Module ModuleOrigin),
+ index_all :: UnitState -> ModuleNameProvidersMap
+ }
+
+data UnitIndex =
+ UnitIndex {
+ query :: UnitId -> IO UnitIndexQuery,
+ readDatabases :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId],
+ update ::
+ Logger ->
+ UnitId ->
+ UnitConfig ->
+ [UnitDatabase UnitId] ->
+ [PackageFlag] ->
+ IO (
+ ModuleNameProvidersMap,
+ ModuleNameProvidersMap,
+ UnitInfoMap,
+ [(Unit, Maybe PackageArg)],
+ [UnitId],
+ UniqMap ModuleName [InstantiatedModule],
+ UniqFM PackageName UnitId,
+ WiringMap
+ )
+ }
+
+unitIndexQuery ::
+ MonadIO m =>
+ UnitId ->
+ UnitIndex ->
+ m UnitIndexQuery
+unitIndexQuery unit index = liftIO (index.query unit)
+
+data UnitIndexBackend =
+ UnitIndexBackend {
+ moduleNameProviders :: !ModuleNameProvidersMap,
+ pluginModuleNameProviders :: !ModuleNameProvidersMap
+ }
+
+newUnitIndexBackend :: UnitIndexBackend
+newUnitIndexBackend =
+ UnitIndexBackend {
+ moduleNameProviders = mempty,
+ pluginModuleNameProviders = mempty
+ }
+
+queryFindOriginDefault ::
+ UnitIndexBackend ->
+ UnitState ->
+ ModuleName ->
+ Bool ->
+ Maybe (UniqMap Module ModuleOrigin)
+queryFindOriginDefault _ UnitState {moduleNameProvidersMap, pluginModuleNameProvidersMap} name plugins =
+ lookupUniqMap source name
+ where
+ source = if plugins then pluginModuleNameProvidersMap else moduleNameProvidersMap
+
+newUnitIndexQuery ::
+ MonadIO m =>
+ IORef UnitIndexBackend ->
+ UnitId ->
+ m UnitIndexQuery
+newUnitIndexQuery ref _ = do
+ state <- liftIO $ readIORef ref
+ pure UnitIndexQuery {
+ findOrigin = queryFindOriginDefault state,
+ index_all = \ s -> s.moduleNameProvidersMap
+ }
+
+updateIndexDefault ::
+ Logger ->
+ UnitId ->
+ UnitConfig ->
+ [UnitDatabase UnitId] ->
+ [PackageFlag] ->
+ IO (ModuleNameProvidersMap, ModuleNameProvidersMap, UnitInfoMap, [(Unit, Maybe PackageArg)], [UnitId], UniqMap ModuleName [InstantiatedModule], UniqFM PackageName UnitId, WiringMap)
+updateIndexDefault logger _ cfg raw_dbs other_flags = do
+
+ -- distrust all units if the flag is set
+ let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) }
+ dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs
+ | otherwise = raw_dbs
+
+
+ -- Merge databases together, without checking validity
+ (pkg_map1, prec_map) <- mergeDatabases logger dbs
+
+ -- Now that we've merged everything together, prune out unusable
+ -- packages.
+ let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
+
+ reportCycles logger sccs
+ reportUnusable logger unusable
+
+ -- Apply trust flags (these flags apply regardless of whether
+ -- or not packages are visible or not)
+ pkgs1 <- mayThrowUnitErr
+ $ foldM (applyTrustFlag prec_map unusable)
+ (nonDetEltsUniqMap pkg_map2) (reverse (unitConfigFlagsTrusted cfg))
+ let prelim_pkg_db = mkUnitInfoMap pkgs1
+
+ --
+ -- Calculate the initial set of units from package databases, prior to any package flags.
+ --
+ -- Conceptually, we select the latest versions of all valid (not unusable) *packages*
+ -- (not units). This is empty if we have -hide-all-packages.
+ --
+ -- Then we create an initial visibility map with default visibilities for all
+ -- exposed, definite units which belong to the latest valid packages.
+ --
+ let preferLater unit unit' =
+ case compareByPreference prec_map unit unit' of
+ GT -> unit
+ _ -> unit'
+ addIfMorePreferable m unit = addToUDFM_C preferLater m (fsPackageName unit) unit
+ -- This is the set of maximally preferable packages. In fact, it is a set of
+ -- most preferable *units* keyed by package name, which act as stand-ins in
+ -- for "a package in a database". We use units here because we don't have
+ -- "a package in a database" as a type currently.
+ mostPreferablePackageReps = if unitConfigHideAll cfg
+ then emptyUDFM
+ else foldl' addIfMorePreferable emptyUDFM pkgs1
+ -- When exposing units, we want to consider all of those in the most preferable
+ -- packages. We can implement that by looking for units that are equi-preferable
+ -- with the most preferable unit for package. Being equi-preferable means that
+ -- they must be in the same database, with the same version, and the same package name.
+ --
+ -- We must take care to consider all these units and not just the most
+ -- preferable one, otherwise we can end up with problems like #16228.
+ mostPreferable u =
+ case lookupUDFM mostPreferablePackageReps (fsPackageName u) of
+ Nothing -> False
+ Just u' -> compareByPreference prec_map u u' == EQ
+ vis_map1 = foldl' (\vm p ->
+ -- Note: we NEVER expose indefinite packages by
+ -- default, because it's almost assuredly not
+ -- what you want (no mix-in linking has occurred).
+ if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p
+ then addToUniqMap vm (mkUnit p)
+ UnitVisibility {
+ uv_expose_all = True,
+ uv_renamings = [],
+ uv_package_name = First (Just (fsPackageName p)),
+ uv_requirements = emptyUniqMap,
+ uv_explicit = Nothing
+ }
+ else vm)
+ emptyUniqMap pkgs1
+
+ --
+ -- Compute a visibility map according to the command-line flags (-package,
+ -- -hide-package). This needs to know about the unusable packages, since if a
+ -- user tries to enable an unusable package, we should let them know.
+ --
+ vis_map2 <- mayThrowUnitErr
+ $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
+ (unitConfigHideAll cfg) pkgs1)
+ vis_map1 other_flags
+
+ --
+ -- Sort out which packages are wired in. This has to be done last, since
+ -- it modifies the unit ids of wired in packages, but when we process
+ -- package arguments we need to key against the old versions.
+ --
+ (pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2
+ let pkg_db = mkUnitInfoMap pkgs2
+
+ -- Update the visibility map, so we treat wired packages as visible.
+ let vis_map = updateVisibilityMap wired_map vis_map2
+
+ let hide_plugin_pkgs = unitConfigHideAllPlugins cfg
+ plugin_vis_map <-
+ case unitConfigFlagsPlugins cfg of
+ -- common case; try to share the old vis_map
+ [] | not hide_plugin_pkgs -> return vis_map
+ | otherwise -> return emptyUniqMap
+ _ -> do let plugin_vis_map1
+ | hide_plugin_pkgs = emptyUniqMap
+ -- Use the vis_map PRIOR to wired in,
+ -- because otherwise applyPackageFlag
+ -- won't work.
+ | otherwise = vis_map2
+ plugin_vis_map2
+ <- mayThrowUnitErr
+ $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
+ hide_plugin_pkgs pkgs1)
+ plugin_vis_map1
+ (reverse (unitConfigFlagsPlugins cfg))
+ -- Updating based on wired in packages is mostly
+ -- good hygiene, because it won't matter: no wired in
+ -- package has a compiler plugin.
+ -- TODO: If a wired in package had a compiler plugin,
+ -- and you tried to pick different wired in packages
+ -- with the plugin flags and the normal flags... what
+ -- would happen? I don't know! But this doesn't seem
+ -- likely to actually happen.
+ return (updateVisibilityMap wired_map plugin_vis_map2)
+
+ let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
+ | p <- pkgs2
+ ]
+ -- The explicitUnits accurately reflects the set of units we have turned
+ -- on; as such, it also is the only way one can come up with requirements.
+ -- The requirement context is directly based off of this: we simply
+ -- look for nested unit IDs that are directly fed holes: the requirements
+ -- of those units are precisely the ones we need to track
+ let explicit_pkgs = [(k, uv_explicit v) | (k, v) <- nonDetUniqMapToList vis_map]
+ req_ctx = mapUniqMap (Set.toList)
+ $ plusUniqMapListWith Set.union (map uv_requirements (nonDetEltsUniqMap vis_map))
+
+
+ --
+ -- Here we build up a set of the packages mentioned in -package
+ -- flags on the command line; these are called the "preload"
+ -- packages. we link these packages in eagerly. The preload set
+ -- should contain at least rts & base, which is why we pretend that
+ -- the command line contains -package rts & -package base.
+ --
+ -- NB: preload IS important even for type-checking, because we
+ -- need the correct include path to be set.
+ --
+ let preload1 = nonDetKeysUniqMap (filterUniqMap (isJust . uv_explicit) vis_map)
+
+ -- add default preload units if they can be found in the db
+ basicLinkedUnits = fmap (RealUnit . Definite)
+ $ filter (flip elemUniqMap pkg_db)
+ $ unitConfigAutoLink cfg
+ preload3 = ordNub $ (basicLinkedUnits ++ preload1)
+
+ -- Close the preload packages with their dependencies
+ dep_preload <- mayThrowUnitErr
+ $ closeUnitDeps pkg_db
+ $ zip (map toUnitId preload3) (repeat Nothing)
+
+ let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
+ mod_map2 = mkUnusableModuleNameProvidersMap unusable
+ mod_map = mod_map2 `plusUniqMap` mod_map1
+ pluginModuleNameProviders = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
+ pure (mod_map, pluginModuleNameProviders, pkg_db, explicit_pkgs, dep_preload, req_ctx, pkgname_map, wired_map)
+
+readDatabasesDefault :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId]
+readDatabasesDefault logger _ cfg =
+ readUnitDatabases logger cfg
+
+newUnitIndex :: MonadIO m => m UnitIndex
+newUnitIndex = do
+ ref <- liftIO $ newIORef newUnitIndexBackend
+ pure UnitIndex {
+ query = newUnitIndexQuery ref,
+ readDatabases = readDatabasesDefault,
+ update = updateIndexDefault
+ }
-- -----------------------------------------------------------------------------
-- Package Utils
@@ -1903,10 +2015,11 @@ mkModMap pkg mod = unitUniqMap (mkModule pkg mod)
-- | Takes a 'ModuleName', and if the module is in any package returns
-- list of modules which take that name.
lookupModuleInAllUnits :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> [(Module, UnitInfo)]
-lookupModuleInAllUnits pkgs m
- = case lookupModuleWithSuggestions pkgs m NoPkgQual of
+lookupModuleInAllUnits pkgs query m
+ = case lookupModuleWithSuggestions pkgs query m NoPkgQual of
LookupFound a b -> [(a,fst b)]
LookupMultiple rs -> map f rs
where f (m,_) = (m, expectJust "lookupModule" (lookupUnit pkgs
@@ -1933,18 +2046,24 @@ data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin
| SuggestHidden ModuleName Module ModuleOrigin
lookupModuleWithSuggestions :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> PkgQual
-> LookupResult
-lookupModuleWithSuggestions pkgs
- = lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs)
+lookupModuleWithSuggestions pkgs query name
+ = lookupModuleWithSuggestions' pkgs query name False
-- | The package which the module **appears** to come from, this could be
-- the one which reexports the module from it's original package. This function
-- is currently only used for -Wunused-packages
-lookupModulePackage :: UnitState -> ModuleName -> PkgQual -> Maybe [UnitInfo]
-lookupModulePackage pkgs mn mfs =
- case lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs) mn mfs of
+lookupModulePackage ::
+ UnitState ->
+ UnitIndexQuery ->
+ ModuleName ->
+ PkgQual ->
+ Maybe [UnitInfo]
+lookupModulePackage pkgs query mn mfs =
+ case lookupModuleWithSuggestions' pkgs query mn False mfs of
LookupFound _ (orig_unit, origin) ->
case origin of
ModOrigin {fromOrigUnit, fromExposedReexport} ->
@@ -1960,19 +2079,21 @@ lookupModulePackage pkgs mn mfs =
_ -> Nothing
lookupPluginModuleWithSuggestions :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> PkgQual
-> LookupResult
-lookupPluginModuleWithSuggestions pkgs
- = lookupModuleWithSuggestions' pkgs (pluginModuleNameProvidersMap pkgs)
+lookupPluginModuleWithSuggestions pkgs query name
+ = lookupModuleWithSuggestions' pkgs query name True
lookupModuleWithSuggestions' :: UnitState
- -> ModuleNameProvidersMap
+ -> UnitIndexQuery
-> ModuleName
+ -> Bool
-> PkgQual
-> LookupResult
-lookupModuleWithSuggestions' pkgs mod_map m mb_pn
- = case lookupUniqMap mod_map m of
+lookupModuleWithSuggestions' pkgs query m onlyPlugins mb_pn
+ = case query.findOrigin pkgs m onlyPlugins of
Nothing -> LookupNotFound suggestions
Just xs ->
case foldl' classify ([],[],[], []) (sortOn fst $ nonDetUniqMapToList xs) of
@@ -2033,16 +2154,16 @@ lookupModuleWithSuggestions' pkgs mod_map m mb_pn
all_mods :: [(String, ModuleSuggestion)] -- All modules
all_mods = sortBy (comparing fst) $
[ (moduleNameString m, suggestion)
- | (m, e) <- nonDetUniqMapToList (moduleNameProvidersMap pkgs)
+ | (m, e) <- nonDetUniqMapToList (query.index_all pkgs)
, suggestion <- map (getSuggestion m) (nonDetUniqMapToList e)
]
getSuggestion name (mod, origin) =
(if originVisible origin then SuggestVisible else SuggestHidden)
name mod origin
-listVisibleModuleNames :: UnitState -> [ModuleName]
-listVisibleModuleNames state =
- map fst (filter visible (nonDetUniqMapToList (moduleNameProvidersMap state)))
+listVisibleModuleNames :: UnitState -> UnitIndexQuery -> [ModuleName]
+listVisibleModuleNames unit_state query =
+ map fst (filter visible (nonDetUniqMapToList (query.index_all unit_state)))
where visible (_, ms) = anyUniqMap originVisible ms
-- | Takes a list of UnitIds (and their "parent" dependency, used for error
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -3695,19 +3695,21 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000
completeModule = wrapIdentCompleterMod $ \w -> do
hsc_env <- GHC.getSession
- let pkg_mods = allVisibleModules (hsc_units hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let pkg_mods = allVisibleModules (hsc_units hsc_env) query
loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
return $ filter (w `isPrefixOf`)
$ map (showPpr (hsc_dflags hsc_env)) $ loaded_mods ++ pkg_mods
completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
hsc_env <- GHC.getSession
+ query <- liftIO $ hscUnitIndexQuery hsc_env
modules <- case m of
Just '-' -> do
imports <- GHC.getContext
return $ map iiModuleName imports
_ -> do
- let pkg_mods = allVisibleModules (hsc_units hsc_env)
+ let pkg_mods = allVisibleModules (hsc_units hsc_env) query
loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
return $ loaded_mods ++ pkg_mods
return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) modules
@@ -3775,8 +3777,8 @@ wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing wor
-- | Return a list of visible module names for autocompletion.
-- (NB: exposed != visible)
-allVisibleModules :: UnitState -> [ModuleName]
-allVisibleModules unit_state = listVisibleModuleNames unit_state
+allVisibleModules :: UnitState -> UnitIndexQuery -> [ModuleName]
+allVisibleModules us query = listVisibleModuleNames us query
completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
completeIdentifier
=====================================
ghc/GHCi/UI/Monad.hs
=====================================
@@ -374,10 +374,11 @@ printForUserGlobalRdrEnv mb_rdr_env doc = do
where
mkNamePprCtxFromGlobalRdrEnv _ Nothing = GHC.getNamePprCtx
mkNamePprCtxFromGlobalRdrEnv dflags (Just rdr_env) =
- withSession $ \ hsc_env ->
+ withSession $ \ hsc_env -> do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
let unit_env = hsc_unit_env hsc_env
ptc = initPromotionTickContext dflags
- in return $ Ppr.mkNamePprCtx ptc unit_env rdr_env
+ return $ Ppr.mkNamePprCtx ptc unit_env query rdr_env
printForUser :: GhcMonad m => SDoc -> m ()
printForUser doc = do
=====================================
ghc/Main.hs
=====================================
@@ -844,7 +844,8 @@ initMulti unitArgsFiles = do
let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
hue_flags = homeUnitEnv_dflags homeUnitEnv
dflags = homeUnitEnv_dflags homeUnitEnv
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units
+ index = hscUnitIndex hsc_env
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags index cached_unit_dbs home_units
updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
pure $ HomeUnitEnv
@@ -859,7 +860,7 @@ initMulti unitArgsFiles = do
let dflags = homeUnitEnv_dflags $ unitEnv_lookup mainUnitId home_unit_graph
unitEnv <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags))
- let final_hsc_env = hsc_env { hsc_unit_env = unitEnv }
+ let final_hsc_env = hsc_env { hsc_unit_env = unitEnv {ue_index = hscUnitIndex hsc_env} }
GHC.setSession final_hsc_env
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e401cd4a57eb530b612d38dc49f4b1…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e401cd4a57eb530b612d38dc49f4b1…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
06 Dec '25
Simon Peyton Jones pushed to branch wip/T23162-part2 at Glasgow Haskell Compiler / GHC
Commits:
a6edda86 by Simon Peyton Jones at 2025-12-06T00:16:50+00:00
Final wibbles
- - - - -
10 changed files:
- compiler/GHC/Tc/Solver/FunDeps.hs
- testsuite/tests/quantified-constraints/T15316A.stderr
- testsuite/tests/quantified-constraints/T17267.stderr
- testsuite/tests/quantified-constraints/T17267a.stderr
- testsuite/tests/quantified-constraints/T17267b.stderr
- testsuite/tests/quantified-constraints/T17267c.stderr
- testsuite/tests/quantified-constraints/T17267e.stderr
- testsuite/tests/quantified-constraints/T17458.stderr
- testsuite/tests/typecheck/should_fail/ContextStack1.stderr
- testsuite/tests/typecheck/should_fail/TcCoercibleFail.stderr
Changes:
=====================================
compiler/GHC/Tc/Solver/FunDeps.hs
=====================================
@@ -334,9 +334,8 @@ tryDictFunDepsLocal dict_ct@(DictCt { di_cls = cls, di_ev = work_ev })
text "unif =" <+> ppr unif_happened $$ text "eqns = " <+> ppr eqns
-- See (DFL1) of Note [Do fundeps last]
- ; if insoluble then continueWith True
- else if unif_happened then startAgainWith (CDictCan dict_ct)
- else continueWith False }
+ ; if unif_happened then startAgainWith (CDictCan dict_ct)
+ else continueWith insoluble }
where
work_pred = ctEvPred work_ev
work_is_given = isGiven work_ev
@@ -540,9 +539,8 @@ tryFDEqns fam_tc work_args work_item@(EqCt { eq_ev = ev, eq_rhs= rhs }) mk_fd_eq
, text "eqns:" <+> ppr fd_eqns ])
; (insoluble, unif_happened) <- solveFunDeps ev fd_eqns
- ; if insoluble then continueWith True
- else if unif_happened then startAgainWith (CEqCan work_item)
- else continueWith False }
+ ; if unif_happened then startAgainWith (CEqCan work_item)
+ else continueWith insoluble }
-----------------------------------------
-- User-defined type families
=====================================
testsuite/tests/quantified-constraints/T15316A.stderr
=====================================
@@ -1,7 +1,6 @@
-
T15316A.hs:15:23: error: [GHC-40404]
• Reduction stack overflow; size = 201
- When simplifying the following type: Class a
+ When simplifying the following constraint: Class a
• In the third argument of ‘subsume’, namely ‘method’
In the expression: subsume p p method
In an equation for ‘value’: value p = subsume p p method
@@ -10,3 +9,4 @@ T15316A.hs:15:23: error: [GHC-40404]
(any upper bound you could choose might fail unpredictably with
minor updates to GHC, so disabling the check is recommended if
you're sure that type checking should terminate)
+
=====================================
testsuite/tests/quantified-constraints/T17267.stderr
=====================================
@@ -1,7 +1,6 @@
-
T17267.hs:17:12: error: [GHC-40404]
• Reduction stack overflow; size = 201
- When simplifying the following type: a ~ b
+ When simplifying the following constraint: a ~ b
• In the expression: r
In an equation for ‘oops’: oops r = r
In an equation for ‘unsafeCoerce’:
@@ -15,3 +14,4 @@ T17267.hs:17:12: error: [GHC-40404]
(any upper bound you could choose might fail unpredictably with
minor updates to GHC, so disabling the check is recommended if
you're sure that type checking should terminate)
+
=====================================
testsuite/tests/quantified-constraints/T17267a.stderr
=====================================
@@ -1,7 +1,6 @@
-
T17267a.hs:18:12: error: [GHC-40404]
• Reduction stack overflow; size = 201
- When simplifying the following type: C a b
+ When simplifying the following constraint: C a b
• In the expression: op x
In an equation for ‘oops’: oops x = op x
In an equation for ‘uc’:
@@ -15,3 +14,4 @@ T17267a.hs:18:12: error: [GHC-40404]
(any upper bound you could choose might fail unpredictably with
minor updates to GHC, so disabling the check is recommended if
you're sure that type checking should terminate)
+
=====================================
testsuite/tests/quantified-constraints/T17267b.stderr
=====================================
@@ -1,7 +1,6 @@
-
T17267b.hs:15:12: error: [GHC-40404]
• Reduction stack overflow; size = 201
- When simplifying the following type: a ~ b
+ When simplifying the following constraint: a ~ b
• In the expression: x
In an equation for ‘oops’: oops x = x
In an equation for ‘uc’:
@@ -15,3 +14,4 @@ T17267b.hs:15:12: error: [GHC-40404]
(any upper bound you could choose might fail unpredictably with
minor updates to GHC, so disabling the check is recommended if
you're sure that type checking should terminate)
+
=====================================
testsuite/tests/quantified-constraints/T17267c.stderr
=====================================
@@ -1,7 +1,6 @@
-
T17267c.hs:22:14: error: [GHC-40404]
• Reduction stack overflow; size = 201
- When simplifying the following type: C a b
+ When simplifying the following constraint: C a b
• In the expression: r
In an equation for ‘oops’: oops r = r
In an equation for ‘unsafeCoerce’:
@@ -15,3 +14,4 @@ T17267c.hs:22:14: error: [GHC-40404]
(any upper bound you could choose might fail unpredictably with
minor updates to GHC, so disabling the check is recommended if
you're sure that type checking should terminate)
+
=====================================
testsuite/tests/quantified-constraints/T17267e.stderr
=====================================
@@ -1,7 +1,6 @@
-
T17267e.hs:16:14: error: [GHC-40404]
• Reduction stack overflow; size = 201
- When simplifying the following type: Show a
+ When simplifying the following constraint: Show a
• In the expression: show
In an equation for ‘pseudoShow’: pseudoShow = show
Suggested fix:
@@ -9,3 +8,4 @@ T17267e.hs:16:14: error: [GHC-40404]
(any upper bound you could choose might fail unpredictably with
minor updates to GHC, so disabling the check is recommended if
you're sure that type checking should terminate)
+
=====================================
testsuite/tests/quantified-constraints/T17458.stderr
=====================================
@@ -1,7 +1,6 @@
-
T17458.hs:32:32: error: [GHC-40404]
• Reduction stack overflow; size = 201
- When simplifying the following type: Typeable Void
+ When simplifying the following constraint: Typeable Void
• In the expression: eqT
In the expression:
case eqT of
@@ -17,3 +16,4 @@ T17458.hs:32:32: error: [GHC-40404]
(any upper bound you could choose might fail unpredictably with
minor updates to GHC, so disabling the check is recommended if
you're sure that type checking should terminate)
+
=====================================
testsuite/tests/typecheck/should_fail/ContextStack1.stderr
=====================================
@@ -1,7 +1,7 @@
-
ContextStack1.hs:10:5: error: [GHC-40404]
• Reduction stack overflow; size = 11
- When simplifying the following type: Cls [[[[[[[[[[()]]]]]]]]]]
+ When simplifying the following constraint:
+ Cls [[[[[[[[[[[()]]]]]]]]]]]
• In the expression: meth
In an equation for ‘t’: t = meth
Suggested fix:
@@ -9,3 +9,4 @@ ContextStack1.hs:10:5: error: [GHC-40404]
(any upper bound you could choose might fail unpredictably with
minor updates to GHC, so disabling the check is recommended if
you're sure that type checking should terminate)
+
=====================================
testsuite/tests/typecheck/should_fail/TcCoercibleFail.stderr
=====================================
@@ -49,7 +49,8 @@ TcCoercibleFail.hs:30:9: error: [GHC-18872]
TcCoercibleFail.hs:35:8: error: [GHC-40404]
• Reduction stack overflow; size = 201
- When simplifying the following type: Fix (Either Age)
+ When simplifying the following constraint:
+ Coercible (Either Int (Fix (Either Int))) (Fix (Either Age))
• In the expression: coerce :: Fix (Either Int) -> Fix (Either Age)
In an equation for ‘foo6’:
foo6 = coerce :: Fix (Either Int) -> Fix (Either Age)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a6edda869870da4fe7d5c726e00f80c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a6edda869870da4fe7d5c726e00f80c…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Simon Peyton Jones pushed to branch wip/26543 at Glasgow Haskell Compiler / GHC
Commits:
bcda1eff by Simon Peyton Jones at 2025-12-05T23:59:28+00:00
Wibbles
- - - - -
2 changed files:
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -292,7 +292,8 @@ simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs
BC_Let top_lvl is_rec -> simplTrace "SimplBind:normal" (ppr old_bndr) $
simplLazyBind top_lvl is_rec
- (old_bndr,env) (new_bndr,env) (rhs,env)
+ (old_bndr,env) (new_bndr,env)
+ (rhs,env,MRefl)
simplTrace :: String -> SDoc -> SimplM a -> SimplM a
simplTrace herald doc thing_inside = do
@@ -307,11 +308,11 @@ simplLazyBind :: TopLevelFlag -> RecFlag
-> (OutId, SimplEnv) -- OutBinder, and SimplEnv after simplifying that binder
-- The OutId has IdInfo (notably RULES),
-- except arity, unfolding
- -> (InExpr, SimplEnv) -- The RHS and its static environment
+ -> (InExpr, SimplEnv, MOutCoercion) -- The RHS and its static environment
-> SimplM (SimplFloats, SimplEnv)
-- Precondition: Ids only, no TyVars; not a JoinId
-- Precondition: rhs obeys the let-can-float invariant
-simplLazyBind top_lvl is_rec (bndr,unf_se) (bndr1,env) (rhs,rhs_se)
+simplLazyBind top_lvl is_rec (bndr,unf_se) (bndr1,env) (rhs,rhs_se,mco)
= assert (isId bndr )
assertPpr (not (isJoinId bndr)) (ppr bndr) $
-- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $
@@ -364,7 +365,9 @@ simplLazyBind top_lvl is_rec (bndr,unf_se) (bndr1,env) (rhs,rhs_se)
; let env1 = env `setInScopeFromF` rhs_floats
; rhs' <- rebuildLam env1 tvs' body3 rhs_cont
- ; (bind_float, env2) <- completeBind (BC_Let top_lvl is_rec) (bndr,unf_se) (bndr1,rhs',env1)
+ ; (bind_float, env2) <- completeBind (BC_Let top_lvl is_rec)
+ (bndr, unf_se)
+ (bndr1, mkCastMCo rhs' mco, env1)
; return (rhs_floats `addFloats` bind_float, env2) }
--------------------------
@@ -1875,7 +1878,7 @@ simplNonRecE env from_what bndr (ContEx rhs_se rhs mco) body cont
= do { (env1, bndr1) <- simplNonRecBndr env bndr
; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive)
; (floats1, env3) <- simplLazyBind NotTopLevel NonRecursive
- (bndr,env) (bndr2,env2) (rhs,rhs_se)
+ (bndr,env) (bndr2,env2) (rhs,rhs_se,mco)
; (floats2, expr') <- simplNonRecBody env3 from_what body cont
; return (floats1 `addFloats` floats2, expr') }
@@ -2243,7 +2246,7 @@ simplCloArg :: SimplEnvIS -- ^ Used only for its InScopeSet
-- continuation passed to 'simplExprC'
-> SimplClo
-> SimplM OutExpr
-simplCloArg env fun_ty mb_arg_info clo@(ContEx arg_se arg mco)
+simplCloArg env fun_ty mb_arg_info (ContEx arg_se arg mco)
= simplExprC arg_env arg (pushCastCont mco stop)
where
arg_env = arg_se `setInScopeFromE` env
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -224,11 +224,6 @@ data FromWhat = FromLet | FromBeta Levity
data DupFlag = NoDup -- Unsimplified, might be big
| OkToDup -- Simplified and small
-isSimplified :: DupFlag -> Bool
-isSimplified NoDup = False
-isSimplified _ = True -- Invariant: the subst-env is empty
-
-
{- Note [StaticEnv invariant]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We pair up an InExpr or InAlts with a StaticEnv, which establishes the
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bcda1eff59ec9f54a6cfd3b71f361ab…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bcda1eff59ec9f54a6cfd3b71f361ab…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/torsten.schmits/unit-index-debug] 3 commits: Use a name provider map for home packages
by Torsten Schmits (＠torsten.schmits) 06 Dec '25
by Torsten Schmits (＠torsten.schmits) 06 Dec '25
06 Dec '25
Torsten Schmits pushed to branch wip/torsten.schmits/unit-index-debug at Glasgow Haskell Compiler / GHC
Commits:
6516e274 by Matthew Pickering at 2025-12-06T00:04:32+01:00
Use a name provider map for home packages
- - - - -
d608911a by Torsten Schmits at 2025-12-06T00:05:17+01:00
disable home unit closure check
- - - - -
e401cd4a by Torsten Schmits at 2025-12-06T00:05:17+01:00
WIP: unit index
- - - - -
23 changed files:
- compiler/GHC.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Runtime/Context.hs
- compiler/GHC/Runtime/Loader.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/Name/Ppr.hs
- compiler/GHC/Unit/Env.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Module/Graph.hs
- compiler/GHC/Unit/State.hs
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Monad.hs
- ghc/Main.hs
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -341,7 +341,7 @@ import GHC.Builtin.Types.Prim ( alphaTyVars )
import GHC.Data.StringBuffer
import GHC.Data.FastString
import qualified GHC.LanguageExtensions as LangExt
-import GHC.Rename.Names (renamePkgQual, renameRawPkgQual, gresFromAvails)
+import GHC.Rename.Names (gresFromAvails, hscRenamePkgQual, hscRenameRawPkgQual)
import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
import GHC.Tc.Types
@@ -625,7 +625,8 @@ setUnitDynFlagsNoCheck uid dflags1 = do
let old_hue = ue_findHomeUnitEnv uid (hsc_unit_env hsc_env)
let cached_unit_dbs = homeUnitEnv_unit_dbs old_hue
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs (hsc_all_home_unit_ids hsc_env)
+ index <- hscUnitIndex <$> getSession
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 index cached_unit_dbs (hsc_all_home_unit_ids hsc_env)
updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants
let upd hue =
@@ -760,6 +761,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
then do
-- additionally, set checked dflags so we don't lose fixes
old_unit_env <- ue_setFlags dflags0 . hsc_unit_env <$> getSession
+ ue_index <- hscUnitIndex <$> getSession
home_unit_graph <- forM (ue_home_unit_graph old_unit_env) $ \homeUnitEnv -> do
let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
@@ -767,7 +769,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
old_hpt = homeUnitEnv_hpt homeUnitEnv
home_units = unitEnv_keys (ue_home_unit_graph old_unit_env)
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags ue_index cached_unit_dbs home_units
updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
pure HomeUnitEnv
@@ -785,6 +787,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
, ue_home_unit_graph = home_unit_graph
, ue_current_unit = ue_currentUnit old_unit_env
, ue_eps = ue_eps old_unit_env
+ , ue_index
}
modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env }
else modifySession (hscSetFlags dflags0)
@@ -1379,7 +1382,8 @@ getInsts = withSession $ \hsc_env ->
getNamePprCtx :: GhcMonad m => m NamePprCtx
getNamePprCtx = withSession $ \hsc_env -> do
- return $ icNamePprCtx (hsc_unit_env hsc_env) (hsc_IC hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ return $ icNamePprCtx (hsc_unit_env hsc_env) query (hsc_IC hsc_env)
-- | Container for information about a 'Module'.
data ModuleInfo = ModuleInfo {
@@ -1474,7 +1478,8 @@ mkNamePprCtxForModule ::
ModuleInfo ->
m NamePprCtx
mkNamePprCtxForModule mod minf = withSession $ \hsc_env -> do
- let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (availsToGlobalRdrEnv hsc_env mod (minf_exports minf))
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (availsToGlobalRdrEnv hsc_env mod (minf_exports minf))
ptc = initPromotionTickContext (hsc_dflags hsc_env)
return name_ppr_ctx
@@ -1711,10 +1716,10 @@ modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc d
parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))
renamePkgQualM :: GhcMonad m => ModuleName -> Maybe FastString -> m PkgQual
-renamePkgQualM mn p = withSession $ \hsc_env -> pure (renamePkgQual (hsc_unit_env hsc_env) mn p)
+renamePkgQualM mn p = withSession $ \hsc_env -> hscRenamePkgQual hsc_env mn p
renameRawPkgQualM :: GhcMonad m => ModuleName -> RawPkgQual -> m PkgQual
-renameRawPkgQualM mn p = withSession $ \hsc_env -> pure (renameRawPkgQual (hsc_unit_env hsc_env) mn p)
+renameRawPkgQualM mn p = withSession $ \hsc_env -> hscRenameRawPkgQual hsc_env mn p
-- | Like 'findModule', but differs slightly when the module refers to
-- a source file, and the file has not been loaded via 'load'. In
@@ -1738,7 +1743,8 @@ lookupQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do
let units = hsc_units hsc_env
let dflags = hsc_dflags hsc_env
let fopts = initFinderOpts dflags
- res <- findExposedPackageModule fc fopts units mod_name NoPkgQual
+ query <- hscUnitIndexQuery hsc_env
+ res <- findExposedPackageModule fc fopts units query mod_name NoPkgQual
case res of
Found _ m -> return m
err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err
=====================================
compiler/GHC/Core/Opt/Pipeline.hs
=====================================
@@ -78,6 +78,8 @@ core2core hsc_env guts@(ModGuts { mg_module = mod
, mg_rdr_env = rdr_env })
= do { let builtin_passes = getCoreToDo dflags hpt_rule_base extra_vars
uniq_tag = 's'
+ ; query <- hscUnitIndexQuery hsc_env
+ ; let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env
; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_tag mod
name_ppr_ctx loc $
@@ -100,7 +102,6 @@ core2core hsc_env guts@(ModGuts { mg_module = mod
home_pkg_rules = hptRules hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod
, gwib_isBoot = NotBoot })
hpt_rule_base = mkRuleBase home_pkg_rules
- name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env
ptc = initPromotionTickContext dflags
-- mod: get the module out of the current HscEnv so we can retrieve it from the monad.
-- This is very convienent for the users of the monad (e.g. plugins do not have to
@@ -459,6 +460,7 @@ doCorePass pass guts = do
dflags <- getDynFlags
us <- getUniqueSupplyM
p_fam_env <- getPackageFamInstEnv
+ query <- liftIO $ hscUnitIndexQuery hsc_env
let platform = targetPlatform dflags
let fam_envs = (p_fam_env, mg_fam_inst_env guts)
let updateBinds f = return $ guts { mg_binds = f (mg_binds guts) }
@@ -471,6 +473,7 @@ doCorePass pass guts = do
mkNamePprCtx
(initPromotionTickContext dflags)
(hsc_unit_env hsc_env)
+ query
rdr_env
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -429,6 +429,7 @@ addUnit u = do
logger <- getLogger
let dflags0 = hsc_dflags hsc_env
let old_unit_env = hsc_unit_env hsc_env
+ ue_index = hscUnitIndex hsc_env
newdbs <- case ue_unit_dbs old_unit_env of
Nothing -> panic "addUnit: called too early"
Just dbs ->
@@ -437,7 +438,7 @@ addUnit u = do
, unitDatabaseUnits = [u]
}
in return (dbs ++ [newdb]) -- added at the end because ordering matters
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs) (hsc_all_home_unit_ids hsc_env)
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 ue_index (Just newdbs) (hsc_all_home_unit_ids hsc_env)
-- update platform constants
dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
@@ -452,6 +453,7 @@ addUnit u = do
(homeUnitId home_unit)
(mkHomeUnitEnv dflags (ue_hpt old_unit_env) (Just home_unit))
, ue_eps = ue_eps old_unit_env
+ , ue_index
}
setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env }
@@ -870,6 +872,8 @@ hsModuleToModSummary home_keys pn hsc_src modname
hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+
-- Also copied from 'getImports'
let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps
@@ -882,7 +886,7 @@ hsModuleToModSummary home_keys pn hsc_src modname
implicit_imports = mkPrelImports modname loc
implicit_prelude imps
- rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) modname
+ rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query modname
convImport (L _ i) = (rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i)
extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname
=====================================
compiler/GHC/Driver/Env.hs
=====================================
@@ -7,6 +7,8 @@ module GHC.Driver.Env
, hsc_home_unit
, hsc_home_unit_maybe
, hsc_units
+ , hscUnitIndex
+ , hscUnitIndexQuery
, hsc_HPT
, hsc_HUE
, hsc_HUG
@@ -118,6 +120,13 @@ hsc_home_unit_maybe = ue_homeUnit . hsc_unit_env
hsc_units :: HasDebugCallStack => HscEnv -> UnitState
hsc_units = ue_units . hsc_unit_env
+hscUnitIndex :: HscEnv -> UnitIndex
+hscUnitIndex = ue_index . hsc_unit_env
+
+hscUnitIndexQuery :: HscEnv -> IO UnitIndexQuery
+hscUnitIndexQuery hsc_env =
+ unitIndexQuery (hscActiveUnitId hsc_env) (hscUnitIndex hsc_env)
+
hsc_HPT :: HscEnv -> HomePackageTable
hsc_HPT = ue_hpt . hsc_unit_env
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -2665,9 +2665,10 @@ hscTidy hsc_env guts = do
$! {-# SCC "CoreTidy" #-} tidyProgram opts guts
-- post tidy pretty-printing and linting...
+ query <- hscUnitIndexQuery hsc_env
let tidy_rules = md_rules details
let all_tidy_binds = cg_binds cgguts
- let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (mg_rdr_env guts)
+ let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (mg_rdr_env guts)
ptc = initPromotionTickContext (hsc_dflags hsc_env)
endPassHscEnvIO hsc_env name_ppr_ctx CoreTidy all_tidy_binds tidy_rules
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -148,6 +148,7 @@ import GHC.Utils.Constants
import GHC.Types.Unique.DFM (udfmRestrictKeysSet)
import GHC.Types.Unique
import GHC.Iface.Errors.Types
+import GHC.Unit.State (UnitIndexQuery)
import qualified GHC.Data.Word64Set as W
import GHC.Data.Graph.Directed.Reachability
@@ -190,12 +191,13 @@ depanalE excluded_mods allow_dup_roots = do
if isEmptyMessages errs
then do
hsc_env <- getSession
+ query <- liftIO $ hscUnitIndexQuery hsc_env
let one_unit_messages get_mod_errs k hue = do
errs <- get_mod_errs
unknown_module_err <- warnUnknownModules (hscSetActiveUnitId k hsc_env) (homeUnitEnv_dflags hue) mod_graph
let unused_home_mod_err = warnMissingHomeModules (homeUnitEnv_dflags hue) (hsc_targets hsc_env) mod_graph
- unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) (homeUnitEnv_dflags hue) mod_graph
+ unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) query (homeUnitEnv_dflags hue) mod_graph
return $ errs `unionMessages` unused_home_mod_err
@@ -513,15 +515,15 @@ loadWithCache cache diag_wrapper how_much = do
-- actually loaded packages. All the packages, specified on command line,
-- but never loaded, are probably unused dependencies.
-warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages
-warnUnusedPackages us dflags mod_graph =
+warnUnusedPackages :: UnitState -> UnitIndexQuery -> DynFlags -> ModuleGraph -> DriverMessages
+warnUnusedPackages us query dflags mod_graph =
let diag_opts = initDiagOpts dflags
home_mod_sum = filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph)
-- Only need non-source imports here because SOURCE imports are always HPT
loadedPackages = concat $
- mapMaybe (\(fs, mn) -> lookupModulePackage us (unLoc mn) fs)
+ mapMaybe (\(fs, mn) -> lookupModulePackage us query (unLoc mn) fs)
$ concatMap ms_imps home_mod_sum
any_import_ghc_prim = any ms_ghc_prim_import home_mod_sum
@@ -1603,7 +1605,6 @@ downsweep_imports hsc_env old_summaries old_graph excl_mods allow_dup_roots (roo
checkDuplicates root_map
let done0 = maybe M.empty moduleGraphNodeMap old_graph
(deps, map0) <- loopSummaries rootSummariesOk (done0, root_map)
- let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env)
let unit_env = hsc_unit_env hsc_env
let tmpfs = hsc_tmpfs hsc_env
@@ -1613,7 +1614,7 @@ downsweep_imports hsc_env old_summaries old_graph excl_mods allow_dup_roots (roo
(other_errs, unit_nodes) = partitionEithers $ unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] (hsc_HUG hsc_env)
all_nodes = downsweep_nodes ++ unit_nodes
all_errs = all_root_errs ++ downsweep_errs ++ other_errs
- all_root_errs = closure_errs ++ map snd root_errs
+ all_root_errs = map snd root_errs
-- if we have been passed -fno-code, we enable code generation
-- for dependencies of modules that have -XTemplateHaskell,
@@ -2400,7 +2401,8 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn
let mopts = map unLoc $ snd $ getOptions popts pi_hspp_buf src_fn
pure $ ((, mopts) <$>) $ first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps
- let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query
let rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn))
let pi_srcimps = rn_imps pi_srcimps'
let pi_theimps = rn_imps pi_theimps'
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -692,9 +692,10 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do
-- gather the imports and module name
(hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do
buf <- hGetStringBuffer input_fn
+ query <- hscUnitIndexQuery hsc_env
let imp_prelude = xopt LangExt.ImplicitPrelude dflags
popts = initParserOpts dflags
- rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
+ rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query
rn_imps = fmap (\(rpk, lmn@(L _ mn)) -> (rn_pkg_qual mn rpk, lmn))
eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff)
case eimps of
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -149,7 +149,8 @@ deSugar hsc_env
= do { let dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
ptc = initPromotionTickContext (hsc_dflags hsc_env)
- name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env
+ ; query <- hscUnitIndexQuery hsc_env
+ ; let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env
; withTiming logger
(text "Desugar"<+>brackets (ppr mod))
(const ()) $
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -89,6 +89,7 @@ import GHC.Data.FastString
import GHC.Unit.Env
import GHC.Unit.External
+import GHC.Unit.State (UnitIndexQuery)
import GHC.Unit.Module
import GHC.Unit.Module.ModGuts
@@ -264,7 +265,8 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
++ eps_complete_matches eps -- from imports
-- re-use existing next_wrapper_num to ensure uniqueness
next_wrapper_num_var = tcg_next_wrapper_num tcg_env
- ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env ptc
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+ ; return $ mkDsEnvs unit_env query this_mod rdr_env type_env fam_inst_env ptc
msg_var cc_st_var next_wrapper_num_var complete_matches
}
@@ -292,6 +294,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
; next_wrapper_num <- newIORef emptyModuleEnv
; msg_var <- newIORef emptyMessages
; eps <- liftIO $ hscEPS hsc_env
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
; let unit_env = hsc_unit_env hsc_env
type_env = typeEnvFromEntities ids tycons patsyns fam_insts
ptc = initPromotionTickContext (hsc_dflags hsc_env)
@@ -303,7 +306,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
bindsToIds (Rec binds) = map fst binds
ids = concatMap bindsToIds binds
- envs = mkDsEnvs unit_env this_mod rdr_env type_env
+ envs = mkDsEnvs unit_env query this_mod rdr_env type_env
fam_inst_env ptc msg_var cc_st_var
next_wrapper_num complete_matches
; runDs hsc_env envs thing_inside
@@ -342,12 +345,12 @@ initTcDsForSolver thing_inside
Just ret -> pure ret
Nothing -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLocDefault (getErrorMessages msgs)) }
-mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
+mkDsEnvs :: UnitEnv -> UnitIndexQuery -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> PromotionTickContext
-> IORef (Messages DsMessage) -> IORef CostCentreState
-> IORef (ModuleEnv Int) -> CompleteMatches
-> (DsGblEnv, DsLclEnv)
-mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
+mkDsEnvs unit_env query mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
next_wrapper_num complete_matches
= let if_genv = IfGblEnv { if_doc = text "mkDsEnvs"
-- Failing tests here are `ghci` and `T11985` if you get this wrong.
@@ -364,7 +367,7 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
, ds_fam_inst_env = fam_inst_env
, ds_gbl_rdr_env = rdr_env
, ds_if_env = (if_genv, if_lenv)
- , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env rdr_env
+ , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env query rdr_env
, ds_msgs = msg_var
, ds_complete_matches = complete_matches
, ds_cc_st = cc_st_var
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -588,7 +588,8 @@ checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
checkDependencies hsc_env summary iface
= do
res_normal <- classify_import (findImportedModule hsc_env) (ms_textual_imps summary ++ ms_srcimps summary)
- res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units mhome_unit mod) (ms_plugin_imps summary)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units query mhome_unit mod) (ms_plugin_imps summary)
case sequence (res_normal ++ res_plugin ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of
Left recomp -> return $ NeedsRecompile recomp
Right es -> do
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -27,6 +27,7 @@ module GHC.Rename.Names (
getMinimalImports,
printMinimalImports,
renamePkgQual, renameRawPkgQual,
+ hscRenamePkgQual, hscRenameRawPkgQual,
classifyGREs,
ImportDeclUsage,
) where
@@ -337,7 +338,8 @@ rnImportDecl this_mod
hsc_env <- getTopEnv
unit_env <- hsc_unit_env <$> getTopEnv
- let pkg_qual = renameRawPkgQual unit_env imp_mod_name raw_pkg_qual
+ query <- hscUnitIndexQuery unit_env
+ let pkg_qual = renameRawPkgQual unit_env query imp_mod_name raw_pkg_qual
-- Check for self-import, which confuses the typechecker (#9032)
-- ghc --make rejects self-import cycles already, but batch-mode may not
@@ -447,14 +449,14 @@ rnImportDecl this_mod
-- | Rename raw package imports
-renameRawPkgQual :: UnitEnv -> ModuleName -> RawPkgQual -> PkgQual
-renameRawPkgQual unit_env mn = \case
+renameRawPkgQual :: UnitEnv -> UnitIndexQuery -> ModuleName -> RawPkgQual -> PkgQual
+renameRawPkgQual unit_env query mn = \case
NoRawPkgQual -> NoPkgQual
- RawPkgQual p -> renamePkgQual unit_env mn (Just (sl_fs p))
+ RawPkgQual p -> renamePkgQual unit_env query mn (Just (sl_fs p))
-- | Rename raw package imports
-renamePkgQual :: UnitEnv -> ModuleName -> Maybe FastString -> PkgQual
-renamePkgQual unit_env mn mb_pkg = case mb_pkg of
+renamePkgQual :: UnitEnv -> UnitIndexQuery -> ModuleName -> Maybe FastString -> PkgQual
+renamePkgQual unit_env query mn mb_pkg = case mb_pkg of
Nothing -> NoPkgQual
Just pkg_fs
| Just uid <- homeUnitId <$> ue_homeUnit unit_env
@@ -464,7 +466,7 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of
| Just (uid, _) <- find (fromMaybe False . fmap (== pkg_fs) . snd) home_names
-> ThisPkg uid
- | Just uid <- resolvePackageImport (ue_units unit_env) mn (PackageName pkg_fs)
+ | Just uid <- resolvePackageImport (ue_units unit_env) query mn (PackageName pkg_fs)
-> OtherPkg uid
| otherwise
@@ -482,6 +484,25 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of
hpt_deps :: S.Set UnitId
hpt_deps = homeUnitDepends units
+hscRenameRawPkgQual ::
+ MonadIO m =>
+ HscEnv ->
+ ModuleName ->
+ RawPkgQual ->
+ m PkgQual
+hscRenameRawPkgQual hsc_env name raw = do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ pure (renameRawPkgQual (hsc_unit_env hsc_env) query name raw)
+
+hscRenamePkgQual ::
+ MonadIO m =>
+ HscEnv ->
+ ModuleName ->
+ Maybe FastString ->
+ m PkgQual
+hscRenamePkgQual hsc_env name package = do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ pure (renamePkgQual (hsc_unit_env hsc_env) query name package)
-- | Calculate the 'ImportAvails' induced by an import of a particular
-- interface, but without 'imp_mods'.
=====================================
compiler/GHC/Runtime/Context.hs
=====================================
@@ -26,6 +26,7 @@ import GHC.Runtime.Eval.Types ( IcGlobalRdrEnv(..), Resume )
import GHC.Unit
import GHC.Unit.Env
+import GHC.Unit.State (UnitIndexQuery)
import GHC.Core.FamInstEnv
import GHC.Core.InstEnv
@@ -351,8 +352,8 @@ icInScopeTTs ictxt = filter in_scope_unqualified (ic_tythings ictxt)
]
-- | Get the NamePprCtx function based on the flags and this InteractiveContext
-icNamePprCtx :: UnitEnv -> InteractiveContext -> NamePprCtx
-icNamePprCtx unit_env ictxt = mkNamePprCtx ptc unit_env (icReaderEnv ictxt)
+icNamePprCtx :: UnitEnv -> UnitIndexQuery -> InteractiveContext -> NamePprCtx
+icNamePprCtx unit_env query ictxt = mkNamePprCtx ptc unit_env query (icReaderEnv ictxt)
where ptc = initPromotionTickContext (ic_dflags ictxt)
-- | extendInteractiveContext is called with new TyThings recently defined to update the
=====================================
compiler/GHC/Runtime/Loader.hs
=====================================
@@ -348,7 +348,8 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
let unit_state = ue_units unit_env
let mhome_unit = hsc_home_unit_maybe hsc_env
-- First find the unit the module resides in by searching exposed units and home modules
- found_module <- findPluginModule fc fopts unit_state mhome_unit mod_name
+ query <- hscUnitIndexQuery hsc_env
+ found_module <- findPluginModule fc fopts unit_state query mhome_unit mod_name
case found_module of
Found _ mod -> do
-- Find the exports of the module
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -266,9 +266,11 @@ tcRnModuleTcRnM hsc_env mod_sum
; when (notNull prel_imports) $ do
addDiagnostic TcRnImplicitImportOfPrelude
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+
; -- TODO This is a little skeevy; maybe handle a bit more directly
let { simplifyImport (L _ idecl) =
- ( renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName idecl) (ideclPkgQual idecl)
+ ( renameRawPkgQual (hsc_unit_env hsc_env) query (unLoc $ ideclName idecl) (ideclPkgQual idecl)
, reLoc $ ideclName idecl)
}
; raw_sig_imports <- liftIO
@@ -1996,11 +1998,13 @@ runTcInteractive hsc_env thing_inside
(loadSrcInterface (text "runTcInteractive") m
NotBoot mb_pkg)
+
; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i ->
case i of -- force above: see #15111
IIModule n -> getOrphans n NoPkgQual
- IIDecl i -> getOrphans (unLoc (ideclName i))
- (renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i))
+ IIDecl i -> do
+ qual <- hscRenameRawPkgQual hsc_env (unLoc $ ideclName i) (ideclPkgQual i)
+ getOrphans (unLoc (ideclName i)) qual
; let imports = emptyImportAvails { imp_orphs = orphs }
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -869,7 +869,8 @@ getNamePprCtx
= do { ptc <- initPromotionTickContext <$> getDynFlags
; rdr_env <- getGlobalRdrEnv
; hsc_env <- getTopEnv
- ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env }
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+ ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env }
-- | Like logInfoTcRn, but for user consumption
printForUserTcRn :: SDoc -> TcRn ()
=====================================
compiler/GHC/Types/Name/Ppr.hs
=====================================
@@ -13,6 +13,7 @@ import GHC.Data.FastString
import GHC.Unit
import GHC.Unit.Env
+import GHC.Unit.State (UnitIndexQuery)
import GHC.Types.Name
import GHC.Types.Name.Reader
@@ -68,11 +69,11 @@ with some holes, we should try to give the user some more useful information.
-- | Creates some functions that work out the best ways to format
-- names for the user according to a set of heuristics.
-mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> GlobalRdrEnvX info -> NamePprCtx
-mkNamePprCtx ptc unit_env env
+mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> UnitIndexQuery -> GlobalRdrEnvX info -> NamePprCtx
+mkNamePprCtx ptc unit_env index env
= QueryQualify
(mkQualName env)
- (mkQualModule unit_state home_unit)
+ (mkQualModule unit_state index home_unit)
(mkQualPackage unit_state)
(mkPromTick ptc env)
where
@@ -206,8 +207,8 @@ Side note (int-index):
-- | Creates a function for formatting modules based on two heuristics:
-- (1) if the module is the current module, don't qualify, and (2) if there
-- is only one exposed package which exports this module, don't qualify.
-mkQualModule :: UnitState -> Maybe HomeUnit -> QueryQualifyModule
-mkQualModule unit_state mhome_unit mod
+mkQualModule :: UnitState -> UnitIndexQuery -> Maybe HomeUnit -> QueryQualifyModule
+mkQualModule unit_state index mhome_unit mod
| Just home_unit <- mhome_unit
, isHomeModule home_unit mod = False
@@ -218,7 +219,7 @@ mkQualModule unit_state mhome_unit mod
= False
| otherwise = True
- where lookup = lookupModuleInAllUnits unit_state (moduleName mod)
+ where lookup = lookupModuleInAllUnits unit_state index (moduleName mod)
-- | Creates a function for formatting packages based on two heuristics:
-- (1) don't qualify if the package in question is "main", and (2) only qualify
=====================================
compiler/GHC/Unit/Env.hs
=====================================
@@ -100,6 +100,8 @@ data UnitEnv = UnitEnv
, ue_namever :: !GhcNameVersion
-- ^ GHC name/version (used for dynamic library suffix)
+
+ , ue_index :: !UnitIndex
}
ueEPS :: UnitEnv -> IO ExternalPackageState
@@ -108,12 +110,14 @@ ueEPS = eucEPS . ue_eps
initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv
initUnitEnv cur_unit hug namever platform = do
eps <- initExternalUnitCache
+ ue_index <- newUnitIndex
return $ UnitEnv
{ ue_eps = eps
, ue_home_unit_graph = hug
, ue_current_unit = cur_unit
, ue_platform = platform
, ue_namever = namever
+ , ue_index
}
-- | Get home-unit
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -36,6 +36,7 @@ module GHC.Unit.Finder (
lookupFileCache
) where
+import GHC.Driver.Env (hscUnitIndexQuery)
import GHC.Prelude
import GHC.Platform.Ways
@@ -48,6 +49,7 @@ import GHC.Unit.Module
import GHC.Unit.Home
import GHC.Unit.State
import GHC.Unit.Finder.Types
+import GHC.Unit.State (UnitIndexQuery)
import qualified GHC.Data.ShortText as ST
@@ -67,8 +69,9 @@ import Control.Monad
import Data.Time
import qualified Data.Map as M
import GHC.Driver.Env
- ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env) )
+ ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env), hscUnitIndexQuery )
import GHC.Driver.Config.Finder
+import GHC.Unit.Module.Graph (mgHomeModuleMap, ModuleNameHomeMap)
import qualified Data.Set as Set
import qualified Data.List.NonEmpty as NE
@@ -162,28 +165,36 @@ findImportedModule hsc_env mod pkg_qual =
dflags = hsc_dflags hsc_env
fopts = initFinderOpts dflags
in do
- findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) mhome_unit mod pkg_qual
+ query <- hscUnitIndexQuery hsc_env
+ let home_module_map = mgHomeModuleMap (hsc_mod_graph hsc_env)
+ findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) query home_module_map mhome_unit mod pkg_qual
findImportedModuleNoHsc
:: FinderCache
-> FinderOpts
-> UnitEnv
+ -> UnitIndexQuery
+ -> ModuleNameHomeMap
-> Maybe HomeUnit
-> ModuleName
-> PkgQual
-> IO FindResult
-findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
+findImportedModuleNoHsc fc fopts ue query home_module_map mhome_unit mod_name mb_pkg =
case mb_pkg of
NoPkgQual -> unqual_import
ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import
- | Just os <- lookup uid other_fopts -> home_pkg_import (uid, os)
+ | Just os <- M.lookup uid other_fopts_map -> home_pkg_import (uid, os)
| otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mhome_unit) $$ ppr uid $$ ppr (map fst all_opts))
OtherPkg _ -> pkg_import
where
+ (complete_units, module_name_map) = home_module_map
+ module_home_units = M.findWithDefault Set.empty mod_name module_name_map
+ current_unit_id = homeUnitId <$> mhome_unit
all_opts = case mhome_unit of
- Nothing -> other_fopts
- Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts
+ Nothing -> other_fopts_list
+ Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts_list
+ other_fopts_map = M.fromList other_fopts_list
home_import = case mhome_unit of
Just home_unit -> findHomeModule fc fopts home_unit mod_name
@@ -194,7 +205,7 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
-- If the module is reexported, then look for it as if it was from the perspective
-- of that package which reexports it.
| mod_name `Set.member` finder_reexportedModules opts =
- findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
+ findImportedModuleNoHsc fc opts ue query home_module_map (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
| mod_name `Set.member` finder_hiddenModules opts =
return (mkHomeHidden uid)
| otherwise =
@@ -203,35 +214,44 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
-- Do not be smart and change this to `foldr orIfNotFound home_import hs` as
-- that is not the same!! home_import is first because we need to look within ourselves
-- first before looking at the packages in order.
- any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts)
+ any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts_list)
- pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg
+ pkg_import = findExposedPackageModule fc fopts units query mod_name mb_pkg
unqual_import = any_home_import
`orIfNotFound`
- findExposedPackageModule fc fopts units mod_name NoPkgQual
+ findExposedPackageModule fc fopts units query mod_name NoPkgQual
units = case mhome_unit of
Nothing -> ue_units ue
Just home_unit -> homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue
hpt_deps :: Set.Set UnitId
hpt_deps = homeUnitDepends units
- other_fopts =
+ dep_providers = Set.intersection module_home_units hpt_deps
+ known_other_uids =
+ let providers = maybe dep_providers (\u -> Set.delete u dep_providers) current_unit_id
+ in Set.toList providers
+ unknown_units =
+ let candidates = Set.difference hpt_deps complete_units
+ excluded = maybe dep_providers (\u -> Set.insert u dep_providers) current_unit_id
+ in Set.toList (Set.difference candidates excluded)
+ other_home_uids = known_other_uids ++ unknown_units
+ other_fopts_list =
[ (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))
- | uid <- Set.toList hpt_deps
+ | uid <- other_home_uids
]
-- | Locate a plugin module requested by the user, for a compiler
-- plugin. This consults the same set of exposed packages as
-- 'findImportedModule', unless @-hide-all-plugin-packages@ or
-- @-plugin-package@ are specified.
-findPluginModule :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult
-findPluginModule fc fopts units (Just home_unit) mod_name =
+findPluginModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> Maybe HomeUnit -> ModuleName -> IO FindResult
+findPluginModule fc fopts units query (Just home_unit) mod_name =
findHomeModule fc fopts home_unit mod_name
`orIfNotFound`
- findExposedPluginPackageModule fc fopts units mod_name
-findPluginModule fc fopts units Nothing mod_name =
- findExposedPluginPackageModule fc fopts units mod_name
+ findExposedPluginPackageModule fc fopts units query mod_name
+findPluginModule fc fopts units query Nothing mod_name =
+ findExposedPluginPackageModule fc fopts units query mod_name
-- | Locate a specific 'Module'. The purpose of this function is to
-- create a 'ModLocation' for a given 'Module', that is to find out
@@ -287,15 +307,15 @@ homeSearchCache fc home_unit mod_name do_this = do
let mod = mkModule home_unit mod_name
modLocationCache fc mod do_this
-findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult
-findExposedPackageModule fc fopts units mod_name mb_pkg =
+findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> ModuleName -> PkgQual -> IO FindResult
+findExposedPackageModule fc fopts units query mod_name mb_pkg =
findLookupResult fc fopts
- $ lookupModuleWithSuggestions units mod_name mb_pkg
+ $ lookupModuleWithSuggestions units query mod_name mb_pkg
-findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> IO FindResult
-findExposedPluginPackageModule fc fopts units mod_name =
+findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> ModuleName -> IO FindResult
+findExposedPluginPackageModule fc fopts units query mod_name =
findLookupResult fc fopts
- $ lookupPluginModuleWithSuggestions units mod_name NoPkgQual
+ $ lookupPluginModuleWithSuggestions units query mod_name NoPkgQual
findLookupResult :: FinderCache -> FinderOpts -> LookupResult -> IO FindResult
findLookupResult fc fopts r = case r of
=====================================
compiler/GHC/Unit/Module/Graph.hs
=====================================
@@ -18,6 +18,7 @@ module GHC.Unit.Module.Graph
, mgModSummaries
, mgModSummaries'
, mgLookupModule
+ , ModuleNameHomeMap
, mgHomeModuleMap
, showModMsg
, moduleGraphNodeModule
@@ -154,14 +155,16 @@ instance Outputable ModNodeKeyWithUid where
-- check that the module and its hs-boot agree.
--
-- The graph is not necessarily stored in topologically-sorted order. Use
+type ModuleNameHomeMap = (Set UnitId, Map.Map ModuleName (Set UnitId))
+
-- 'GHC.topSortModuleGraph' and 'GHC.Data.Graph.Directed.flattenSCC' to achieve this.
data ModuleGraph = ModuleGraph
{ mg_mss :: [ModuleGraphNode]
, mg_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
-- A cached transitive dependency calculation so that a lot of work is not
-- repeated whenever the transitive dependencies need to be calculated (for example, hptInstances)
- , mg_home_map :: Map.Map ModuleName (Set UnitId)
- -- ^ For each module name, which home-unit UnitIds define it.
+ , mg_home_map :: ModuleNameHomeMap
+ -- ^ For each module name, which home-unit UnitIds define it together with the set of units for which the listing is complete.
}
-- | Map a function 'f' over all the 'ModSummaries'.
@@ -190,12 +193,20 @@ unionMG a b =
mkTransDeps :: [ModuleGraphNode] -> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mkTransDeps = first graphReachability {- module graph is acyclic -} . moduleGraphNodes False
-mkHomeModuleMap :: [ModuleGraphNode] -> Map.Map ModuleName (Set UnitId)
+mkHomeModuleMap :: [ModuleGraphNode] -> ModuleNameHomeMap
mkHomeModuleMap nodes =
- Map.fromListWith Set.union
- [ (ms_mod_name ms, Set.singleton (ms_unitid ms))
- | ModuleNode _ ms <- nodes
- ]
+ (complete_units, provider_map)
+ where
+ provider_map =
+ Map.fromListWith Set.union
+ [ (ms_mod_name ms, Set.singleton (ms_unitid ms))
+ | ModuleNode _ ms <- nodes
+ ]
+ complete_units =
+ Set.fromList
+ [ ms_unitid ms
+ | ModuleNode _ ms <- nodes
+ ]
mgModSummaries :: ModuleGraph -> [ModSummary]
mgModSummaries mg = [ m | ModuleNode _ m <- mgModSummaries' mg ]
@@ -215,11 +226,11 @@ mgLookupModule ModuleGraph{..} m = listToMaybe $ mapMaybe go mg_mss
= Just ms
go _ = Nothing
-mgHomeModuleMap :: ModuleGraph -> Map.Map ModuleName (Set UnitId)
+mgHomeModuleMap :: ModuleGraph -> ModuleNameHomeMap
mgHomeModuleMap = mg_home_map
emptyMG :: ModuleGraph
-emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing) Map.empty
+emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing) (Set.empty, Map.empty)
isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool
isTemplateHaskellOrQQNonBoot ms =
=====================================
compiler/GHC/Unit/State.hs
=====================================
@@ -1,6 +1,6 @@
-- (c) The University of Glasgow, 2006
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase, OverloadedRecordDot, RecordWildCards #-}
-- | Unit manipulation
module GHC.Unit.State (
@@ -49,6 +49,15 @@ module GHC.Unit.State (
closeUnitDeps',
mayThrowUnitErr,
+ UnitConfig (..),
+ UnitIndex (..),
+ UnitIndexQuery (..),
+ UnitVisibility (..),
+ VisibilityMap,
+ ModuleNameProvidersMap,
+ newUnitIndex,
+ unitIndexQuery,
+
-- * Module hole substitution
ShHoleSubst,
renameHoleUnit,
@@ -121,6 +130,8 @@ import qualified Data.Semigroup as Semigroup
import qualified Data.Set as Set
import GHC.LanguageExtensions
import Control.Applicative
+import Control.Monad.IO.Class (MonadIO (..))
+import Data.IORef (IORef, newIORef, readIORef)
-- ---------------------------------------------------------------------------
-- The Unit state
@@ -577,10 +588,10 @@ searchPackageId pkgstate pid = filter ((pid ==) . unitPackageId)
-- | Find the UnitId which an import qualified by a package import comes from.
-- Compared to 'lookupPackageName', this function correctly accounts for visibility,
-- renaming and thinning.
-resolvePackageImport :: UnitState -> ModuleName -> PackageName -> Maybe UnitId
-resolvePackageImport unit_st mn pn = do
+resolvePackageImport :: UnitState -> UnitIndexQuery -> ModuleName -> PackageName -> Maybe UnitId
+resolvePackageImport unit_st query mn pn = do
-- 1. Find all modules providing the ModuleName (this accounts for visibility/thinning etc)
- providers <- filterUniqMap originVisible <$> lookupUniqMap (moduleNameProvidersMap unit_st) mn
+ providers <- filterUniqMap originVisible <$> query.findOrigin unit_st mn False
-- 2. Get the UnitIds of the candidates
let candidates_uid = concatMap to_uid $ sortOn fst $ nonDetUniqMapToList providers
-- 3. Get the package names of the candidates
@@ -638,14 +649,14 @@ listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state)
-- 'initUnits' can be called again subsequently after updating the
-- 'packageFlags' field of the 'DynFlags', and it will update the
-- 'unitState' in 'DynFlags'.
-initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
-initUnits logger dflags cached_dbs home_units = do
+initUnits :: Logger -> DynFlags -> UnitIndex -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
+initUnits logger dflags index cached_dbs home_units = do
let forceUnitInfoMap (state, _) = unitInfoMap state `seq` ()
(unit_state,dbs) <- withTiming logger (text "initializing unit database")
forceUnitInfoMap
- $ mkUnitState logger (initUnitConfig dflags cached_dbs home_units)
+ $ mkUnitState logger (homeUnitId_ dflags) (initUnitConfig dflags cached_dbs home_units) index
putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map"
FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})
@@ -1021,7 +1032,7 @@ selectPackages prec_map arg pkgs unusable
= let matches = matching arg
(ps,rest) = partition matches pkgs
in if null ps
- then Left (filter (matches.fst) (nonDetEltsUniqMap unusable))
+ then Left (filter (matches . fst) (nonDetEltsUniqMap unusable))
else Right (sortByPreference prec_map ps, rest)
-- | Rename a 'UnitInfo' according to some module instantiation.
@@ -1484,9 +1495,11 @@ validateDatabase cfg pkg_map1 =
mkUnitState
:: Logger
+ -> UnitId
-> UnitConfig
+ -> UnitIndex
-> IO (UnitState,[UnitDatabase UnitId])
-mkUnitState logger cfg = do
+mkUnitState logger unit cfg index = do
{-
Plan.
@@ -1542,15 +1555,9 @@ mkUnitState logger cfg = do
-- if databases have not been provided, read the database flags
raw_dbs <- case unitConfigDBCache cfg of
- Nothing -> readUnitDatabases logger cfg
+ Nothing -> index.readDatabases logger unit cfg
Just dbs -> return dbs
- -- distrust all units if the flag is set
- let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) }
- dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs
- | otherwise = raw_dbs
-
-
-- This, and the other reverse's that you will see, are due to the fact that
-- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order
-- than they are on the command line.
@@ -1561,159 +1568,7 @@ mkUnitState logger cfg = do
let home_unit_deps = selectHomeUnits (unitConfigHomeUnits cfg) hpt_flags
- -- Merge databases together, without checking validity
- (pkg_map1, prec_map) <- mergeDatabases logger dbs
-
- -- Now that we've merged everything together, prune out unusable
- -- packages.
- let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
-
- reportCycles logger sccs
- reportUnusable logger unusable
-
- -- Apply trust flags (these flags apply regardless of whether
- -- or not packages are visible or not)
- pkgs1 <- mayThrowUnitErr
- $ foldM (applyTrustFlag prec_map unusable)
- (nonDetEltsUniqMap pkg_map2) (reverse (unitConfigFlagsTrusted cfg))
- let prelim_pkg_db = mkUnitInfoMap pkgs1
-
- --
- -- Calculate the initial set of units from package databases, prior to any package flags.
- --
- -- Conceptually, we select the latest versions of all valid (not unusable) *packages*
- -- (not units). This is empty if we have -hide-all-packages.
- --
- -- Then we create an initial visibility map with default visibilities for all
- -- exposed, definite units which belong to the latest valid packages.
- --
- let preferLater unit unit' =
- case compareByPreference prec_map unit unit' of
- GT -> unit
- _ -> unit'
- addIfMorePreferable m unit = addToUDFM_C preferLater m (fsPackageName unit) unit
- -- This is the set of maximally preferable packages. In fact, it is a set of
- -- most preferable *units* keyed by package name, which act as stand-ins in
- -- for "a package in a database". We use units here because we don't have
- -- "a package in a database" as a type currently.
- mostPreferablePackageReps = if unitConfigHideAll cfg
- then emptyUDFM
- else foldl' addIfMorePreferable emptyUDFM pkgs1
- -- When exposing units, we want to consider all of those in the most preferable
- -- packages. We can implement that by looking for units that are equi-preferable
- -- with the most preferable unit for package. Being equi-preferable means that
- -- they must be in the same database, with the same version, and the same package name.
- --
- -- We must take care to consider all these units and not just the most
- -- preferable one, otherwise we can end up with problems like #16228.
- mostPreferable u =
- case lookupUDFM mostPreferablePackageReps (fsPackageName u) of
- Nothing -> False
- Just u' -> compareByPreference prec_map u u' == EQ
- vis_map1 = foldl' (\vm p ->
- -- Note: we NEVER expose indefinite packages by
- -- default, because it's almost assuredly not
- -- what you want (no mix-in linking has occurred).
- if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p
- then addToUniqMap vm (mkUnit p)
- UnitVisibility {
- uv_expose_all = True,
- uv_renamings = [],
- uv_package_name = First (Just (fsPackageName p)),
- uv_requirements = emptyUniqMap,
- uv_explicit = Nothing
- }
- else vm)
- emptyUniqMap pkgs1
-
- --
- -- Compute a visibility map according to the command-line flags (-package,
- -- -hide-package). This needs to know about the unusable packages, since if a
- -- user tries to enable an unusable package, we should let them know.
- --
- vis_map2 <- mayThrowUnitErr
- $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
- (unitConfigHideAll cfg) pkgs1)
- vis_map1 other_flags
-
- --
- -- Sort out which packages are wired in. This has to be done last, since
- -- it modifies the unit ids of wired in packages, but when we process
- -- package arguments we need to key against the old versions.
- --
- (pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2
- let pkg_db = mkUnitInfoMap pkgs2
-
- -- Update the visibility map, so we treat wired packages as visible.
- let vis_map = updateVisibilityMap wired_map vis_map2
-
- let hide_plugin_pkgs = unitConfigHideAllPlugins cfg
- plugin_vis_map <-
- case unitConfigFlagsPlugins cfg of
- -- common case; try to share the old vis_map
- [] | not hide_plugin_pkgs -> return vis_map
- | otherwise -> return emptyUniqMap
- _ -> do let plugin_vis_map1
- | hide_plugin_pkgs = emptyUniqMap
- -- Use the vis_map PRIOR to wired in,
- -- because otherwise applyPackageFlag
- -- won't work.
- | otherwise = vis_map2
- plugin_vis_map2
- <- mayThrowUnitErr
- $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
- hide_plugin_pkgs pkgs1)
- plugin_vis_map1
- (reverse (unitConfigFlagsPlugins cfg))
- -- Updating based on wired in packages is mostly
- -- good hygiene, because it won't matter: no wired in
- -- package has a compiler plugin.
- -- TODO: If a wired in package had a compiler plugin,
- -- and you tried to pick different wired in packages
- -- with the plugin flags and the normal flags... what
- -- would happen? I don't know! But this doesn't seem
- -- likely to actually happen.
- return (updateVisibilityMap wired_map plugin_vis_map2)
-
- let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
- | p <- pkgs2
- ]
- -- The explicitUnits accurately reflects the set of units we have turned
- -- on; as such, it also is the only way one can come up with requirements.
- -- The requirement context is directly based off of this: we simply
- -- look for nested unit IDs that are directly fed holes: the requirements
- -- of those units are precisely the ones we need to track
- let explicit_pkgs = [(k, uv_explicit v) | (k, v) <- nonDetUniqMapToList vis_map]
- req_ctx = mapUniqMap (Set.toList)
- $ plusUniqMapListWith Set.union (map uv_requirements (nonDetEltsUniqMap vis_map))
-
-
- --
- -- Here we build up a set of the packages mentioned in -package
- -- flags on the command line; these are called the "preload"
- -- packages. we link these packages in eagerly. The preload set
- -- should contain at least rts & base, which is why we pretend that
- -- the command line contains -package rts & -package base.
- --
- -- NB: preload IS important even for type-checking, because we
- -- need the correct include path to be set.
- --
- let preload1 = nonDetKeysUniqMap (filterUniqMap (isJust . uv_explicit) vis_map)
-
- -- add default preload units if they can be found in the db
- basicLinkedUnits = fmap (RealUnit . Definite)
- $ filter (flip elemUniqMap pkg_db)
- $ unitConfigAutoLink cfg
- preload3 = ordNub $ (basicLinkedUnits ++ preload1)
-
- -- Close the preload packages with their dependencies
- dep_preload <- mayThrowUnitErr
- $ closeUnitDeps pkg_db
- $ zip (map toUnitId preload3) (repeat Nothing)
-
- let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
- mod_map2 = mkUnusableModuleNameProvidersMap unusable
- mod_map = mod_map2 `plusUniqMap` mod_map1
+ (moduleNameProvidersMap, pluginModuleNameProvidersMap, pkg_db, explicit_pkgs, dep_preload, req_ctx, pkgname_map, wired_map) <- index.update logger unit cfg raw_dbs other_flags
-- Force the result to avoid leaking input parameters
let !state = UnitState
@@ -1722,8 +1577,8 @@ mkUnitState logger cfg = do
, homeUnitDepends = home_unit_deps
, unitInfoMap = pkg_db
, preloadClosure = emptyUniqSet
- , moduleNameProvidersMap = mod_map
- , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
+ , moduleNameProvidersMap
+ , pluginModuleNameProvidersMap
, packageNameMap = pkgname_map
, wireMap = wired_map
, unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ]
@@ -1896,6 +1751,263 @@ addListTo = foldl' merge
mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin
mkModMap pkg mod = unitUniqMap (mkModule pkg mod)
+-- -----------------------------------------------------------------------------
+-- Index
+
+data UnitIndexQuery =
+ UnitIndexQuery {
+ findOrigin :: UnitState -> ModuleName -> Bool -> Maybe (UniqMap Module ModuleOrigin),
+ index_all :: UnitState -> ModuleNameProvidersMap
+ }
+
+data UnitIndex =
+ UnitIndex {
+ query :: UnitId -> IO UnitIndexQuery,
+ readDatabases :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId],
+ update ::
+ Logger ->
+ UnitId ->
+ UnitConfig ->
+ [UnitDatabase UnitId] ->
+ [PackageFlag] ->
+ IO (
+ ModuleNameProvidersMap,
+ ModuleNameProvidersMap,
+ UnitInfoMap,
+ [(Unit, Maybe PackageArg)],
+ [UnitId],
+ UniqMap ModuleName [InstantiatedModule],
+ UniqFM PackageName UnitId,
+ WiringMap
+ )
+ }
+
+unitIndexQuery ::
+ MonadIO m =>
+ UnitId ->
+ UnitIndex ->
+ m UnitIndexQuery
+unitIndexQuery unit index = liftIO (index.query unit)
+
+data UnitIndexBackend =
+ UnitIndexBackend {
+ moduleNameProviders :: !ModuleNameProvidersMap,
+ pluginModuleNameProviders :: !ModuleNameProvidersMap
+ }
+
+newUnitIndexBackend :: UnitIndexBackend
+newUnitIndexBackend =
+ UnitIndexBackend {
+ moduleNameProviders = mempty,
+ pluginModuleNameProviders = mempty
+ }
+
+queryFindOriginDefault ::
+ UnitIndexBackend ->
+ UnitState ->
+ ModuleName ->
+ Bool ->
+ Maybe (UniqMap Module ModuleOrigin)
+queryFindOriginDefault _ UnitState {moduleNameProvidersMap, pluginModuleNameProvidersMap} name plugins =
+ lookupUniqMap source name
+ where
+ source = if plugins then pluginModuleNameProvidersMap else moduleNameProvidersMap
+
+newUnitIndexQuery ::
+ MonadIO m =>
+ IORef UnitIndexBackend ->
+ UnitId ->
+ m UnitIndexQuery
+newUnitIndexQuery ref _ = do
+ state <- liftIO $ readIORef ref
+ pure UnitIndexQuery {
+ findOrigin = queryFindOriginDefault state,
+ index_all = \ s -> s.moduleNameProvidersMap
+ }
+
+updateIndexDefault ::
+ Logger ->
+ UnitId ->
+ UnitConfig ->
+ [UnitDatabase UnitId] ->
+ [PackageFlag] ->
+ IO (ModuleNameProvidersMap, ModuleNameProvidersMap, UnitInfoMap, [(Unit, Maybe PackageArg)], [UnitId], UniqMap ModuleName [InstantiatedModule], UniqFM PackageName UnitId, WiringMap)
+updateIndexDefault logger _ cfg raw_dbs other_flags = do
+
+ -- distrust all units if the flag is set
+ let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) }
+ dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs
+ | otherwise = raw_dbs
+
+
+ -- Merge databases together, without checking validity
+ (pkg_map1, prec_map) <- mergeDatabases logger dbs
+
+ -- Now that we've merged everything together, prune out unusable
+ -- packages.
+ let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
+
+ reportCycles logger sccs
+ reportUnusable logger unusable
+
+ -- Apply trust flags (these flags apply regardless of whether
+ -- or not packages are visible or not)
+ pkgs1 <- mayThrowUnitErr
+ $ foldM (applyTrustFlag prec_map unusable)
+ (nonDetEltsUniqMap pkg_map2) (reverse (unitConfigFlagsTrusted cfg))
+ let prelim_pkg_db = mkUnitInfoMap pkgs1
+
+ --
+ -- Calculate the initial set of units from package databases, prior to any package flags.
+ --
+ -- Conceptually, we select the latest versions of all valid (not unusable) *packages*
+ -- (not units). This is empty if we have -hide-all-packages.
+ --
+ -- Then we create an initial visibility map with default visibilities for all
+ -- exposed, definite units which belong to the latest valid packages.
+ --
+ let preferLater unit unit' =
+ case compareByPreference prec_map unit unit' of
+ GT -> unit
+ _ -> unit'
+ addIfMorePreferable m unit = addToUDFM_C preferLater m (fsPackageName unit) unit
+ -- This is the set of maximally preferable packages. In fact, it is a set of
+ -- most preferable *units* keyed by package name, which act as stand-ins in
+ -- for "a package in a database". We use units here because we don't have
+ -- "a package in a database" as a type currently.
+ mostPreferablePackageReps = if unitConfigHideAll cfg
+ then emptyUDFM
+ else foldl' addIfMorePreferable emptyUDFM pkgs1
+ -- When exposing units, we want to consider all of those in the most preferable
+ -- packages. We can implement that by looking for units that are equi-preferable
+ -- with the most preferable unit for package. Being equi-preferable means that
+ -- they must be in the same database, with the same version, and the same package name.
+ --
+ -- We must take care to consider all these units and not just the most
+ -- preferable one, otherwise we can end up with problems like #16228.
+ mostPreferable u =
+ case lookupUDFM mostPreferablePackageReps (fsPackageName u) of
+ Nothing -> False
+ Just u' -> compareByPreference prec_map u u' == EQ
+ vis_map1 = foldl' (\vm p ->
+ -- Note: we NEVER expose indefinite packages by
+ -- default, because it's almost assuredly not
+ -- what you want (no mix-in linking has occurred).
+ if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p
+ then addToUniqMap vm (mkUnit p)
+ UnitVisibility {
+ uv_expose_all = True,
+ uv_renamings = [],
+ uv_package_name = First (Just (fsPackageName p)),
+ uv_requirements = emptyUniqMap,
+ uv_explicit = Nothing
+ }
+ else vm)
+ emptyUniqMap pkgs1
+
+ --
+ -- Compute a visibility map according to the command-line flags (-package,
+ -- -hide-package). This needs to know about the unusable packages, since if a
+ -- user tries to enable an unusable package, we should let them know.
+ --
+ vis_map2 <- mayThrowUnitErr
+ $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
+ (unitConfigHideAll cfg) pkgs1)
+ vis_map1 other_flags
+
+ --
+ -- Sort out which packages are wired in. This has to be done last, since
+ -- it modifies the unit ids of wired in packages, but when we process
+ -- package arguments we need to key against the old versions.
+ --
+ (pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2
+ let pkg_db = mkUnitInfoMap pkgs2
+
+ -- Update the visibility map, so we treat wired packages as visible.
+ let vis_map = updateVisibilityMap wired_map vis_map2
+
+ let hide_plugin_pkgs = unitConfigHideAllPlugins cfg
+ plugin_vis_map <-
+ case unitConfigFlagsPlugins cfg of
+ -- common case; try to share the old vis_map
+ [] | not hide_plugin_pkgs -> return vis_map
+ | otherwise -> return emptyUniqMap
+ _ -> do let plugin_vis_map1
+ | hide_plugin_pkgs = emptyUniqMap
+ -- Use the vis_map PRIOR to wired in,
+ -- because otherwise applyPackageFlag
+ -- won't work.
+ | otherwise = vis_map2
+ plugin_vis_map2
+ <- mayThrowUnitErr
+ $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
+ hide_plugin_pkgs pkgs1)
+ plugin_vis_map1
+ (reverse (unitConfigFlagsPlugins cfg))
+ -- Updating based on wired in packages is mostly
+ -- good hygiene, because it won't matter: no wired in
+ -- package has a compiler plugin.
+ -- TODO: If a wired in package had a compiler plugin,
+ -- and you tried to pick different wired in packages
+ -- with the plugin flags and the normal flags... what
+ -- would happen? I don't know! But this doesn't seem
+ -- likely to actually happen.
+ return (updateVisibilityMap wired_map plugin_vis_map2)
+
+ let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
+ | p <- pkgs2
+ ]
+ -- The explicitUnits accurately reflects the set of units we have turned
+ -- on; as such, it also is the only way one can come up with requirements.
+ -- The requirement context is directly based off of this: we simply
+ -- look for nested unit IDs that are directly fed holes: the requirements
+ -- of those units are precisely the ones we need to track
+ let explicit_pkgs = [(k, uv_explicit v) | (k, v) <- nonDetUniqMapToList vis_map]
+ req_ctx = mapUniqMap (Set.toList)
+ $ plusUniqMapListWith Set.union (map uv_requirements (nonDetEltsUniqMap vis_map))
+
+
+ --
+ -- Here we build up a set of the packages mentioned in -package
+ -- flags on the command line; these are called the "preload"
+ -- packages. we link these packages in eagerly. The preload set
+ -- should contain at least rts & base, which is why we pretend that
+ -- the command line contains -package rts & -package base.
+ --
+ -- NB: preload IS important even for type-checking, because we
+ -- need the correct include path to be set.
+ --
+ let preload1 = nonDetKeysUniqMap (filterUniqMap (isJust . uv_explicit) vis_map)
+
+ -- add default preload units if they can be found in the db
+ basicLinkedUnits = fmap (RealUnit . Definite)
+ $ filter (flip elemUniqMap pkg_db)
+ $ unitConfigAutoLink cfg
+ preload3 = ordNub $ (basicLinkedUnits ++ preload1)
+
+ -- Close the preload packages with their dependencies
+ dep_preload <- mayThrowUnitErr
+ $ closeUnitDeps pkg_db
+ $ zip (map toUnitId preload3) (repeat Nothing)
+
+ let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
+ mod_map2 = mkUnusableModuleNameProvidersMap unusable
+ mod_map = mod_map2 `plusUniqMap` mod_map1
+ pluginModuleNameProviders = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
+ pure (mod_map, pluginModuleNameProviders, pkg_db, explicit_pkgs, dep_preload, req_ctx, pkgname_map, wired_map)
+
+readDatabasesDefault :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId]
+readDatabasesDefault logger _ cfg =
+ readUnitDatabases logger cfg
+
+newUnitIndex :: MonadIO m => m UnitIndex
+newUnitIndex = do
+ ref <- liftIO $ newIORef newUnitIndexBackend
+ pure UnitIndex {
+ query = newUnitIndexQuery ref,
+ readDatabases = readDatabasesDefault,
+ update = updateIndexDefault
+ }
-- -----------------------------------------------------------------------------
-- Package Utils
@@ -1903,10 +2015,11 @@ mkModMap pkg mod = unitUniqMap (mkModule pkg mod)
-- | Takes a 'ModuleName', and if the module is in any package returns
-- list of modules which take that name.
lookupModuleInAllUnits :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> [(Module, UnitInfo)]
-lookupModuleInAllUnits pkgs m
- = case lookupModuleWithSuggestions pkgs m NoPkgQual of
+lookupModuleInAllUnits pkgs query m
+ = case lookupModuleWithSuggestions pkgs query m NoPkgQual of
LookupFound a b -> [(a,fst b)]
LookupMultiple rs -> map f rs
where f (m,_) = (m, expectJust "lookupModule" (lookupUnit pkgs
@@ -1933,18 +2046,24 @@ data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin
| SuggestHidden ModuleName Module ModuleOrigin
lookupModuleWithSuggestions :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> PkgQual
-> LookupResult
-lookupModuleWithSuggestions pkgs
- = lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs)
+lookupModuleWithSuggestions pkgs query name
+ = lookupModuleWithSuggestions' pkgs query name False
-- | The package which the module **appears** to come from, this could be
-- the one which reexports the module from it's original package. This function
-- is currently only used for -Wunused-packages
-lookupModulePackage :: UnitState -> ModuleName -> PkgQual -> Maybe [UnitInfo]
-lookupModulePackage pkgs mn mfs =
- case lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs) mn mfs of
+lookupModulePackage ::
+ UnitState ->
+ UnitIndexQuery ->
+ ModuleName ->
+ PkgQual ->
+ Maybe [UnitInfo]
+lookupModulePackage pkgs query mn mfs =
+ case lookupModuleWithSuggestions' pkgs query mn False mfs of
LookupFound _ (orig_unit, origin) ->
case origin of
ModOrigin {fromOrigUnit, fromExposedReexport} ->
@@ -1960,19 +2079,21 @@ lookupModulePackage pkgs mn mfs =
_ -> Nothing
lookupPluginModuleWithSuggestions :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> PkgQual
-> LookupResult
-lookupPluginModuleWithSuggestions pkgs
- = lookupModuleWithSuggestions' pkgs (pluginModuleNameProvidersMap pkgs)
+lookupPluginModuleWithSuggestions pkgs query name
+ = lookupModuleWithSuggestions' pkgs query name True
lookupModuleWithSuggestions' :: UnitState
- -> ModuleNameProvidersMap
+ -> UnitIndexQuery
-> ModuleName
+ -> Bool
-> PkgQual
-> LookupResult
-lookupModuleWithSuggestions' pkgs mod_map m mb_pn
- = case lookupUniqMap mod_map m of
+lookupModuleWithSuggestions' pkgs query m onlyPlugins mb_pn
+ = case query.findOrigin pkgs m onlyPlugins of
Nothing -> LookupNotFound suggestions
Just xs ->
case foldl' classify ([],[],[], []) (sortOn fst $ nonDetUniqMapToList xs) of
@@ -2033,16 +2154,16 @@ lookupModuleWithSuggestions' pkgs mod_map m mb_pn
all_mods :: [(String, ModuleSuggestion)] -- All modules
all_mods = sortBy (comparing fst) $
[ (moduleNameString m, suggestion)
- | (m, e) <- nonDetUniqMapToList (moduleNameProvidersMap pkgs)
+ | (m, e) <- nonDetUniqMapToList (query.index_all pkgs)
, suggestion <- map (getSuggestion m) (nonDetUniqMapToList e)
]
getSuggestion name (mod, origin) =
(if originVisible origin then SuggestVisible else SuggestHidden)
name mod origin
-listVisibleModuleNames :: UnitState -> [ModuleName]
-listVisibleModuleNames state =
- map fst (filter visible (nonDetUniqMapToList (moduleNameProvidersMap state)))
+listVisibleModuleNames :: UnitState -> UnitIndexQuery -> [ModuleName]
+listVisibleModuleNames unit_state query =
+ map fst (filter visible (nonDetUniqMapToList (query.index_all unit_state)))
where visible (_, ms) = anyUniqMap originVisible ms
-- | Takes a list of UnitIds (and their "parent" dependency, used for error
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -3695,19 +3695,21 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000
completeModule = wrapIdentCompleterMod $ \w -> do
hsc_env <- GHC.getSession
- let pkg_mods = allVisibleModules (hsc_units hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let pkg_mods = allVisibleModules (hsc_units hsc_env) query
loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
return $ filter (w `isPrefixOf`)
$ map (showPpr (hsc_dflags hsc_env)) $ loaded_mods ++ pkg_mods
completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
hsc_env <- GHC.getSession
+ query <- liftIO $ hscUnitIndexQuery hsc_env
modules <- case m of
Just '-' -> do
imports <- GHC.getContext
return $ map iiModuleName imports
_ -> do
- let pkg_mods = allVisibleModules (hsc_units hsc_env)
+ let pkg_mods = allVisibleModules (hsc_units hsc_env) query
loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
return $ loaded_mods ++ pkg_mods
return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) modules
@@ -3775,8 +3777,8 @@ wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing wor
-- | Return a list of visible module names for autocompletion.
-- (NB: exposed != visible)
-allVisibleModules :: UnitState -> [ModuleName]
-allVisibleModules unit_state = listVisibleModuleNames unit_state
+allVisibleModules :: UnitState -> UnitIndexQuery -> [ModuleName]
+allVisibleModules us query = listVisibleModuleNames us query
completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
completeIdentifier
=====================================
ghc/GHCi/UI/Monad.hs
=====================================
@@ -374,10 +374,11 @@ printForUserGlobalRdrEnv mb_rdr_env doc = do
where
mkNamePprCtxFromGlobalRdrEnv _ Nothing = GHC.getNamePprCtx
mkNamePprCtxFromGlobalRdrEnv dflags (Just rdr_env) =
- withSession $ \ hsc_env ->
+ withSession $ \ hsc_env -> do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
let unit_env = hsc_unit_env hsc_env
ptc = initPromotionTickContext dflags
- in return $ Ppr.mkNamePprCtx ptc unit_env rdr_env
+ return $ Ppr.mkNamePprCtx ptc unit_env query rdr_env
printForUser :: GhcMonad m => SDoc -> m ()
printForUser doc = do
=====================================
ghc/Main.hs
=====================================
@@ -844,7 +844,8 @@ initMulti unitArgsFiles = do
let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
hue_flags = homeUnitEnv_dflags homeUnitEnv
dflags = homeUnitEnv_dflags homeUnitEnv
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units
+ index = hscUnitIndex hsc_env
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags index cached_unit_dbs home_units
updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
pure $ HomeUnitEnv
@@ -859,7 +860,7 @@ initMulti unitArgsFiles = do
let dflags = homeUnitEnv_dflags $ unitEnv_lookup mainUnitId home_unit_graph
unitEnv <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags))
- let final_hsc_env = hsc_env { hsc_unit_env = unitEnv }
+ let final_hsc_env = hsc_env { hsc_unit_env = unitEnv {ue_index = hscUnitIndex hsc_env} }
GHC.setSession final_hsc_env
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e124952c65fe2ebe69f63885662951…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e124952c65fe2ebe69f63885662951…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/torsten.schmits/unit-index-debug] 9 commits: Don't call implicitRequirementsShallow
by Torsten Schmits (＠torsten.schmits) 06 Dec '25
by Torsten Schmits (＠torsten.schmits) 06 Dec '25
06 Dec '25
Torsten Schmits pushed to branch wip/torsten.schmits/unit-index-debug at Glasgow Haskell Compiler / GHC
Commits:
532fab17 by Matthew Pickering at 2025-12-05T23:48:35+01:00
Don't call implicitRequirementsShallow
- - - - -
d954cea2 by Ben Gamari at 2025-12-05T23:48:36+01:00
compiler: Fix CPP guards around ghc_unique_counter64
The `ghc_unique_counter64` symbol was introduced in the RTS in the
64-bit unique refactor (!10568) which has been backported to %9.6.7 and
%9.8.4. Update the CPP to reflect this.
Fixes #25576.
- - - - -
12f26755 by Matthew Pickering at 2025-12-05T23:48:37+01:00
Use ModuleGraph for cache
- - - - -
55234fcd by Matthew Pickering at 2025-12-05T23:48:38+01:00
OsPath for Map
- - - - -
09f11c20 by Matthew Pickering at 2025-12-05T23:48:39+01:00
Set hpt deps
- - - - -
94306f54 by Matthew Pickering at 2025-12-05T23:48:40+01:00
HomeUnitMap
- - - - -
ea4cff65 by Torsten Schmits at 2025-12-05T23:48:40+01:00
WIP: unit index
- - - - -
1e8926d7 by Matthew Pickering at 2025-12-05T23:48:40+01:00
Use a name provider map for home packages
- - - - -
e124952c by Torsten Schmits at 2025-12-05T23:48:40+01:00
disable home unit closure check
- - - - -
27 changed files:
- compiler/GHC.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Runtime/Context.hs
- compiler/GHC/Runtime/Loader.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/Name/Ppr.hs
- compiler/GHC/Unit/Env.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Module/Graph.hs
- compiler/GHC/Unit/State.hs
- compiler/cbits/genSym.c
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Monad.hs
- ghc/Main.hs
- testsuite/tests/ghc-api/downsweep/OldModLocation.hs
- testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -341,7 +341,7 @@ import GHC.Builtin.Types.Prim ( alphaTyVars )
import GHC.Data.StringBuffer
import GHC.Data.FastString
import qualified GHC.LanguageExtensions as LangExt
-import GHC.Rename.Names (renamePkgQual, renameRawPkgQual, gresFromAvails)
+import GHC.Rename.Names (gresFromAvails, hscRenamePkgQual, hscRenameRawPkgQual)
import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
import GHC.Tc.Types
@@ -625,7 +625,8 @@ setUnitDynFlagsNoCheck uid dflags1 = do
let old_hue = ue_findHomeUnitEnv uid (hsc_unit_env hsc_env)
let cached_unit_dbs = homeUnitEnv_unit_dbs old_hue
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs (hsc_all_home_unit_ids hsc_env)
+ index <- hscUnitIndex <$> getSession
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 index cached_unit_dbs (hsc_all_home_unit_ids hsc_env)
updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants
let upd hue =
@@ -760,6 +761,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
then do
-- additionally, set checked dflags so we don't lose fixes
old_unit_env <- ue_setFlags dflags0 . hsc_unit_env <$> getSession
+ ue_index <- hscUnitIndex <$> getSession
home_unit_graph <- forM (ue_home_unit_graph old_unit_env) $ \homeUnitEnv -> do
let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
@@ -767,7 +769,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
old_hpt = homeUnitEnv_hpt homeUnitEnv
home_units = unitEnv_keys (ue_home_unit_graph old_unit_env)
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags ue_index cached_unit_dbs home_units
updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
pure HomeUnitEnv
@@ -785,6 +787,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
, ue_home_unit_graph = home_unit_graph
, ue_current_unit = ue_currentUnit old_unit_env
, ue_eps = ue_eps old_unit_env
+ , ue_index
}
modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env }
else modifySession (hscSetFlags dflags0)
@@ -1379,7 +1382,8 @@ getInsts = withSession $ \hsc_env ->
getNamePprCtx :: GhcMonad m => m NamePprCtx
getNamePprCtx = withSession $ \hsc_env -> do
- return $ icNamePprCtx (hsc_unit_env hsc_env) (hsc_IC hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ return $ icNamePprCtx (hsc_unit_env hsc_env) query (hsc_IC hsc_env)
-- | Container for information about a 'Module'.
data ModuleInfo = ModuleInfo {
@@ -1474,7 +1478,8 @@ mkNamePprCtxForModule ::
ModuleInfo ->
m NamePprCtx
mkNamePprCtxForModule mod minf = withSession $ \hsc_env -> do
- let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (availsToGlobalRdrEnv hsc_env mod (minf_exports minf))
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (availsToGlobalRdrEnv hsc_env mod (minf_exports minf))
ptc = initPromotionTickContext (hsc_dflags hsc_env)
return name_ppr_ctx
@@ -1711,10 +1716,10 @@ modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc d
parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))
renamePkgQualM :: GhcMonad m => ModuleName -> Maybe FastString -> m PkgQual
-renamePkgQualM mn p = withSession $ \hsc_env -> pure (renamePkgQual (hsc_unit_env hsc_env) mn p)
+renamePkgQualM mn p = withSession $ \hsc_env -> hscRenamePkgQual hsc_env mn p
renameRawPkgQualM :: GhcMonad m => ModuleName -> RawPkgQual -> m PkgQual
-renameRawPkgQualM mn p = withSession $ \hsc_env -> pure (renameRawPkgQual (hsc_unit_env hsc_env) mn p)
+renameRawPkgQualM mn p = withSession $ \hsc_env -> hscRenameRawPkgQual hsc_env mn p
-- | Like 'findModule', but differs slightly when the module refers to
-- a source file, and the file has not been loaded via 'load'. In
@@ -1738,7 +1743,8 @@ lookupQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do
let units = hsc_units hsc_env
let dflags = hsc_dflags hsc_env
let fopts = initFinderOpts dflags
- res <- findExposedPackageModule fc fopts units mod_name NoPkgQual
+ query <- hscUnitIndexQuery hsc_env
+ res <- findExposedPackageModule fc fopts units query mod_name NoPkgQual
case res of
Found _ m -> return m
err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err
=====================================
compiler/GHC/Core/Opt/Pipeline.hs
=====================================
@@ -78,6 +78,8 @@ core2core hsc_env guts@(ModGuts { mg_module = mod
, mg_rdr_env = rdr_env })
= do { let builtin_passes = getCoreToDo dflags hpt_rule_base extra_vars
uniq_tag = 's'
+ ; query <- hscUnitIndexQuery hsc_env
+ ; let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env
; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_tag mod
name_ppr_ctx loc $
@@ -100,7 +102,6 @@ core2core hsc_env guts@(ModGuts { mg_module = mod
home_pkg_rules = hptRules hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod
, gwib_isBoot = NotBoot })
hpt_rule_base = mkRuleBase home_pkg_rules
- name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env
ptc = initPromotionTickContext dflags
-- mod: get the module out of the current HscEnv so we can retrieve it from the monad.
-- This is very convienent for the users of the monad (e.g. plugins do not have to
@@ -459,6 +460,7 @@ doCorePass pass guts = do
dflags <- getDynFlags
us <- getUniqueSupplyM
p_fam_env <- getPackageFamInstEnv
+ query <- liftIO $ hscUnitIndexQuery hsc_env
let platform = targetPlatform dflags
let fam_envs = (p_fam_env, mg_fam_inst_env guts)
let updateBinds f = return $ guts { mg_binds = f (mg_binds guts) }
@@ -471,6 +473,7 @@ doCorePass pass guts = do
mkNamePprCtx
(initPromotionTickContext dflags)
(hsc_unit_env hsc_env)
+ query
rdr_env
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -429,6 +429,7 @@ addUnit u = do
logger <- getLogger
let dflags0 = hsc_dflags hsc_env
let old_unit_env = hsc_unit_env hsc_env
+ ue_index = hscUnitIndex hsc_env
newdbs <- case ue_unit_dbs old_unit_env of
Nothing -> panic "addUnit: called too early"
Just dbs ->
@@ -437,7 +438,7 @@ addUnit u = do
, unitDatabaseUnits = [u]
}
in return (dbs ++ [newdb]) -- added at the end because ordering matters
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs) (hsc_all_home_unit_ids hsc_env)
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 ue_index (Just newdbs) (hsc_all_home_unit_ids hsc_env)
-- update platform constants
dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
@@ -452,6 +453,7 @@ addUnit u = do
(homeUnitId home_unit)
(mkHomeUnitEnv dflags (ue_hpt old_unit_env) (Just home_unit))
, ue_eps = ue_eps old_unit_env
+ , ue_index
}
setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env }
@@ -870,6 +872,8 @@ hsModuleToModSummary home_keys pn hsc_src modname
hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+
-- Also copied from 'getImports'
let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps
@@ -882,7 +886,7 @@ hsModuleToModSummary home_keys pn hsc_src modname
implicit_imports = mkPrelImports modname loc
implicit_prelude imps
- rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) modname
+ rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query modname
convImport (L _ i) = (rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i)
extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname
=====================================
compiler/GHC/Driver/Env.hs
=====================================
@@ -7,6 +7,8 @@ module GHC.Driver.Env
, hsc_home_unit
, hsc_home_unit_maybe
, hsc_units
+ , hscUnitIndex
+ , hscUnitIndexQuery
, hsc_HPT
, hsc_HUE
, hsc_HUG
@@ -58,6 +60,7 @@ import GHC.Unit.Module.ModDetails
import GHC.Unit.Home.ModInfo
import GHC.Unit.Env
import GHC.Unit.External
+import GHC.Unit.State (UnitIndex, UnitIndexQuery, unitIndexQuery)
import GHC.Core ( CoreRule )
import GHC.Core.FamInstEnv
@@ -118,6 +121,12 @@ hsc_home_unit_maybe = ue_homeUnit . hsc_unit_env
hsc_units :: HasDebugCallStack => HscEnv -> UnitState
hsc_units = ue_units . hsc_unit_env
+hscUnitIndex :: HscEnv -> UnitIndex
+hscUnitIndex = ue_index . hsc_unit_env
+
+hscUnitIndexQuery :: HscEnv -> IO UnitIndexQuery
+hscUnitIndexQuery = unitIndexQuery . hscUnitIndex
+
hsc_HPT :: HscEnv -> HomePackageTable
hsc_HPT = ue_hpt . hsc_unit_env
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -2665,9 +2665,10 @@ hscTidy hsc_env guts = do
$! {-# SCC "CoreTidy" #-} tidyProgram opts guts
-- post tidy pretty-printing and linting...
+ query <- hscUnitIndexQuery hsc_env
let tidy_rules = md_rules details
let all_tidy_binds = cg_binds cgguts
- let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (mg_rdr_env guts)
+ let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (mg_rdr_env guts)
ptc = initPromotionTickContext (hsc_dflags hsc_env)
endPassHscEnvIO hsc_env name_ppr_ctx CoreTidy all_tidy_binds tidy_rules
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -114,6 +114,8 @@ import Data.Either ( rights, partitionEithers, lefts )
import qualified Data.Map as Map
import qualified Data.Set as Set
+import GHC.Data.OsPath (OsPath)
+import qualified GHC.Data.OsPath as OsPath
import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask )
import qualified GHC.Conc as CC
import Control.Concurrent.MVar
@@ -146,6 +148,7 @@ import GHC.Utils.Constants
import GHC.Types.Unique.DFM (udfmRestrictKeysSet)
import GHC.Types.Unique
import GHC.Iface.Errors.Types
+import GHC.Unit.State (UnitIndexQuery)
import qualified GHC.Data.Word64Set as W
import GHC.Data.Graph.Directed.Reachability
@@ -188,12 +191,13 @@ depanalE excluded_mods allow_dup_roots = do
if isEmptyMessages errs
then do
hsc_env <- getSession
+ query <- liftIO $ hscUnitIndexQuery hsc_env
let one_unit_messages get_mod_errs k hue = do
errs <- get_mod_errs
unknown_module_err <- warnUnknownModules (hscSetActiveUnitId k hsc_env) (homeUnitEnv_dflags hue) mod_graph
let unused_home_mod_err = warnMissingHomeModules (homeUnitEnv_dflags hue) (hsc_targets hsc_env) mod_graph
- unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) (homeUnitEnv_dflags hue) mod_graph
+ unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) query (homeUnitEnv_dflags hue) mod_graph
return $ errs `unionMessages` unused_home_mod_err
@@ -245,7 +249,7 @@ depanalPartial excluded_mods allow_dup_roots = do
liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env)
(errs, graph_nodes) <- liftIO $ downsweep
- hsc_env (mgModSummaries old_graph)
+ hsc_env (mgModSummaries old_graph) (Just old_graph)
excluded_mods allow_dup_roots
let
mod_graph = mkModuleGraph graph_nodes
@@ -511,15 +515,15 @@ loadWithCache cache diag_wrapper how_much = do
-- actually loaded packages. All the packages, specified on command line,
-- but never loaded, are probably unused dependencies.
-warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages
-warnUnusedPackages us dflags mod_graph =
+warnUnusedPackages :: UnitState -> UnitIndexQuery -> DynFlags -> ModuleGraph -> DriverMessages
+warnUnusedPackages us query dflags mod_graph =
let diag_opts = initDiagOpts dflags
home_mod_sum = filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph)
-- Only need non-source imports here because SOURCE imports are always HPT
loadedPackages = concat $
- mapMaybe (\(fs, mn) -> lookupModulePackage us (unLoc mn) fs)
+ mapMaybe (\(fs, mn) -> lookupModulePackage us query (unLoc mn) fs)
$ concatMap ms_imps home_mod_sum
any_import_ghc_prim = any ms_ghc_prim_import home_mod_sum
@@ -1539,6 +1543,10 @@ warnUnnecessarySourceImports sccs = do
-- an import of this module mean.
type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModSummary]
+moduleGraphNodeMap :: ModuleGraph -> M.Map NodeKey ModuleGraphNode
+moduleGraphNodeMap graph =
+ M.fromList [(mkNodeKey node, node) | node <- mgModSummaries' graph]
+
-----------------------------------------------------------------------------
--
-- | Downsweep (dependency analysis)
@@ -1557,6 +1565,8 @@ type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either Driv
downsweep :: HscEnv
-> [ModSummary]
-- ^ Old summaries
+ -> Maybe ModuleGraph
+ -- ^ Existing module graph to reuse cached nodes from
-> [ModuleName] -- Ignore dependencies on these; treat
-- them as if they were package modules
-> Bool -- True <=> allow multiple targets to have
@@ -1566,10 +1576,10 @@ downsweep :: HscEnv
-- The non-error elements of the returned list all have distinct
-- (Modules, IsBoot) identifiers, unless the Bool is true in
-- which case there can be repeats
-downsweep hsc_env old_summaries excl_mods allow_dup_roots = do
+downsweep hsc_env old_summaries old_graph excl_mods allow_dup_roots = do
n_jobs <- mkWorkerLimit (hsc_dflags hsc_env)
new <- rootSummariesParallel n_jobs hsc_env summary
- downsweep_imports hsc_env old_summary_map excl_mods allow_dup_roots new
+ downsweep_imports hsc_env old_summary_map old_graph excl_mods allow_dup_roots new
where
summary = getRootSummary excl_mods old_summary_map
@@ -1578,22 +1588,23 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots = do
-- file was used in.
-- Reuse these if we can because the most expensive part of downsweep is
-- reading the headers.
- old_summary_map :: M.Map (UnitId, FilePath) ModSummary
+ old_summary_map :: M.Map (UnitId, OsPath) ModSummary
old_summary_map =
- M.fromList [((ms_unitid ms, msHsFilePath ms), ms) | ms <- old_summaries]
+ M.fromList [((ms_unitid ms, OsPath.unsafeEncodeUtf (msHsFilePath ms)), ms) | ms <- old_summaries]
downsweep_imports :: HscEnv
- -> M.Map (UnitId, FilePath) ModSummary
+ -> M.Map (UnitId, OsPath) ModSummary
+ -> Maybe ModuleGraph
-> [ModuleName]
-> Bool
-> ([(UnitId, DriverMessages)], [ModSummary])
-> IO ([DriverMessages], [ModuleGraphNode])
-downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, rootSummariesOk)
+downsweep_imports hsc_env old_summaries old_graph excl_mods allow_dup_roots (root_errs, rootSummariesOk)
= do
let root_map = mkRootMap rootSummariesOk
checkDuplicates root_map
- (deps, map0) <- loopSummaries rootSummariesOk (M.empty, root_map)
- let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env)
+ let done0 = maybe M.empty moduleGraphNodeMap old_graph
+ (deps, map0) <- loopSummaries rootSummariesOk (done0, root_map)
let unit_env = hsc_unit_env hsc_env
let tmpfs = hsc_tmpfs hsc_env
@@ -1603,7 +1614,7 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro
(other_errs, unit_nodes) = partitionEithers $ unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] (hsc_HUG hsc_env)
all_nodes = downsweep_nodes ++ unit_nodes
all_errs = all_root_errs ++ downsweep_errs ++ other_errs
- all_root_errs = closure_errs ++ map snd root_errs
+ all_root_errs = map snd root_errs
-- if we have been passed -fno-code, we enable code generation
-- for dependencies of modules that have -XTemplateHaskell,
@@ -1723,7 +1734,7 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro
getRootSummary ::
[ModuleName] ->
- M.Map (UnitId, FilePath) ModSummary ->
+ M.Map (UnitId, OsPath) ModSummary ->
HscEnv ->
Target ->
IO (Either (UnitId, DriverMessages) ModSummary)
@@ -2069,7 +2080,7 @@ mkRootMap summaries = Map.fromListWith (flip (++))
summariseFile
:: HscEnv
-> HomeUnit
- -> M.Map (UnitId, FilePath) ModSummary -- old summaries
+ -> M.Map (UnitId, OsPath) ModSummary -- old summaries
-> FilePath -- source file name
-> Maybe Phase -- start phase
-> Maybe (StringBuffer,UTCTime)
@@ -2078,7 +2089,7 @@ summariseFile
summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf
-- we can use a cached summary if one is available and the
-- source file hasn't changed,
- | Just old_summary <- M.lookup (homeUnitId home_unit, src_fn) old_summaries
+ | Just old_summary <- M.lookup (homeUnitId home_unit, src_fn_os) old_summaries
= do
let location = ms_location $ old_summary
@@ -2099,6 +2110,7 @@ summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf
where
-- change the main active unit so all operations happen relative to the given unit
hsc_env = hscSetActiveHomeUnit home_unit hsc_env'
+ src_fn_os = OsPath.unsafeEncodeUtf src_fn
-- src_fn does not necessarily exist on the filesystem, so we need to
-- check what kind of target we are dealing with
get_src_hash = case maybe_buf of
@@ -2188,7 +2200,7 @@ data SummariseResult =
summariseModule
:: HscEnv
-> HomeUnit
- -> M.Map (UnitId, FilePath) ModSummary
+ -> M.Map (UnitId, OsPath) ModSummary
-- ^ Map of old summaries
-> IsBootInterface -- True <=> a {-# SOURCE #-} import
-> Located ModuleName -- Imported module to be summarised
@@ -2249,7 +2261,7 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p
Right ms -> FoundHome ms
new_summary_cache_check loc mod src_fn h
- | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn)) old_summary_map =
+ | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn_os)) old_summary_map =
-- check the hash on the source file, and
-- return the cached summary if it hasn't changed. If the
@@ -2260,6 +2272,8 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p
Nothing ->
checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc h
| otherwise = new_summary loc mod src_fn h
+ where
+ src_fn_os = OsPath.unsafeEncodeUtf src_fn
new_summary :: ModLocation
-> Module
@@ -2328,7 +2342,8 @@ makeNewModSummary hsc_env MakeNewModSummary{..} = do
hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location)
extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name
- (implicit_sigs, _inst_deps) <- implicitRequirementsShallow (hscSetActiveUnitId (moduleUnitId nms_mod) hsc_env) pi_theimps
+-- (implicit_sigs, _inst_deps) <- implicitRequirementsShallow (hscSetActiveUnitId (moduleUnitId nms_mod) hsc_env) pi_theimps
+ let implicit_sigs = []
return $
ModSummary
@@ -2386,7 +2401,8 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn
let mopts = map unLoc $ snd $ getOptions popts pi_hspp_buf src_fn
pure $ ((, mopts) <$>) $ first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps
- let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query
let rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn))
let pi_srcimps = rn_imps pi_srcimps'
let pi_theimps = rn_imps pi_theimps'
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -692,9 +692,10 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do
-- gather the imports and module name
(hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do
buf <- hGetStringBuffer input_fn
+ query <- hscUnitIndexQuery hsc_env
let imp_prelude = xopt LangExt.ImplicitPrelude dflags
popts = initParserOpts dflags
- rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
+ rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query
rn_imps = fmap (\(rpk, lmn@(L _ mn)) -> (rn_pkg_qual mn rpk, lmn))
eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff)
case eimps of
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -149,7 +149,8 @@ deSugar hsc_env
= do { let dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
ptc = initPromotionTickContext (hsc_dflags hsc_env)
- name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env
+ ; query <- hscUnitIndexQuery hsc_env
+ ; let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env
; withTiming logger
(text "Desugar"<+>brackets (ppr mod))
(const ()) $
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -89,6 +89,7 @@ import GHC.Data.FastString
import GHC.Unit.Env
import GHC.Unit.External
+import GHC.Unit.State (UnitIndexQuery)
import GHC.Unit.Module
import GHC.Unit.Module.ModGuts
@@ -264,7 +265,8 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
++ eps_complete_matches eps -- from imports
-- re-use existing next_wrapper_num to ensure uniqueness
next_wrapper_num_var = tcg_next_wrapper_num tcg_env
- ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env ptc
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+ ; return $ mkDsEnvs unit_env query this_mod rdr_env type_env fam_inst_env ptc
msg_var cc_st_var next_wrapper_num_var complete_matches
}
@@ -292,6 +294,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
; next_wrapper_num <- newIORef emptyModuleEnv
; msg_var <- newIORef emptyMessages
; eps <- liftIO $ hscEPS hsc_env
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
; let unit_env = hsc_unit_env hsc_env
type_env = typeEnvFromEntities ids tycons patsyns fam_insts
ptc = initPromotionTickContext (hsc_dflags hsc_env)
@@ -303,7 +306,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
bindsToIds (Rec binds) = map fst binds
ids = concatMap bindsToIds binds
- envs = mkDsEnvs unit_env this_mod rdr_env type_env
+ envs = mkDsEnvs unit_env query this_mod rdr_env type_env
fam_inst_env ptc msg_var cc_st_var
next_wrapper_num complete_matches
; runDs hsc_env envs thing_inside
@@ -342,12 +345,12 @@ initTcDsForSolver thing_inside
Just ret -> pure ret
Nothing -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLocDefault (getErrorMessages msgs)) }
-mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
+mkDsEnvs :: UnitEnv -> UnitIndexQuery -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> PromotionTickContext
-> IORef (Messages DsMessage) -> IORef CostCentreState
-> IORef (ModuleEnv Int) -> CompleteMatches
-> (DsGblEnv, DsLclEnv)
-mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
+mkDsEnvs unit_env query mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
next_wrapper_num complete_matches
= let if_genv = IfGblEnv { if_doc = text "mkDsEnvs"
-- Failing tests here are `ghci` and `T11985` if you get this wrong.
@@ -364,7 +367,7 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
, ds_fam_inst_env = fam_inst_env
, ds_gbl_rdr_env = rdr_env
, ds_if_env = (if_genv, if_lenv)
- , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env rdr_env
+ , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env query rdr_env
, ds_msgs = msg_var
, ds_complete_matches = complete_matches
, ds_cc_st = cc_st_var
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -588,7 +588,8 @@ checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
checkDependencies hsc_env summary iface
= do
res_normal <- classify_import (findImportedModule hsc_env) (ms_textual_imps summary ++ ms_srcimps summary)
- res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units mhome_unit mod) (ms_plugin_imps summary)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units query mhome_unit mod) (ms_plugin_imps summary)
case sequence (res_normal ++ res_plugin ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of
Left recomp -> return $ NeedsRecompile recomp
Right es -> do
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -358,7 +358,7 @@ loadCmdLineLibs' interp hsc_env pls = snd <$>
let hsc' = hscSetActiveUnitId uid hsc_env
-- Load potential dependencies first
(done', pls') <- foldM (\(done', pls') uid -> load done' uid pls') (done, pls)
- (homeUnitDepends (hsc_units hsc'))
+ (Set.toList (homeUnitDepends (hsc_units hsc')))
pls'' <- loadCmdLineLibs'' interp hsc' pls'
return $ (Set.insert uid done', pls'')
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -27,6 +27,7 @@ module GHC.Rename.Names (
getMinimalImports,
printMinimalImports,
renamePkgQual, renameRawPkgQual,
+ hscRenamePkgQual, hscRenameRawPkgQual,
classifyGREs,
ImportDeclUsage,
) where
@@ -87,6 +88,7 @@ import GHC.Unit.Module.ModIface
import GHC.Unit.Module.Imported
import GHC.Unit.Module.Deps
import GHC.Unit.Env
+import GHC.Unit.State (UnitIndexQuery, unitIndexQuery)
import GHC.Data.Bag
import GHC.Data.FastString
@@ -337,7 +339,8 @@ rnImportDecl this_mod
hsc_env <- getTopEnv
unit_env <- hsc_unit_env <$> getTopEnv
- let pkg_qual = renameRawPkgQual unit_env imp_mod_name raw_pkg_qual
+ query <- unitIndexQuery (ue_index unit_env)
+ let pkg_qual = renameRawPkgQual unit_env query imp_mod_name raw_pkg_qual
-- Check for self-import, which confuses the typechecker (#9032)
-- ghc --make rejects self-import cycles already, but batch-mode may not
@@ -447,14 +450,14 @@ rnImportDecl this_mod
-- | Rename raw package imports
-renameRawPkgQual :: UnitEnv -> ModuleName -> RawPkgQual -> PkgQual
-renameRawPkgQual unit_env mn = \case
+renameRawPkgQual :: UnitEnv -> UnitIndexQuery -> ModuleName -> RawPkgQual -> PkgQual
+renameRawPkgQual unit_env query mn = \case
NoRawPkgQual -> NoPkgQual
- RawPkgQual p -> renamePkgQual unit_env mn (Just (sl_fs p))
+ RawPkgQual p -> renamePkgQual unit_env query mn (Just (sl_fs p))
-- | Rename raw package imports
-renamePkgQual :: UnitEnv -> ModuleName -> Maybe FastString -> PkgQual
-renamePkgQual unit_env mn mb_pkg = case mb_pkg of
+renamePkgQual :: UnitEnv -> UnitIndexQuery -> ModuleName -> Maybe FastString -> PkgQual
+renamePkgQual unit_env query mn mb_pkg = case mb_pkg of
Nothing -> NoPkgQual
Just pkg_fs
| Just uid <- homeUnitId <$> ue_homeUnit unit_env
@@ -464,7 +467,7 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of
| Just (uid, _) <- find (fromMaybe False . fmap (== pkg_fs) . snd) home_names
-> ThisPkg uid
- | Just uid <- resolvePackageImport (ue_units unit_env) mn (PackageName pkg_fs)
+ | Just uid <- resolvePackageImport (ue_units unit_env) query mn (PackageName pkg_fs)
-> OtherPkg uid
| otherwise
@@ -472,13 +475,35 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of
-- not really correct as pkg_fs is unlikely to be a valid unit-id but
-- we will report the failure later...
where
- home_names = map (\uid -> (uid, mkFastString <$> thisPackageName (homeUnitEnv_dflags (ue_findHomeUnitEnv uid unit_env)))) hpt_deps
+ home_names =
+ [ (uid, mkFastString <$> thisPackageName (homeUnitEnv_dflags (ue_findHomeUnitEnv uid unit_env)))
+ | uid <- S.toList hpt_deps
+ ]
units = ue_units unit_env
- hpt_deps :: [UnitId]
+ hpt_deps :: S.Set UnitId
hpt_deps = homeUnitDepends units
+hscRenameRawPkgQual ::
+ MonadIO m =>
+ HscEnv ->
+ ModuleName ->
+ RawPkgQual ->
+ m PkgQual
+hscRenameRawPkgQual hsc_env name raw = do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ pure (renameRawPkgQual (hsc_unit_env hsc_env) query name raw)
+
+hscRenamePkgQual ::
+ MonadIO m =>
+ HscEnv ->
+ ModuleName ->
+ Maybe FastString ->
+ m PkgQual
+hscRenamePkgQual hsc_env name package = do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ pure (renamePkgQual (hsc_unit_env hsc_env) query name package)
-- | Calculate the 'ImportAvails' induced by an import of a particular
-- interface, but without 'imp_mods'.
=====================================
compiler/GHC/Runtime/Context.hs
=====================================
@@ -26,6 +26,7 @@ import GHC.Runtime.Eval.Types ( IcGlobalRdrEnv(..), Resume )
import GHC.Unit
import GHC.Unit.Env
+import GHC.Unit.State (UnitIndexQuery)
import GHC.Core.FamInstEnv
import GHC.Core.InstEnv
@@ -351,8 +352,8 @@ icInScopeTTs ictxt = filter in_scope_unqualified (ic_tythings ictxt)
]
-- | Get the NamePprCtx function based on the flags and this InteractiveContext
-icNamePprCtx :: UnitEnv -> InteractiveContext -> NamePprCtx
-icNamePprCtx unit_env ictxt = mkNamePprCtx ptc unit_env (icReaderEnv ictxt)
+icNamePprCtx :: UnitEnv -> UnitIndexQuery -> InteractiveContext -> NamePprCtx
+icNamePprCtx unit_env query ictxt = mkNamePprCtx ptc unit_env query (icReaderEnv ictxt)
where ptc = initPromotionTickContext (ic_dflags ictxt)
-- | extendInteractiveContext is called with new TyThings recently defined to update the
=====================================
compiler/GHC/Runtime/Loader.hs
=====================================
@@ -348,7 +348,8 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
let unit_state = ue_units unit_env
let mhome_unit = hsc_home_unit_maybe hsc_env
-- First find the unit the module resides in by searching exposed units and home modules
- found_module <- findPluginModule fc fopts unit_state mhome_unit mod_name
+ query <- hscUnitIndexQuery hsc_env
+ found_module <- findPluginModule fc fopts unit_state query mhome_unit mod_name
case found_module of
Found _ mod -> do
-- Find the exports of the module
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -266,9 +266,11 @@ tcRnModuleTcRnM hsc_env mod_sum
; when (notNull prel_imports) $ do
addDiagnostic TcRnImplicitImportOfPrelude
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+
; -- TODO This is a little skeevy; maybe handle a bit more directly
let { simplifyImport (L _ idecl) =
- ( renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName idecl) (ideclPkgQual idecl)
+ ( renameRawPkgQual (hsc_unit_env hsc_env) query (unLoc $ ideclName idecl) (ideclPkgQual idecl)
, reLoc $ ideclName idecl)
}
; raw_sig_imports <- liftIO
@@ -1996,11 +1998,13 @@ runTcInteractive hsc_env thing_inside
(loadSrcInterface (text "runTcInteractive") m
NotBoot mb_pkg)
+
; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i ->
case i of -- force above: see #15111
IIModule n -> getOrphans n NoPkgQual
- IIDecl i -> getOrphans (unLoc (ideclName i))
- (renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i))
+ IIDecl i -> do
+ qual <- hscRenameRawPkgQual hsc_env (unLoc $ ideclName i) (ideclPkgQual i)
+ getOrphans (unLoc (ideclName i)) qual
; let imports = emptyImportAvails { imp_orphs = orphs }
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -869,7 +869,8 @@ getNamePprCtx
= do { ptc <- initPromotionTickContext <$> getDynFlags
; rdr_env <- getGlobalRdrEnv
; hsc_env <- getTopEnv
- ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env }
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+ ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env }
-- | Like logInfoTcRn, but for user consumption
printForUserTcRn :: SDoc -> TcRn ()
=====================================
compiler/GHC/Types/Name/Ppr.hs
=====================================
@@ -13,6 +13,7 @@ import GHC.Data.FastString
import GHC.Unit
import GHC.Unit.Env
+import GHC.Unit.State (UnitIndexQuery)
import GHC.Types.Name
import GHC.Types.Name.Reader
@@ -68,11 +69,11 @@ with some holes, we should try to give the user some more useful information.
-- | Creates some functions that work out the best ways to format
-- names for the user according to a set of heuristics.
-mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> GlobalRdrEnvX info -> NamePprCtx
-mkNamePprCtx ptc unit_env env
+mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> UnitIndexQuery -> GlobalRdrEnvX info -> NamePprCtx
+mkNamePprCtx ptc unit_env index env
= QueryQualify
(mkQualName env)
- (mkQualModule unit_state home_unit)
+ (mkQualModule unit_state index home_unit)
(mkQualPackage unit_state)
(mkPromTick ptc env)
where
@@ -206,8 +207,8 @@ Side note (int-index):
-- | Creates a function for formatting modules based on two heuristics:
-- (1) if the module is the current module, don't qualify, and (2) if there
-- is only one exposed package which exports this module, don't qualify.
-mkQualModule :: UnitState -> Maybe HomeUnit -> QueryQualifyModule
-mkQualModule unit_state mhome_unit mod
+mkQualModule :: UnitState -> UnitIndexQuery -> Maybe HomeUnit -> QueryQualifyModule
+mkQualModule unit_state index mhome_unit mod
| Just home_unit <- mhome_unit
, isHomeModule home_unit mod = False
@@ -218,7 +219,7 @@ mkQualModule unit_state mhome_unit mod
= False
| otherwise = True
- where lookup = lookupModuleInAllUnits unit_state (moduleName mod)
+ where lookup = lookupModuleInAllUnits unit_state index (moduleName mod)
-- | Creates a function for formatting packages based on two heuristics:
-- (1) don't qualify if the package in question is "main", and (2) only qualify
=====================================
compiler/GHC/Unit/Env.hs
=====================================
@@ -100,6 +100,8 @@ data UnitEnv = UnitEnv
, ue_namever :: !GhcNameVersion
-- ^ GHC name/version (used for dynamic library suffix)
+
+ , ue_index :: !UnitIndex
}
ueEPS :: UnitEnv -> IO ExternalPackageState
@@ -108,12 +110,14 @@ ueEPS = eucEPS . ue_eps
initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv
initUnitEnv cur_unit hug namever platform = do
eps <- initExternalUnitCache
+ ue_index <- newUnitIndex
return $ UnitEnv
{ ue_eps = eps
, ue_home_unit_graph = hug
, ue_current_unit = cur_unit
, ue_platform = platform
, ue_namever = namever
+ , ue_index
}
-- | Get home-unit
@@ -138,7 +142,7 @@ ue_transitiveHomeDeps uid unit_env = Set.toList (loop Set.empty [uid])
loop acc (uid:uids)
| uid `Set.member` acc = loop acc uids
| otherwise =
- let hue = homeUnitDepends (homeUnitEnv_units (ue_findHomeUnitEnv uid unit_env))
+ let hue = Set.toList (homeUnitDepends (homeUnitEnv_units (ue_findHomeUnitEnv uid unit_env)))
in loop (Set.insert uid acc) (hue ++ uids)
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -36,6 +36,7 @@ module GHC.Unit.Finder (
lookupFileCache
) where
+import GHC.Driver.Env (hscUnitIndexQuery)
import GHC.Prelude
import GHC.Platform.Ways
@@ -48,6 +49,7 @@ import GHC.Unit.Module
import GHC.Unit.Home
import GHC.Unit.State
import GHC.Unit.Finder.Types
+import GHC.Unit.State (UnitIndexQuery)
import qualified GHC.Data.ShortText as ST
@@ -67,8 +69,9 @@ import Control.Monad
import Data.Time
import qualified Data.Map as M
import GHC.Driver.Env
- ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env) )
+ ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env, hsc_mod_graph) )
import GHC.Driver.Config.Finder
+import GHC.Unit.Module.Graph (mgHomeModuleMap, ModuleNameHomeMap)
import qualified Data.Set as Set
import qualified Data.List.NonEmpty as NE
@@ -162,28 +165,36 @@ findImportedModule hsc_env mod pkg_qual =
dflags = hsc_dflags hsc_env
fopts = initFinderOpts dflags
in do
- findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) mhome_unit mod pkg_qual
+ query <- hscUnitIndexQuery hsc_env
+ let home_module_map = mgHomeModuleMap (hsc_mod_graph hsc_env)
+ findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) query home_module_map mhome_unit mod pkg_qual
findImportedModuleNoHsc
:: FinderCache
-> FinderOpts
-> UnitEnv
+ -> UnitIndexQuery
+ -> ModuleNameHomeMap
-> Maybe HomeUnit
-> ModuleName
-> PkgQual
-> IO FindResult
-findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
+findImportedModuleNoHsc fc fopts ue query home_module_map mhome_unit mod_name mb_pkg =
case mb_pkg of
NoPkgQual -> unqual_import
ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import
- | Just os <- lookup uid other_fopts -> home_pkg_import (uid, os)
+ | Just os <- M.lookup uid other_fopts_map -> home_pkg_import (uid, os)
| otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mhome_unit) $$ ppr uid $$ ppr (map fst all_opts))
OtherPkg _ -> pkg_import
where
+ (complete_units, module_name_map) = home_module_map
+ module_home_units = M.findWithDefault Set.empty mod_name module_name_map
+ current_unit_id = homeUnitId <$> mhome_unit
all_opts = case mhome_unit of
- Nothing -> other_fopts
- Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts
+ Nothing -> other_fopts_list
+ Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts_list
+ other_fopts_map = M.fromList other_fopts_list
home_import = case mhome_unit of
Just home_unit -> findHomeModule fc fopts home_unit mod_name
@@ -194,7 +205,7 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
-- If the module is reexported, then look for it as if it was from the perspective
-- of that package which reexports it.
| mod_name `Set.member` finder_reexportedModules opts =
- findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
+ findImportedModuleNoHsc fc opts ue query home_module_map (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
| mod_name `Set.member` finder_hiddenModules opts =
return (mkHomeHidden uid)
| otherwise =
@@ -203,32 +214,44 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
-- Do not be smart and change this to `foldr orIfNotFound home_import hs` as
-- that is not the same!! home_import is first because we need to look within ourselves
-- first before looking at the packages in order.
- any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts)
+ any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts_list)
- pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg
+ pkg_import = findExposedPackageModule fc fopts units query mod_name mb_pkg
unqual_import = any_home_import
`orIfNotFound`
- findExposedPackageModule fc fopts units mod_name NoPkgQual
+ findExposedPackageModule fc fopts units query mod_name NoPkgQual
units = case mhome_unit of
Nothing -> ue_units ue
Just home_unit -> homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue
- hpt_deps :: [UnitId]
+ hpt_deps :: Set.Set UnitId
hpt_deps = homeUnitDepends units
- other_fopts = map (\uid -> (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))) hpt_deps
+ dep_providers = Set.intersection module_home_units hpt_deps
+ known_other_uids =
+ let providers = maybe dep_providers (\u -> Set.delete u dep_providers) current_unit_id
+ in Set.toList providers
+ unknown_units =
+ let candidates = Set.difference hpt_deps complete_units
+ excluded = maybe dep_providers (\u -> Set.insert u dep_providers) current_unit_id
+ in Set.toList (Set.difference candidates excluded)
+ other_home_uids = known_other_uids ++ unknown_units
+ other_fopts_list =
+ [ (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))
+ | uid <- other_home_uids
+ ]
-- | Locate a plugin module requested by the user, for a compiler
-- plugin. This consults the same set of exposed packages as
-- 'findImportedModule', unless @-hide-all-plugin-packages@ or
-- @-plugin-package@ are specified.
-findPluginModule :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult
-findPluginModule fc fopts units (Just home_unit) mod_name =
+findPluginModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> Maybe HomeUnit -> ModuleName -> IO FindResult
+findPluginModule fc fopts units query (Just home_unit) mod_name =
findHomeModule fc fopts home_unit mod_name
`orIfNotFound`
- findExposedPluginPackageModule fc fopts units mod_name
-findPluginModule fc fopts units Nothing mod_name =
- findExposedPluginPackageModule fc fopts units mod_name
+ findExposedPluginPackageModule fc fopts units query mod_name
+findPluginModule fc fopts units query Nothing mod_name =
+ findExposedPluginPackageModule fc fopts units query mod_name
-- | Locate a specific 'Module'. The purpose of this function is to
-- create a 'ModLocation' for a given 'Module', that is to find out
@@ -284,15 +307,15 @@ homeSearchCache fc home_unit mod_name do_this = do
let mod = mkModule home_unit mod_name
modLocationCache fc mod do_this
-findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult
-findExposedPackageModule fc fopts units mod_name mb_pkg =
+findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> ModuleName -> PkgQual -> IO FindResult
+findExposedPackageModule fc fopts units query mod_name mb_pkg =
findLookupResult fc fopts
- $ lookupModuleWithSuggestions units mod_name mb_pkg
+ $ lookupModuleWithSuggestions units query mod_name mb_pkg
-findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> IO FindResult
-findExposedPluginPackageModule fc fopts units mod_name =
+findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> ModuleName -> IO FindResult
+findExposedPluginPackageModule fc fopts units query mod_name =
findLookupResult fc fopts
- $ lookupPluginModuleWithSuggestions units mod_name NoPkgQual
+ $ lookupPluginModuleWithSuggestions units query mod_name NoPkgQual
findLookupResult :: FinderCache -> FinderOpts -> LookupResult -> IO FindResult
findLookupResult fc fopts r = case r of
=====================================
compiler/GHC/Unit/Module/Graph.hs
=====================================
@@ -18,6 +18,8 @@ module GHC.Unit.Module.Graph
, mgModSummaries
, mgModSummaries'
, mgLookupModule
+ , ModuleNameHomeMap
+ , mgHomeModuleMap
, showModMsg
, moduleGraphNodeModule
, moduleGraphNodeModSum
@@ -153,23 +155,31 @@ instance Outputable ModNodeKeyWithUid where
-- check that the module and its hs-boot agree.
--
-- The graph is not necessarily stored in topologically-sorted order. Use
+type ModuleNameHomeMap = (Set UnitId, Map.Map ModuleName (Set UnitId))
+
-- 'GHC.topSortModuleGraph' and 'GHC.Data.Graph.Directed.flattenSCC' to achieve this.
data ModuleGraph = ModuleGraph
{ mg_mss :: [ModuleGraphNode]
, mg_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
-- A cached transitive dependency calculation so that a lot of work is not
-- repeated whenever the transitive dependencies need to be calculated (for example, hptInstances)
+ , mg_home_map :: ModuleNameHomeMap
+ -- ^ For each module name, which home-unit UnitIds define it together with the set of units for which the listing is complete.
}
-- | Map a function 'f' over all the 'ModSummaries'.
-- To preserve invariants 'f' can't change the isBoot status.
mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph
mapMG f mg@ModuleGraph{..} = mg
- { mg_mss = flip fmap mg_mss $ \case
- InstantiationNode uid iuid -> InstantiationNode uid iuid
- LinkNode uid nks -> LinkNode uid nks
- ModuleNode deps ms -> ModuleNode deps (f ms)
+ { mg_mss = new_mss
+ , mg_home_map = mkHomeModuleMap new_mss
}
+ where
+ new_mss =
+ flip fmap mg_mss $ \case
+ InstantiationNode uid iuid -> InstantiationNode uid iuid
+ LinkNode uid nks -> LinkNode uid nks
+ ModuleNode deps ms -> ModuleNode deps (f ms)
unionMG :: ModuleGraph -> ModuleGraph -> ModuleGraph
unionMG a b =
@@ -177,11 +187,27 @@ unionMG a b =
in ModuleGraph {
mg_mss = new_mss
, mg_graph = mkTransDeps new_mss
+ , mg_home_map = mkHomeModuleMap new_mss
}
mkTransDeps :: [ModuleGraphNode] -> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mkTransDeps = first graphReachability {- module graph is acyclic -} . moduleGraphNodes False
+mkHomeModuleMap :: [ModuleGraphNode] -> ModuleNameHomeMap
+mkHomeModuleMap nodes =
+ (complete_units, provider_map)
+ where
+ provider_map =
+ Map.fromListWith Set.union
+ [ (ms_mod_name ms, Set.singleton (ms_unitid ms))
+ | ModuleNode _ ms <- nodes
+ ]
+ complete_units =
+ Set.fromList
+ [ ms_unitid ms
+ | ModuleNode _ ms <- nodes
+ ]
+
mgModSummaries :: ModuleGraph -> [ModSummary]
mgModSummaries mg = [ m | ModuleNode _ m <- mgModSummaries' mg ]
@@ -200,8 +226,11 @@ mgLookupModule ModuleGraph{..} m = listToMaybe $ mapMaybe go mg_mss
= Just ms
go _ = Nothing
+mgHomeModuleMap :: ModuleGraph -> ModuleNameHomeMap
+mgHomeModuleMap = mg_home_map
+
emptyMG :: ModuleGraph
-emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing)
+emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing) (Set.empty, Map.empty)
isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool
isTemplateHaskellOrQQNonBoot ms =
@@ -213,9 +242,12 @@ isTemplateHaskellOrQQNonBoot ms =
-- not an element of the ModuleGraph.
extendMG :: ModuleGraph -> [NodeKey] -> ModSummary -> ModuleGraph
extendMG ModuleGraph{..} deps ms = ModuleGraph
- { mg_mss = ModuleNode deps ms : mg_mss
- , mg_graph = mkTransDeps (ModuleNode deps ms : mg_mss)
+ { mg_mss = new_mss
+ , mg_graph = mkTransDeps new_mss
+ , mg_home_map = mkHomeModuleMap new_mss
}
+ where
+ new_mss = ModuleNode deps ms : mg_mss
extendMGInst :: ModuleGraph -> UnitId -> InstantiatedUnit -> ModuleGraph
extendMGInst mg uid depUnitId = mg
=====================================
compiler/GHC/Unit/State.hs
=====================================
@@ -1,6 +1,6 @@
-- (c) The University of Glasgow, 2006
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase, OverloadedRecordDot, RecordWildCards #-}
-- | Unit manipulation
module GHC.Unit.State (
@@ -49,6 +49,15 @@ module GHC.Unit.State (
closeUnitDeps',
mayThrowUnitErr,
+ UnitConfig (..),
+ UnitIndex (..),
+ UnitIndexQuery (..),
+ UnitVisibility (..),
+ VisibilityMap,
+ ModuleNameProvidersMap,
+ newUnitIndex,
+ unitIndexQuery,
+
-- * Module hole substitution
ShHoleSubst,
renameHoleUnit,
@@ -121,6 +130,8 @@ import qualified Data.Semigroup as Semigroup
import qualified Data.Set as Set
import GHC.LanguageExtensions
import Control.Applicative
+import Control.Monad.IO.Class (MonadIO (..))
+import Data.IORef (IORef, newIORef, readIORef)
-- ---------------------------------------------------------------------------
-- The Unit state
@@ -458,7 +469,7 @@ data UnitState = UnitState {
-- -Wunused-packages warning.
explicitUnits :: [(Unit, Maybe PackageArg)],
- homeUnitDepends :: [UnitId],
+ homeUnitDepends :: Set UnitId,
-- | This is a full map from 'ModuleName' to all modules which may possibly
-- be providing it. These providers may be hidden (but we'll still want
@@ -493,7 +504,7 @@ emptyUnitState = UnitState {
unwireMap = emptyUniqMap,
preloadUnits = [],
explicitUnits = [],
- homeUnitDepends = [],
+ homeUnitDepends = Set.empty,
moduleNameProvidersMap = emptyUniqMap,
pluginModuleNameProvidersMap = emptyUniqMap,
requirementContext = emptyUniqMap,
@@ -577,10 +588,10 @@ searchPackageId pkgstate pid = filter ((pid ==) . unitPackageId)
-- | Find the UnitId which an import qualified by a package import comes from.
-- Compared to 'lookupPackageName', this function correctly accounts for visibility,
-- renaming and thinning.
-resolvePackageImport :: UnitState -> ModuleName -> PackageName -> Maybe UnitId
-resolvePackageImport unit_st mn pn = do
+resolvePackageImport :: UnitState -> UnitIndexQuery -> ModuleName -> PackageName -> Maybe UnitId
+resolvePackageImport unit_st query mn pn = do
-- 1. Find all modules providing the ModuleName (this accounts for visibility/thinning etc)
- providers <- filterUniqMap originVisible <$> lookupUniqMap (moduleNameProvidersMap unit_st) mn
+ providers <- filterUniqMap originVisible <$> query.findOrigin unit_st mn False
-- 2. Get the UnitIds of the candidates
let candidates_uid = concatMap to_uid $ sortOn fst $ nonDetUniqMapToList providers
-- 3. Get the package names of the candidates
@@ -638,14 +649,14 @@ listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state)
-- 'initUnits' can be called again subsequently after updating the
-- 'packageFlags' field of the 'DynFlags', and it will update the
-- 'unitState' in 'DynFlags'.
-initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
-initUnits logger dflags cached_dbs home_units = do
+initUnits :: Logger -> DynFlags -> UnitIndex -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
+initUnits logger dflags index cached_dbs home_units = do
let forceUnitInfoMap (state, _) = unitInfoMap state `seq` ()
(unit_state,dbs) <- withTiming logger (text "initializing unit database")
forceUnitInfoMap
- $ mkUnitState logger (initUnitConfig dflags cached_dbs home_units)
+ $ mkUnitState logger (homeUnitId_ dflags) (initUnitConfig dflags cached_dbs home_units) index
putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map"
FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})
@@ -1021,7 +1032,7 @@ selectPackages prec_map arg pkgs unusable
= let matches = matching arg
(ps,rest) = partition matches pkgs
in if null ps
- then Left (filter (matches.fst) (nonDetEltsUniqMap unusable))
+ then Left (filter (matches . fst) (nonDetEltsUniqMap unusable))
else Right (sortByPreference prec_map ps, rest)
-- | Rename a 'UnitInfo' according to some module instantiation.
@@ -1484,9 +1495,11 @@ validateDatabase cfg pkg_map1 =
mkUnitState
:: Logger
+ -> UnitId
-> UnitConfig
+ -> UnitIndex
-> IO (UnitState,[UnitDatabase UnitId])
-mkUnitState logger cfg = do
+mkUnitState logger unit cfg index = do
{-
Plan.
@@ -1542,15 +1555,9 @@ mkUnitState logger cfg = do
-- if databases have not been provided, read the database flags
raw_dbs <- case unitConfigDBCache cfg of
- Nothing -> readUnitDatabases logger cfg
+ Nothing -> index.readDatabases logger unit cfg
Just dbs -> return dbs
- -- distrust all units if the flag is set
- let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) }
- dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs
- | otherwise = raw_dbs
-
-
-- This, and the other reverse's that you will see, are due to the fact that
-- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order
-- than they are on the command line.
@@ -1561,169 +1568,17 @@ mkUnitState logger cfg = do
let home_unit_deps = selectHomeUnits (unitConfigHomeUnits cfg) hpt_flags
- -- Merge databases together, without checking validity
- (pkg_map1, prec_map) <- mergeDatabases logger dbs
-
- -- Now that we've merged everything together, prune out unusable
- -- packages.
- let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
-
- reportCycles logger sccs
- reportUnusable logger unusable
-
- -- Apply trust flags (these flags apply regardless of whether
- -- or not packages are visible or not)
- pkgs1 <- mayThrowUnitErr
- $ foldM (applyTrustFlag prec_map unusable)
- (nonDetEltsUniqMap pkg_map2) (reverse (unitConfigFlagsTrusted cfg))
- let prelim_pkg_db = mkUnitInfoMap pkgs1
-
- --
- -- Calculate the initial set of units from package databases, prior to any package flags.
- --
- -- Conceptually, we select the latest versions of all valid (not unusable) *packages*
- -- (not units). This is empty if we have -hide-all-packages.
- --
- -- Then we create an initial visibility map with default visibilities for all
- -- exposed, definite units which belong to the latest valid packages.
- --
- let preferLater unit unit' =
- case compareByPreference prec_map unit unit' of
- GT -> unit
- _ -> unit'
- addIfMorePreferable m unit = addToUDFM_C preferLater m (fsPackageName unit) unit
- -- This is the set of maximally preferable packages. In fact, it is a set of
- -- most preferable *units* keyed by package name, which act as stand-ins in
- -- for "a package in a database". We use units here because we don't have
- -- "a package in a database" as a type currently.
- mostPreferablePackageReps = if unitConfigHideAll cfg
- then emptyUDFM
- else foldl' addIfMorePreferable emptyUDFM pkgs1
- -- When exposing units, we want to consider all of those in the most preferable
- -- packages. We can implement that by looking for units that are equi-preferable
- -- with the most preferable unit for package. Being equi-preferable means that
- -- they must be in the same database, with the same version, and the same package name.
- --
- -- We must take care to consider all these units and not just the most
- -- preferable one, otherwise we can end up with problems like #16228.
- mostPreferable u =
- case lookupUDFM mostPreferablePackageReps (fsPackageName u) of
- Nothing -> False
- Just u' -> compareByPreference prec_map u u' == EQ
- vis_map1 = foldl' (\vm p ->
- -- Note: we NEVER expose indefinite packages by
- -- default, because it's almost assuredly not
- -- what you want (no mix-in linking has occurred).
- if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p
- then addToUniqMap vm (mkUnit p)
- UnitVisibility {
- uv_expose_all = True,
- uv_renamings = [],
- uv_package_name = First (Just (fsPackageName p)),
- uv_requirements = emptyUniqMap,
- uv_explicit = Nothing
- }
- else vm)
- emptyUniqMap pkgs1
-
- --
- -- Compute a visibility map according to the command-line flags (-package,
- -- -hide-package). This needs to know about the unusable packages, since if a
- -- user tries to enable an unusable package, we should let them know.
- --
- vis_map2 <- mayThrowUnitErr
- $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
- (unitConfigHideAll cfg) pkgs1)
- vis_map1 other_flags
-
- --
- -- Sort out which packages are wired in. This has to be done last, since
- -- it modifies the unit ids of wired in packages, but when we process
- -- package arguments we need to key against the old versions.
- --
- (pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2
- let pkg_db = mkUnitInfoMap pkgs2
-
- -- Update the visibility map, so we treat wired packages as visible.
- let vis_map = updateVisibilityMap wired_map vis_map2
-
- let hide_plugin_pkgs = unitConfigHideAllPlugins cfg
- plugin_vis_map <-
- case unitConfigFlagsPlugins cfg of
- -- common case; try to share the old vis_map
- [] | not hide_plugin_pkgs -> return vis_map
- | otherwise -> return emptyUniqMap
- _ -> do let plugin_vis_map1
- | hide_plugin_pkgs = emptyUniqMap
- -- Use the vis_map PRIOR to wired in,
- -- because otherwise applyPackageFlag
- -- won't work.
- | otherwise = vis_map2
- plugin_vis_map2
- <- mayThrowUnitErr
- $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
- hide_plugin_pkgs pkgs1)
- plugin_vis_map1
- (reverse (unitConfigFlagsPlugins cfg))
- -- Updating based on wired in packages is mostly
- -- good hygiene, because it won't matter: no wired in
- -- package has a compiler plugin.
- -- TODO: If a wired in package had a compiler plugin,
- -- and you tried to pick different wired in packages
- -- with the plugin flags and the normal flags... what
- -- would happen? I don't know! But this doesn't seem
- -- likely to actually happen.
- return (updateVisibilityMap wired_map plugin_vis_map2)
-
- let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
- | p <- pkgs2
- ]
- -- The explicitUnits accurately reflects the set of units we have turned
- -- on; as such, it also is the only way one can come up with requirements.
- -- The requirement context is directly based off of this: we simply
- -- look for nested unit IDs that are directly fed holes: the requirements
- -- of those units are precisely the ones we need to track
- let explicit_pkgs = [(k, uv_explicit v) | (k, v) <- nonDetUniqMapToList vis_map]
- req_ctx = mapUniqMap (Set.toList)
- $ plusUniqMapListWith Set.union (map uv_requirements (nonDetEltsUniqMap vis_map))
-
-
- --
- -- Here we build up a set of the packages mentioned in -package
- -- flags on the command line; these are called the "preload"
- -- packages. we link these packages in eagerly. The preload set
- -- should contain at least rts & base, which is why we pretend that
- -- the command line contains -package rts & -package base.
- --
- -- NB: preload IS important even for type-checking, because we
- -- need the correct include path to be set.
- --
- let preload1 = nonDetKeysUniqMap (filterUniqMap (isJust . uv_explicit) vis_map)
-
- -- add default preload units if they can be found in the db
- basicLinkedUnits = fmap (RealUnit . Definite)
- $ filter (flip elemUniqMap pkg_db)
- $ unitConfigAutoLink cfg
- preload3 = ordNub $ (basicLinkedUnits ++ preload1)
-
- -- Close the preload packages with their dependencies
- dep_preload <- mayThrowUnitErr
- $ closeUnitDeps pkg_db
- $ zip (map toUnitId preload3) (repeat Nothing)
-
- let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
- mod_map2 = mkUnusableModuleNameProvidersMap unusable
- mod_map = mod_map2 `plusUniqMap` mod_map1
+ (moduleNameProvidersMap, pluginModuleNameProvidersMap, pkg_db, explicit_pkgs, dep_preload, req_ctx, pkgname_map, wired_map) <- index.update logger unit cfg raw_dbs other_flags
-- Force the result to avoid leaking input parameters
let !state = UnitState
{ preloadUnits = dep_preload
, explicitUnits = explicit_pkgs
- , homeUnitDepends = Set.toList home_unit_deps
+ , homeUnitDepends = home_unit_deps
, unitInfoMap = pkg_db
, preloadClosure = emptyUniqSet
- , moduleNameProvidersMap = mod_map
- , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
+ , moduleNameProvidersMap
+ , pluginModuleNameProvidersMap
, packageNameMap = pkgname_map
, wireMap = wired_map
, unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ]
@@ -1896,6 +1751,261 @@ addListTo = foldl' merge
mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin
mkModMap pkg mod = unitUniqMap (mkModule pkg mod)
+-- -----------------------------------------------------------------------------
+-- Index
+
+data UnitIndexQuery =
+ UnitIndexQuery {
+ findOrigin :: UnitState -> ModuleName -> Bool -> Maybe (UniqMap Module ModuleOrigin),
+ index_all :: UnitState -> ModuleNameProvidersMap
+ }
+
+data UnitIndex =
+ UnitIndex {
+ query :: IO UnitIndexQuery,
+ readDatabases :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId],
+ update ::
+ Logger ->
+ UnitId ->
+ UnitConfig ->
+ [UnitDatabase UnitId] ->
+ [PackageFlag] ->
+ IO (
+ ModuleNameProvidersMap,
+ ModuleNameProvidersMap,
+ UnitInfoMap,
+ [(Unit, Maybe PackageArg)],
+ [UnitId],
+ UniqMap ModuleName [InstantiatedModule],
+ UniqFM PackageName UnitId,
+ WiringMap
+ )
+ }
+
+unitIndexQuery ::
+ MonadIO m =>
+ UnitIndex ->
+ m UnitIndexQuery
+unitIndexQuery index = liftIO index.query
+
+data UnitIndexBackend =
+ UnitIndexBackend {
+ moduleNameProviders :: !ModuleNameProvidersMap,
+ pluginModuleNameProviders :: !ModuleNameProvidersMap
+ }
+
+newUnitIndexBackend :: UnitIndexBackend
+newUnitIndexBackend =
+ UnitIndexBackend {
+ moduleNameProviders = mempty,
+ pluginModuleNameProviders = mempty
+ }
+
+queryFindOriginDefault ::
+ UnitIndexBackend ->
+ UnitState ->
+ ModuleName ->
+ Bool ->
+ Maybe (UniqMap Module ModuleOrigin)
+queryFindOriginDefault _ UnitState {moduleNameProvidersMap, pluginModuleNameProvidersMap} name plugins =
+ lookupUniqMap source name
+ where
+ source = if plugins then pluginModuleNameProvidersMap else moduleNameProvidersMap
+
+newUnitIndexQuery ::
+ MonadIO m =>
+ IORef UnitIndexBackend ->
+ m UnitIndexQuery
+newUnitIndexQuery ref = do
+ state <- liftIO $ readIORef ref
+ pure UnitIndexQuery {
+ findOrigin = queryFindOriginDefault state,
+ index_all = \ s -> s.moduleNameProvidersMap
+ }
+
+updateIndexDefault ::
+ Logger ->
+ UnitId ->
+ UnitConfig ->
+ [UnitDatabase UnitId] ->
+ [PackageFlag] ->
+ IO (ModuleNameProvidersMap, ModuleNameProvidersMap, UnitInfoMap, [(Unit, Maybe PackageArg)], [UnitId], UniqMap ModuleName [InstantiatedModule], UniqFM PackageName UnitId, WiringMap)
+updateIndexDefault logger _ cfg raw_dbs other_flags = do
+
+ -- distrust all units if the flag is set
+ let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) }
+ dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs
+ | otherwise = raw_dbs
+
+
+ -- Merge databases together, without checking validity
+ (pkg_map1, prec_map) <- mergeDatabases logger dbs
+
+ -- Now that we've merged everything together, prune out unusable
+ -- packages.
+ let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
+
+ reportCycles logger sccs
+ reportUnusable logger unusable
+
+ -- Apply trust flags (these flags apply regardless of whether
+ -- or not packages are visible or not)
+ pkgs1 <- mayThrowUnitErr
+ $ foldM (applyTrustFlag prec_map unusable)
+ (nonDetEltsUniqMap pkg_map2) (reverse (unitConfigFlagsTrusted cfg))
+ let prelim_pkg_db = mkUnitInfoMap pkgs1
+
+ --
+ -- Calculate the initial set of units from package databases, prior to any package flags.
+ --
+ -- Conceptually, we select the latest versions of all valid (not unusable) *packages*
+ -- (not units). This is empty if we have -hide-all-packages.
+ --
+ -- Then we create an initial visibility map with default visibilities for all
+ -- exposed, definite units which belong to the latest valid packages.
+ --
+ let preferLater unit unit' =
+ case compareByPreference prec_map unit unit' of
+ GT -> unit
+ _ -> unit'
+ addIfMorePreferable m unit = addToUDFM_C preferLater m (fsPackageName unit) unit
+ -- This is the set of maximally preferable packages. In fact, it is a set of
+ -- most preferable *units* keyed by package name, which act as stand-ins in
+ -- for "a package in a database". We use units here because we don't have
+ -- "a package in a database" as a type currently.
+ mostPreferablePackageReps = if unitConfigHideAll cfg
+ then emptyUDFM
+ else foldl' addIfMorePreferable emptyUDFM pkgs1
+ -- When exposing units, we want to consider all of those in the most preferable
+ -- packages. We can implement that by looking for units that are equi-preferable
+ -- with the most preferable unit for package. Being equi-preferable means that
+ -- they must be in the same database, with the same version, and the same package name.
+ --
+ -- We must take care to consider all these units and not just the most
+ -- preferable one, otherwise we can end up with problems like #16228.
+ mostPreferable u =
+ case lookupUDFM mostPreferablePackageReps (fsPackageName u) of
+ Nothing -> False
+ Just u' -> compareByPreference prec_map u u' == EQ
+ vis_map1 = foldl' (\vm p ->
+ -- Note: we NEVER expose indefinite packages by
+ -- default, because it's almost assuredly not
+ -- what you want (no mix-in linking has occurred).
+ if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p
+ then addToUniqMap vm (mkUnit p)
+ UnitVisibility {
+ uv_expose_all = True,
+ uv_renamings = [],
+ uv_package_name = First (Just (fsPackageName p)),
+ uv_requirements = emptyUniqMap,
+ uv_explicit = Nothing
+ }
+ else vm)
+ emptyUniqMap pkgs1
+
+ --
+ -- Compute a visibility map according to the command-line flags (-package,
+ -- -hide-package). This needs to know about the unusable packages, since if a
+ -- user tries to enable an unusable package, we should let them know.
+ --
+ vis_map2 <- mayThrowUnitErr
+ $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
+ (unitConfigHideAll cfg) pkgs1)
+ vis_map1 other_flags
+
+ --
+ -- Sort out which packages are wired in. This has to be done last, since
+ -- it modifies the unit ids of wired in packages, but when we process
+ -- package arguments we need to key against the old versions.
+ --
+ (pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2
+ let pkg_db = mkUnitInfoMap pkgs2
+
+ -- Update the visibility map, so we treat wired packages as visible.
+ let vis_map = updateVisibilityMap wired_map vis_map2
+
+ let hide_plugin_pkgs = unitConfigHideAllPlugins cfg
+ plugin_vis_map <-
+ case unitConfigFlagsPlugins cfg of
+ -- common case; try to share the old vis_map
+ [] | not hide_plugin_pkgs -> return vis_map
+ | otherwise -> return emptyUniqMap
+ _ -> do let plugin_vis_map1
+ | hide_plugin_pkgs = emptyUniqMap
+ -- Use the vis_map PRIOR to wired in,
+ -- because otherwise applyPackageFlag
+ -- won't work.
+ | otherwise = vis_map2
+ plugin_vis_map2
+ <- mayThrowUnitErr
+ $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
+ hide_plugin_pkgs pkgs1)
+ plugin_vis_map1
+ (reverse (unitConfigFlagsPlugins cfg))
+ -- Updating based on wired in packages is mostly
+ -- good hygiene, because it won't matter: no wired in
+ -- package has a compiler plugin.
+ -- TODO: If a wired in package had a compiler plugin,
+ -- and you tried to pick different wired in packages
+ -- with the plugin flags and the normal flags... what
+ -- would happen? I don't know! But this doesn't seem
+ -- likely to actually happen.
+ return (updateVisibilityMap wired_map plugin_vis_map2)
+
+ let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
+ | p <- pkgs2
+ ]
+ -- The explicitUnits accurately reflects the set of units we have turned
+ -- on; as such, it also is the only way one can come up with requirements.
+ -- The requirement context is directly based off of this: we simply
+ -- look for nested unit IDs that are directly fed holes: the requirements
+ -- of those units are precisely the ones we need to track
+ let explicit_pkgs = [(k, uv_explicit v) | (k, v) <- nonDetUniqMapToList vis_map]
+ req_ctx = mapUniqMap (Set.toList)
+ $ plusUniqMapListWith Set.union (map uv_requirements (nonDetEltsUniqMap vis_map))
+
+
+ --
+ -- Here we build up a set of the packages mentioned in -package
+ -- flags on the command line; these are called the "preload"
+ -- packages. we link these packages in eagerly. The preload set
+ -- should contain at least rts & base, which is why we pretend that
+ -- the command line contains -package rts & -package base.
+ --
+ -- NB: preload IS important even for type-checking, because we
+ -- need the correct include path to be set.
+ --
+ let preload1 = nonDetKeysUniqMap (filterUniqMap (isJust . uv_explicit) vis_map)
+
+ -- add default preload units if they can be found in the db
+ basicLinkedUnits = fmap (RealUnit . Definite)
+ $ filter (flip elemUniqMap pkg_db)
+ $ unitConfigAutoLink cfg
+ preload3 = ordNub $ (basicLinkedUnits ++ preload1)
+
+ -- Close the preload packages with their dependencies
+ dep_preload <- mayThrowUnitErr
+ $ closeUnitDeps pkg_db
+ $ zip (map toUnitId preload3) (repeat Nothing)
+
+ let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
+ mod_map2 = mkUnusableModuleNameProvidersMap unusable
+ mod_map = mod_map2 `plusUniqMap` mod_map1
+ pluginModuleNameProviders = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
+ pure (mod_map, pluginModuleNameProviders, pkg_db, explicit_pkgs, dep_preload, req_ctx, pkgname_map, wired_map)
+
+readDatabasesDefault :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId]
+readDatabasesDefault logger _ cfg =
+ readUnitDatabases logger cfg
+
+newUnitIndex :: MonadIO m => m UnitIndex
+newUnitIndex = do
+ ref <- liftIO $ newIORef newUnitIndexBackend
+ pure UnitIndex {
+ query = newUnitIndexQuery ref,
+ readDatabases = readDatabasesDefault,
+ update = updateIndexDefault
+ }
-- -----------------------------------------------------------------------------
-- Package Utils
@@ -1903,10 +2013,11 @@ mkModMap pkg mod = unitUniqMap (mkModule pkg mod)
-- | Takes a 'ModuleName', and if the module is in any package returns
-- list of modules which take that name.
lookupModuleInAllUnits :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> [(Module, UnitInfo)]
-lookupModuleInAllUnits pkgs m
- = case lookupModuleWithSuggestions pkgs m NoPkgQual of
+lookupModuleInAllUnits pkgs query m
+ = case lookupModuleWithSuggestions pkgs query m NoPkgQual of
LookupFound a b -> [(a,fst b)]
LookupMultiple rs -> map f rs
where f (m,_) = (m, expectJust "lookupModule" (lookupUnit pkgs
@@ -1933,18 +2044,24 @@ data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin
| SuggestHidden ModuleName Module ModuleOrigin
lookupModuleWithSuggestions :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> PkgQual
-> LookupResult
-lookupModuleWithSuggestions pkgs
- = lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs)
+lookupModuleWithSuggestions pkgs query name
+ = lookupModuleWithSuggestions' pkgs query name False
-- | The package which the module **appears** to come from, this could be
-- the one which reexports the module from it's original package. This function
-- is currently only used for -Wunused-packages
-lookupModulePackage :: UnitState -> ModuleName -> PkgQual -> Maybe [UnitInfo]
-lookupModulePackage pkgs mn mfs =
- case lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs) mn mfs of
+lookupModulePackage ::
+ UnitState ->
+ UnitIndexQuery ->
+ ModuleName ->
+ PkgQual ->
+ Maybe [UnitInfo]
+lookupModulePackage pkgs query mn mfs =
+ case lookupModuleWithSuggestions' pkgs query mn False mfs of
LookupFound _ (orig_unit, origin) ->
case origin of
ModOrigin {fromOrigUnit, fromExposedReexport} ->
@@ -1960,19 +2077,21 @@ lookupModulePackage pkgs mn mfs =
_ -> Nothing
lookupPluginModuleWithSuggestions :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> PkgQual
-> LookupResult
-lookupPluginModuleWithSuggestions pkgs
- = lookupModuleWithSuggestions' pkgs (pluginModuleNameProvidersMap pkgs)
+lookupPluginModuleWithSuggestions pkgs query name
+ = lookupModuleWithSuggestions' pkgs query name True
lookupModuleWithSuggestions' :: UnitState
- -> ModuleNameProvidersMap
+ -> UnitIndexQuery
-> ModuleName
+ -> Bool
-> PkgQual
-> LookupResult
-lookupModuleWithSuggestions' pkgs mod_map m mb_pn
- = case lookupUniqMap mod_map m of
+lookupModuleWithSuggestions' pkgs query m onlyPlugins mb_pn
+ = case query.findOrigin pkgs m onlyPlugins of
Nothing -> LookupNotFound suggestions
Just xs ->
case foldl' classify ([],[],[], []) (sortOn fst $ nonDetUniqMapToList xs) of
@@ -2033,16 +2152,16 @@ lookupModuleWithSuggestions' pkgs mod_map m mb_pn
all_mods :: [(String, ModuleSuggestion)] -- All modules
all_mods = sortBy (comparing fst) $
[ (moduleNameString m, suggestion)
- | (m, e) <- nonDetUniqMapToList (moduleNameProvidersMap pkgs)
+ | (m, e) <- nonDetUniqMapToList (query.index_all pkgs)
, suggestion <- map (getSuggestion m) (nonDetUniqMapToList e)
]
getSuggestion name (mod, origin) =
(if originVisible origin then SuggestVisible else SuggestHidden)
name mod origin
-listVisibleModuleNames :: UnitState -> [ModuleName]
-listVisibleModuleNames state =
- map fst (filter visible (nonDetUniqMapToList (moduleNameProvidersMap state)))
+listVisibleModuleNames :: UnitState -> UnitIndexQuery -> [ModuleName]
+listVisibleModuleNames unit_state query =
+ map fst (filter visible (nonDetUniqMapToList (query.index_all unit_state)))
where visible (_, ms) = anyUniqMap originVisible ms
-- | Takes a list of UnitIds (and their "parent" dependency, used for error
=====================================
compiler/cbits/genSym.c
=====================================
@@ -9,7 +9,19 @@
//
// The CPP is thus about the RTS version GHC is linked against, and not the
// version of the GHC being built.
-#if !MIN_VERSION_GLASGOW_HASKELL(9,9,0,0)
+
+#if MIN_VERSION_GLASGOW_HASKELL(9,9,0,0)
+// Unique64 patch was present in 9.10 and later
+#define HAVE_UNIQUE64 1
+#elif !MIN_VERSION_GLASGOW_HASKELL(9,9,0,0) && MIN_VERSION_GLASGOW_HASKELL(9,8,4,0)
+// Unique64 patch was backported to 9.8.4
+#define HAVE_UNIQUE64 1
+#elif !MIN_VERSION_GLASGOW_HASKELL(9,7,0,0) && MIN_VERSION_GLASGOW_HASKELL(9,6,7,0)
+// Unique64 patch was backported to 9.6.7
+#define HAVE_UNIQUE64 1
+#endif
+
+#if !defined(HAVE_UNIQUE64)
HsWord64 ghc_unique_counter64 = 0;
#endif
#if !MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -3695,19 +3695,21 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000
completeModule = wrapIdentCompleterMod $ \w -> do
hsc_env <- GHC.getSession
- let pkg_mods = allVisibleModules (hsc_units hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let pkg_mods = allVisibleModules (hsc_units hsc_env) query
loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
return $ filter (w `isPrefixOf`)
$ map (showPpr (hsc_dflags hsc_env)) $ loaded_mods ++ pkg_mods
completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
hsc_env <- GHC.getSession
+ query <- liftIO $ hscUnitIndexQuery hsc_env
modules <- case m of
Just '-' -> do
imports <- GHC.getContext
return $ map iiModuleName imports
_ -> do
- let pkg_mods = allVisibleModules (hsc_units hsc_env)
+ let pkg_mods = allVisibleModules (hsc_units hsc_env) query
loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
return $ loaded_mods ++ pkg_mods
return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) modules
@@ -3775,8 +3777,8 @@ wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing wor
-- | Return a list of visible module names for autocompletion.
-- (NB: exposed != visible)
-allVisibleModules :: UnitState -> [ModuleName]
-allVisibleModules unit_state = listVisibleModuleNames unit_state
+allVisibleModules :: UnitState -> UnitIndexQuery -> [ModuleName]
+allVisibleModules us query = listVisibleModuleNames us query
completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
completeIdentifier
=====================================
ghc/GHCi/UI/Monad.hs
=====================================
@@ -374,10 +374,11 @@ printForUserGlobalRdrEnv mb_rdr_env doc = do
where
mkNamePprCtxFromGlobalRdrEnv _ Nothing = GHC.getNamePprCtx
mkNamePprCtxFromGlobalRdrEnv dflags (Just rdr_env) =
- withSession $ \ hsc_env ->
+ withSession $ \ hsc_env -> do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
let unit_env = hsc_unit_env hsc_env
ptc = initPromotionTickContext dflags
- in return $ Ppr.mkNamePprCtx ptc unit_env rdr_env
+ return $ Ppr.mkNamePprCtx ptc unit_env query rdr_env
printForUser :: GhcMonad m => SDoc -> m ()
printForUser doc = do
=====================================
ghc/Main.hs
=====================================
@@ -844,7 +844,8 @@ initMulti unitArgsFiles = do
let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
hue_flags = homeUnitEnv_dflags homeUnitEnv
dflags = homeUnitEnv_dflags homeUnitEnv
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units
+ index = hscUnitIndex hsc_env
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags index cached_unit_dbs home_units
updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
pure $ HomeUnitEnv
@@ -859,7 +860,7 @@ initMulti unitArgsFiles = do
let dflags = homeUnitEnv_dflags $ unitEnv_lookup mainUnitId home_unit_graph
unitEnv <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags))
- let final_hsc_env = hsc_env { hsc_unit_env = unitEnv }
+ let final_hsc_env = hsc_env { hsc_unit_env = unitEnv {ue_index = hscUnitIndex hsc_env} }
GHC.setSession final_hsc_env
@@ -892,7 +893,7 @@ checkUnitCycles :: DynFlags -> UnitEnvGraph HomeUnitEnv -> Ghc ()
checkUnitCycles dflags graph = processSCCs sccs
where
mkNode :: (UnitId, HomeUnitEnv) -> Node UnitId UnitId
- mkNode (uid, hue) = DigraphNode uid uid (homeUnitDepends (homeUnitEnv_units hue))
+ mkNode (uid, hue) = DigraphNode uid uid (Set.toList (homeUnitDepends (homeUnitEnv_units hue)))
nodes = map mkNode (unitEnv_elts graph)
sccs = stronglyConnCompFromEdgedVerticesOrd nodes
=====================================
testsuite/tests/ghc-api/downsweep/OldModLocation.hs
=====================================
@@ -47,13 +47,13 @@ main = do
liftIO $ do
- _emss <- downsweep hsc_env [] [] False
+ _emss <- downsweep hsc_env [] Nothing [] False
flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env)
createDirectoryIfMissing False "mydir"
renameFile "B.hs" "mydir/B.hs"
- (_, nodes) <- downsweep hsc_env [] [] False
+ (_, nodes) <- downsweep hsc_env [] Nothing [] False
-- If 'checkSummaryTimestamp' were to call 'addHomeModuleToFinder' with
-- (ms_location old_summary) like summariseFile used to instead of
=====================================
testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs
=====================================
@@ -168,7 +168,7 @@ go label mods cnd =
setTargets [tgt]
hsc_env <- getSession
- (_, nodes) <- liftIO $ downsweep hsc_env [] [] False
+ (_, nodes) <- liftIO $ downsweep hsc_env [] Nothing [] False
it label $ cnd (mapMaybe moduleGraphNodeModSum nodes)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/87ea8e106301f4a6cc82346a315e1f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/87ea8e106301f4a6cc82346a315e1f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0