[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: NCG/LA64: adjust register usage to avoid src-register being clobbered
by Marge Bot (＠marge-bot) 07 Feb '26
by Marge Bot (＠marge-bot) 07 Feb '26
07 Feb '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
27d3046e by Peng Fan at 2026-02-06T20:20:46-05:00
NCG/LA64: adjust register usage to avoid src-register being clobbered
- - - - -
fcf25099 by Teo Camarasu at 2026-02-06T20:20:48-05:00
ghc-internal: Delete unnecessary GHC.Internal.Data.Ix
This module merely re-exports GHC.Internal.Ix. It was copied from
`base` when `ghc-internal` was split, but there is no reason to have
this now. So, let's delete it.
Resolves #26848
- - - - -
8 changed files:
- compiler/GHC/CmmToAsm/LA64/CodeGen.hs
- libraries/base/src/Data/Ix.hs
- libraries/ghc-internal/ghc-internal.cabal.in
- − libraries/ghc-internal/src/GHC/Internal/Data/Ix.hs
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
Changes:
=====================================
compiler/GHC/CmmToAsm/LA64/CodeGen.hs
=====================================
@@ -1784,16 +1784,18 @@ genClz :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock
genClz w dst src = do
platform <- getPlatform
(reg_x, _, code_x) <- getSomeReg src
+ tmp <- getNewRegNat II64
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
+ -- Process uniformly according to one data length, W32.
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),
+ MOV (OpReg W64 tmp) (OpImm (ImmInt 1)),
+ SLL (OpReg W64 tmp) (OpReg W64 tmp) (OpImm (ImmInt (31-shift))),
+ SLL (OpReg W64 dst_reg) (OpReg W32 reg_x) (OpImm (ImmInt (32-shift))),
+ OR (OpReg W64 dst_reg) (OpReg W64 tmp) (OpReg W64 dst_reg),
CLZ (OpReg W64 dst_reg) (OpReg W32 dst_reg)
]
)
@@ -1806,16 +1808,17 @@ genCtz :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock
genCtz w dst src = do
platform <- getPlatform
(reg_x, _, code_x) <- getSomeReg src
+ tmp <- getNewRegNat II64
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),
+ MOV (OpReg W64 tmp) (OpImm (ImmInt 1)),
+ SLL (OpReg W64 tmp) (OpReg W64 tmp) (OpImm (ImmInt shift)),
+ BSTRPICK II64 (OpReg W64 dst_reg) (OpReg W64 reg_x) (OpImm (ImmInt (shift-1))) (OpImm (ImmInt 0)),
+ OR (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpReg W64 tmp),
CTZ (OpReg W64 dst_reg) (OpReg W64 dst_reg)
]
)
=====================================
libraries/base/src/Data/Ix.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE Safe #-}
+{-# LANGUAGE Trustworthy #-}
-- |
--
@@ -42,4 +42,4 @@ module Data.Ix
-- <https://www.haskell.org/onlinereport/haskell2010/haskellch19.html>.
) where
-import GHC.Internal.Data.Ix
+import GHC.Internal.Ix
=====================================
libraries/ghc-internal/ghc-internal.cabal.in
=====================================
@@ -153,7 +153,6 @@ Library
GHC.Internal.Data.Functor.Identity
GHC.Internal.Data.Functor.Utils
GHC.Internal.Data.IORef
- GHC.Internal.Data.Ix
GHC.Internal.Data.List
GHC.Internal.Data.List.NonEmpty
GHC.Internal.Data.Maybe
=====================================
libraries/ghc-internal/src/GHC/Internal/Data/Ix.hs deleted
=====================================
@@ -1,64 +0,0 @@
-{-# LANGUAGE Trustworthy #-}
-
------------------------------------------------------------------------------
--- |
--- Module : GHC.Internal.Data.Ix
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries(a)haskell.org
--- Stability : stable
--- Portability : portable
---
--- The 'Ix' class is used to map a contiguous subrange of values in
--- type onto integers. It is used primarily for array indexing
--- (see the array package). 'Ix' uses row-major order.
---
------------------------------------------------------------------------------
-
-module GHC.Internal.Data.Ix
- (
- -- * The 'Ix' class
- Ix
- ( range
- , index
- , inRange
- , rangeSize
- )
- -- Ix instances:
- --
- -- Ix Char
- -- Ix Int
- -- Ix Integer
- -- Ix Bool
- -- Ix Ordering
- -- Ix ()
- -- (Ix a, Ix b) => Ix (a, b)
- -- ...
-
- -- * Deriving Instances of 'Ix'
- -- | Derived instance declarations for the class 'Ix' are only possible
- -- for enumerations (i.e. datatypes having only nullary constructors)
- -- and single-constructor datatypes, including arbitrarily large tuples,
- -- whose constituent types are instances of 'Ix'.
- --
- -- * For an enumeration, the nullary constructors are assumed to be
- -- numbered left-to-right with the indices being 0 to n-1 inclusive. This
- -- is the same numbering defined by the 'Enum' class. For example, given
- -- the datatype:
- --
- -- > data Colour = Red | Orange | Yellow | Green | Blue | Indigo | Violet
- --
- -- we would have:
- --
- -- > range (Yellow,Blue) == [Yellow,Green,Blue]
- -- > index (Yellow,Blue) Green == 1
- -- > inRange (Yellow,Blue) Red == False
- --
- -- * For single-constructor datatypes, the derived instance declarations
- -- are as shown for tuples in chapter 19, section 2 of the Haskell 2010 report:
- -- <https://www.haskell.org/onlinereport/haskell2010/haskellch19.html>.
-
- ) where
-
-import GHC.Internal.Ix
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -1286,7 +1286,7 @@ module Data.Int where
data Int8 = ...
module Data.Ix where
- -- Safety: Safe
+ -- Safety: Trustworthy
type Ix :: * -> Constraint
class GHC.Internal.Classes.Ord a => Ix a where
range :: (a, a) -> [a]
=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -1286,7 +1286,7 @@ module Data.Int where
data Int8 = ...
module Data.Ix where
- -- Safety: Safe
+ -- Safety: Trustworthy
type Ix :: * -> Constraint
class GHC.Internal.Classes.Ord a => Ix a where
range :: (a, a) -> [a]
=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -1286,7 +1286,7 @@ module Data.Int where
data Int8 = ...
module Data.Ix where
- -- Safety: Safe
+ -- Safety: Trustworthy
type Ix :: * -> Constraint
class GHC.Internal.Classes.Ord a => Ix a where
range :: (a, a) -> [a]
=====================================
testsuite/tests/interface-stability/base-exports.stdout-ws-32
=====================================
@@ -1286,7 +1286,7 @@ module Data.Int where
data Int8 = ...
module Data.Ix where
- -- Safety: Safe
+ -- Safety: Trustworthy
type Ix :: * -> Constraint
class GHC.Internal.Classes.Ord a => Ix a where
range :: (a, a) -> [a]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2bfb63390fb6b4f31e4c1e394394ff…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2bfb63390fb6b4f31e4c1e394394ff…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fix-26700] Decoupling L.H.S.Decls from GHC.Types.ForeignCall
by recursion-ninja (＠recursion-ninja) 06 Feb '26
by recursion-ninja (＠recursion-ninja) 06 Feb '26
06 Feb '26
recursion-ninja pushed to branch wip/fix-26700 at Glasgow Haskell Compiler / GHC
Commits:
f6123da9 by Recursion Ninja at 2026-02-06T17:35:03-05:00
Decoupling L.H.S.Decls from GHC.Types.ForeignCall
- Adding TTG extension point for 'CCallTarget'
- Adding TTG extension point for 'CType'
- Adding TTG extension point for 'Header'
- Moving ForeignCall types that do not need extension
to new L.H.S.Decls.Foreign module
- - - - -
42 changed files:
- compiler/GHC/Builtin/Types.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/CoreToStg.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/HsToCore/Errors/Types.hs
- compiler/GHC/HsToCore/Foreign/C.hs
- compiler/GHC/HsToCore/Foreign/Call.hs
- compiler/GHC/HsToCore/Foreign/Decl.hs
- compiler/GHC/HsToCore/Foreign/JavaScript.hs
- compiler/GHC/HsToCore/Foreign/Wasm.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToCmm/Foreign.hs
- compiler/GHC/StgToJS/FFI.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Foreign.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/Types/ErrCtxt.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Types/ForeignCall.hs
- compiler/Language/Haskell/Syntax/Decls.hs
- + compiler/Language/Haskell/Syntax/Decls/Foreign.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- compiler/ghc.cabal.in
- libraries/text
- libraries/transformers
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- utils/check-exact/ExactPrint.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
- utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
- utils/haddock/haddock-api/src/Haddock/Interface/LexParseRn.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
- utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f6123da9619d0eadc8f3a9fb4e6e8d1…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f6123da9619d0eadc8f3a9fb4e6e8d1…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fix-26700] 2 commits: Addressing code review comments
by recursion-ninja (＠recursion-ninja) 06 Feb '26
by recursion-ninja (＠recursion-ninja) 06 Feb '26
06 Feb '26
recursion-ninja pushed to branch wip/fix-26700 at Glasgow Haskell Compiler / GHC
Commits:
73251e50 by Recursion Ninja at 2026-02-06T16:07:21-05:00
Addressing code review comments
- - - - -
9ddbfca5 by Recursion Ninja at 2026-02-06T16:50:48-05:00
Correcting 'Haddock' and 'Exact-Print' builds
- - - - -
27 changed files:
- compiler/GHC/CoreToStg.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/HsToCore/Errors/Types.hs
- compiler/GHC/HsToCore/Foreign/C.hs
- compiler/GHC/HsToCore/Foreign/Call.hs
- compiler/GHC/HsToCore/Foreign/Decl.hs
- compiler/GHC/HsToCore/Foreign/JavaScript.hs
- compiler/GHC/HsToCore/Foreign/Wasm.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToCmm/Foreign.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Foreign.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/Types/ErrCtxt.hs
- compiler/GHC/Types/ForeignCall.hs
- compiler/Language/Haskell/Syntax/Decls.hs
- compiler/Language/Haskell/Syntax/Decls/Foreign.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
- utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
- utils/haddock/haddock-api/src/Haddock/Interface/LexParseRn.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
- utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
Changes:
=====================================
compiler/GHC/CoreToStg.hs
=====================================
@@ -554,10 +554,11 @@ mkStgApp f how_bound core_args stg_args res_ty
StgOpApp (StgPrimOp op) stg_args res_ty
-- A call to some primitive Cmm function.
- FCallId (CCall (CCallSpec (StaticTarget ext lbl ForeignFunction)
- PrimCallConv _))
+ FCallId (CCall (CCallSpec
+ (StaticTarget ext lbl ForeignFunction) PrimCallConv _))
+ | TargetIsInThat unit <- staticTargetUnit ext
-> assert exactly_saturated $
- StgOpApp (StgPrimCallOp (PrimCall lbl (staticTargetUnit ext))) stg_args res_ty
+ StgOpApp (StgPrimCallOp (PrimCall lbl unit)) stg_args res_ty
-- A regular foreign call.
FCallId call -> assert exactly_saturated $
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -33,7 +33,6 @@ import GHC.Types.Name.Reader (WithUserRdr(..))
import GHC.Types.InlinePragma (ActivationGhc)
import GHC.Data.BooleanFormula (BooleanFormula(..))
import Language.Haskell.Syntax.Decls
-import Language.Haskell.Syntax.Decls.Foreign
import Language.Haskell.Syntax.Decls.Overlap (OverlapMode(..))
import Language.Haskell.Syntax.Extension (Anno)
import Language.Haskell.Syntax.Binds.InlinePragma (ActivationX(..), InlinePragma(..))
@@ -250,16 +249,21 @@ deriving instance Data (CImportSpec GhcPs)
deriving instance Data (CImportSpec GhcRn)
deriving instance Data (CImportSpec GhcTc)
--- deriving instance (DataIdLR p p) => Data (CImportSpec p)
+-- deriving instance (DataIdLR p p) => Data (CCallTarget p)
deriving instance Data (CCallTarget GhcPs)
deriving instance Data (CCallTarget GhcRn)
deriving instance Data (CCallTarget GhcTc)
--- deriving instance (DataIdLR p p) => Data (CImportSpec p)
+-- deriving instance (DataIdLR p p) => Data (CType p)
deriving instance Data (CType GhcPs)
deriving instance Data (CType GhcRn)
deriving instance Data (CType GhcTc)
+-- deriving instance (DataIdLR p p) => Data (Header p)
+deriving instance Data (Header GhcPs)
+deriving instance Data (Header GhcRn)
+deriving instance Data (Header GhcTc)
+
-- deriving instance (DataIdLR p p) => Data (RuleDecls p)
deriving instance Data (RuleDecls GhcPs)
deriving instance Data (RuleDecls GhcRn)
=====================================
compiler/GHC/HsToCore/Errors/Types.hs
=====================================
@@ -13,7 +13,6 @@ import GHC.Driver.Flags (WarningFlag)
import GHC.Hs
import GHC.HsToCore.Pmc.Solver.Types
import GHC.Types.Error
-import GHC.Types.ForeignCall (CLabelString)
import GHC.Types.Id
import GHC.Types.InlinePragma (ActivationGhc)
import GHC.Types.Name (Name)
=====================================
compiler/GHC/HsToCore/Foreign/C.hs
=====================================
@@ -68,29 +68,28 @@ dsCFExport:: Id -- Either the exported Id,
-- from C, and its representation type
-> CLabelString -- The name to export to C land
-> CCallConv
- -> ForeignKind -- If it is a function,
- -- then is foreign export dynamic
- -- so invoke IO action that's hanging off
- -- the first argument's stable pointer
+ -> ExportLinking -- If foreign export is dynamic
+ -- then invoke IO action that's hanging off
+ -- the first argument's stable pointer
-> DsM ( CHeader -- contents of Module_stub.h
, CStub -- contents of Module_stub.c
, String -- string describing type to pass to createAdj.
)
-dsCFExport fn_id co ext_name cconv target_kind = do
+dsCFExport fn_id co ext_name cconv isDyn = do
let
ty = coercionRKind co
(bndrs, orig_res_ty) = tcSplitPiTys ty
fe_arg_tys' = mapMaybe anonPiTyBinderType_maybe bndrs
-- We must use tcSplits here, because we want to see
-- the (IO t) in the corner of the type!
- fe_arg_tys = case target_kind of
- ForeignFunction -> tail fe_arg_tys'
- _ -> fe_arg_tys'
+ (fe_arg_tys, m_fn_id) = case isDyn of
+ ExportIsDynamic -> (tail fe_arg_tys', Nothing)
+ ExportIsStatic -> (fe_arg_tys', Just fn_id)
-- Look at the result type of the exported function, orig_res_ty
- -- If it's IO t, return (t, ForeignFunction)
- -- If it's plain t, return (t, ForeignValue)
+ -- If it's IO t, return (t, True)
+ -- If it's plain t, return (t, False)
(res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of
-- The function already returns IO t
Just (_ioTyCon, res_ty) -> (res_ty, True)
@@ -99,16 +98,14 @@ dsCFExport fn_id co ext_name cconv target_kind = do
dflags <- getDynFlags
return $
- mkFExportCBits dflags ext_name
- (if isDyn then Nothing else Just fn_id)
- fe_arg_tys res_ty is_IO_res_ty cconv
+ mkFExportCBits dflags ext_name m_fn_id fe_arg_tys res_ty is_IO_res_ty cconv
dsCImport :: Id
-> Coercion
-> CImportSpec GhcTc
-> CCallConv
-> Safety
- -> Maybe Header
+ -> Maybe (Header GhcTc)
-> DsM ([Binding], CHeader, CStub)
dsCImport id co (CLabel cid) _ _ _ = do
let ty = coercionLKind co
@@ -186,7 +183,7 @@ dsCFExportDynamic id co0 cconv = do
export_ty = mkVisFunTyMany stable_ptr_ty arg_ty
bindIOId <- dsLookupGlobalId bindIOName
stbl_value <- newSysLocalMDs stable_ptr_ty
- (h_code, c_code, typestring) <- dsCFExport id (mkRepReflCo export_ty) fe_nm cconv True
+ (h_code, c_code, typestring) <- dsCFExport id (mkRepReflCo export_ty) fe_nm cconv ExportIsDynamic
let
{-
The arguments to the external function which will
@@ -203,7 +200,7 @@ dsCFExportDynamic id co0 cconv = do
-- (probably in the RTS.)
adjustor = fsLit "createAdjustor"
- ccall_adj <- dsCCall adjustor (moduleUnit mod) adj_args PlayRisky (mkTyConApp io_tc [res_ty])
+ ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])
-- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
let io_app = mkLams tvs $
@@ -231,7 +228,7 @@ dsCFExportDynamic id co0 cconv = do
-- | Foreign calls
-dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header
+dsFCall :: Id -> Coercion -> ForeignCall -> Maybe (Header GhcTc)
-> DsM ([(Id, Expr TyVar)], CHeader, CStub)
dsFCall fn_id co fcall mDeclHeader = do
let
@@ -331,7 +328,7 @@ dsFCall fn_id co fcall mDeclHeader = do
toCName :: Id -> String
toCName i = showSDocOneLine defaultSDocContext (pprCode (ppr (idName i)))
-toCType :: Type -> (Maybe Header, SDoc)
+toCType :: Type -> (Maybe (Header GhcTc), SDoc)
toCType = f False
where f voidOK t
-- First, if we have (Ptr t) of (FunPtr t), then we need to
@@ -382,7 +379,7 @@ mkFExportCBits :: DynFlags
-> Maybe Id -- Just==static, Nothing==dynamic
-> [Type]
-> Type
- -> ForeignKind -- Function <=> returns an IO type
+ -> Bool -- True <=> returns an IO type
-> CCallConv
-> (CHeader,
CStub,
@@ -519,7 +516,7 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty io_res_ty cc
char '&' <> cap <>
text "rts_apply" <> parens (
cap
- <> (if io_res_ty == ForeignFunction
+ <> (if io_res_ty
then text "ghc_hs_iface->runIO_closure"
else text "ghc_hs_iface->runNonIO_closure")
<> comma
=====================================
compiler/GHC/HsToCore/Foreign/Call.hs
=====================================
@@ -42,7 +42,6 @@ import GHC.Types.Literal
import GHC.Types.RepType (typePrimRep1)
import GHC.Tc.Utils.TcType
-import GHC.Unit (Unit)
import GHC.Builtin.Types.Prim
import GHC.Builtin.Types
@@ -93,20 +92,19 @@ follows:
-}
dsCCall :: CLabelString -- C routine to invoke
- -> Unit -- Module unit of the C routine
-> [CoreExpr] -- Arguments (desugared)
-- Precondition: none have representation-polymorphic types
-> Safety -- Safety of the call
-> Type -- Type of the result: IO t
-> DsM CoreExpr -- Result, of type ???
-dsCCall lbl unit args may_gc result_ty
+dsCCall lbl args may_gc result_ty
= do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args
(ccall_result_ty, res_wrapper) <- boxResult result_ty
uniq <- newUnique
let stExt = StaticTargetGhc
{ staticTargetLabel = NoSourceText
- , staticTargetUnit = unit
+ , staticTargetUnit = TargetIsInThisUnit
}
target = StaticTarget stExt lbl ForeignFunction
the_fcall = CCall (CCallSpec target CCallConv may_gc)
=====================================
compiler/GHC/HsToCore/Foreign/Decl.hs
=====================================
@@ -24,7 +24,7 @@ import GHC.HsToCore.Monad
import GHC.Hs
import GHC.Types.Id
-import GHC.Types.ForeignCall
+import GHC.Types.ForeignCall (ExportLinking(..))
import GHC.Types.ForeignStubs
import GHC.Unit.Module
import GHC.Core.Coercion
@@ -93,7 +93,7 @@ dsForeigns' fos = do
, fd_e_ext = co
, fd_fe = CExport _
(L _ (CExportStatic ext_nm cconv)) }) = do
- (h, c, _, ids, bs) <- dsFExport id co ext_nm cconv False
+ (h, c, _, ids, bs) <- dsFExport id co ext_nm cconv ExportIsStatic
return (h, c, ids, bs)
{-
@@ -165,7 +165,7 @@ dsFExport :: Id -- Either the exported Id,
-- from C, and its representation type
-> CLabelString -- The name to export to C land
-> CCallConv
- -> Bool -- True => foreign export dynamic
+ -> ExportLinking -- True => foreign export dynamic
-- so invoke IO action that's hanging off
-- the first argument's stable pointer
-> DsM ( CHeader -- contents of Module_stub.h
=====================================
compiler/GHC/HsToCore/Foreign/JavaScript.hs
=====================================
@@ -72,9 +72,9 @@ dsJsFExport
-- from C, and its representation type
-> CLabelString -- The name to export to C land
-> CCallConv
- -> Bool -- True => foreign export dynamic
- -- so invoke IO action that's hanging off
- -- the first argument's stable pointer
+ -> ExportLinking -- If foreign export is dynamic
+ -- then invoke IO action that's hanging off
+ -- the first argument's stable pointer
-> DsM ( CHeader -- contents of Module_stub.h
, CStub -- contents of Module_stub.c
, String -- string describing type to pass to createAdj.
@@ -87,9 +87,9 @@ dsJsFExport fn_id co ext_name cconv isDyn = do
(fe_arg_tys', orig_res_ty) = tcSplitFunTys sans_foralls
-- We must use tcSplits here, because we want to see
-- the (IO t) in the corner of the type!
- fe_arg_tys = case target_kind of
- ForeignFunction -> tail fe_arg_tys'
- _ -> fe_arg_tys'
+ (fe_arg_tys, m_fn_id) = case isDyn of
+ ExportIsDynamic -> (tail fe_arg_tys', Nothing)
+ ExportIsStatic -> (fe_arg_tys', Just fn_id)
-- Look at the result type of the exported function, orig_res_ty
-- If it's IO t, return (t, True)
@@ -101,8 +101,7 @@ dsJsFExport fn_id co ext_name cconv isDyn = do
Nothing -> (orig_res_ty, False)
platform <- targetPlatform <$> getDynFlags
return $
- mkFExportJSBits platform ext_name
- (if isDyn then Nothing else Just fn_id)
+ mkFExportJSBits platform ext_name m_fn_id
(map scaledThing fe_arg_tys) res_ty is_IO_res_ty cconv
mkFExportJSBits
@@ -231,7 +230,7 @@ dsJsImport
-> CImportSpec GhcTc
-> CCallConv
-> Safety
- -> Maybe Header
+ -> Maybe (Header GhcTc)
-> DsM ([Binding], CHeader, CStub)
dsJsImport id co (CLabel cid) _ _ _ = do
let ty = coercionLKind co
@@ -283,7 +282,7 @@ dsJsFExportDynamic id co0 cconv = do
export_ty = mkVisFunTyMany stable_ptr_ty arg_ty
bindIOId <- dsLookupGlobalId bindIOName
stbl_value <- newSysLocalMDs stable_ptr_ty
- (h_code, c_code, typestring) <- dsJsFExport id (mkRepReflCo export_ty) fe_nm cconv True
+ (h_code, c_code, typestring) <- dsJsFExport id (mkRepReflCo export_ty) fe_nm cconv ExportIsDynamic
let
{-
The arguments to the external function which will
@@ -300,7 +299,7 @@ dsJsFExportDynamic id co0 cconv = do
-- (probably in the RTS.)
adjustor = fsLit "createAdjustor"
- ccall_adj <- dsCCall adjustor (moduleUnit mod) adj_args PlayRisky (mkTyConApp io_tc [res_ty])
+ ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])
-- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
let io_app = mkLams tvs $
@@ -321,7 +320,7 @@ dsJsFExportDynamic id co0 cconv = do
toJsName :: Id -> String
toJsName i = renderWithContext defaultSDocContext (pprCode (ppr (idName i)))
-dsJsCall :: Id -> Coercion -> ForeignCall -> Maybe Header
+dsJsCall :: Id -> Coercion -> ForeignCall -> Maybe (Header GhcTc)
-> DsM ([(Id, Expr TyVar)], CHeader, CStub)
dsJsCall fn_id co (CCall (CCallSpec target cconv safety)) _mDeclHeader = do
let
@@ -650,7 +649,7 @@ mkJsCall u tgt args t = mkFCall u ccall args t
where
stExt = StaticTargetGhc
{ staticTargetLabel = NoSourceText
- , staticTargetUnit = ghcInternalUnit
+ , staticTargetUnit = TargetIsInThat ghcInternalUnit
}
ccall = CCall $ CCallSpec
(StaticTarget stExt tgt ForeignFunction)
=====================================
compiler/GHC/HsToCore/Foreign/Wasm.hs
=====================================
@@ -42,7 +42,6 @@ import GHC.Types.Name
import GHC.Types.SourceText
import GHC.Types.SrcLoc
import GHC.Types.Var
-import GHC.Unit
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -131,7 +130,7 @@ dsWasmJSDynamicExport ::
Synchronicity ->
Id ->
Coercion ->
- Unit ->
+ CCallStaticTargetUnit ->
DsM ([Binding], CHeader, CStub, [Id])
dsWasmJSDynamicExport sync fn_id co unitId = do
sp_tycon <- dsLookupTyCon stablePtrTyConName
@@ -308,7 +307,7 @@ dsWasmJSStaticImport ::
Id ->
Coercion ->
String ->
- Unit ->
+ CCallStaticTargetUnit ->
Synchronicity ->
DsM ([Binding], CHeader, CStub)
dsWasmJSStaticImport fn_id co js_src' unitId sync = do
@@ -399,7 +398,7 @@ uniqueCFunName = do
mkWrapperName cfun_num "ghc_wasm_jsffi" ""
importBindingRHS ::
- Unit ->
+ CCallStaticTargetUnit ->
FastString ->
[TyVar] ->
[Scaled Type] ->
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -423,7 +423,7 @@ rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec })
--
patchForeignImport :: Unit -> (ForeignImport GhcPs) -> (ForeignImport GhcRn)
patchForeignImport unit (CImport ext cconv safety fs spec)
- = CImport ext cconv safety fs (patchCImportSpec unit spec)
+ = CImport ext cconv safety (renameHeader <$> fs) (patchCImportSpec unit spec)
patchCImportSpec :: Unit -> CImportSpec GhcPs -> CImportSpec GhcRn
patchCImportSpec unit = \case
@@ -437,7 +437,7 @@ patchCCallTarget unit = \case
StaticTarget sTxt label targetKind ->
let ext = StaticTargetGhc
{ staticTargetLabel = sTxt
- , staticTargetUnit = unit
+ , staticTargetUnit = TargetIsInThat unit
}
in StaticTarget ext label targetKind
@@ -2037,7 +2037,7 @@ rnDataDefn doc (HsDataDefn { dd_cType = cType, dd_ctxt = context, dd_cons = cond
}
where
rn_ctype :: CType GhcPs -> CType GhcRn
- rn_ctype (CType x y z) = CType x y z
+ rn_ctype (CType x y z) = CType x (renameHeader <$> y) z
h98_style = not $ anyLConIsGadt condecls -- Note [Stupid theta]
rn_derivs ds
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -27,8 +27,6 @@ import GHC.Cmm.Utils
import GHC.Platform
import GHC.Platform.Profile
-import GHC.Hs.Extension ( GhcTc )
-
import GHCi.FFI
import GHC.Types.Basic
import GHC.Utils.Outputable
@@ -671,8 +669,8 @@ schemeT d s p (StgOpApp (StgPrimOp op) args _ty) = do
-- Otherwise we have to do a call to the primop wrapper instead :(
_ -> doTailCall d s p (primOpId op) (reverse args)
-schemeT d s p (StgOpApp (StgPrimCallOp (PrimCall label unit)) args result_ty)
- = generatePrimCall d s p label unit result_ty args
+schemeT d s p (StgOpApp (StgPrimCallOp (PrimCall label _)) args result_ty)
+ = generatePrimCall d s p label result_ty args
schemeT d s p (StgConApp con _cn args _tys)
-- Case 2: Unboxed tuple
@@ -1869,11 +1867,10 @@ generatePrimCall
-> Sequel
-> BCEnv
-> CLabelString -- where to call
- -> Unit
-> Type
-> [StgArg] -- args (atoms)
-> BcM BCInstrList
-generatePrimCall d s p target _mb_unit _result_ty args
+generatePrimCall d s p target _result_ty args
= do
profile <- getProfile
let
@@ -1931,13 +1928,13 @@ generateCCall
:: StackDepth
-> Sequel
-> BCEnv
- -> CCallSpec GhcTc -- where to call
+ -> CCallSpec -- where to call
-> Type
-> [StgArg] -- args (atoms)
-> BcM BCInstrList
generateCCall d0 s p (CCallSpec target PrimCallConv _) result_ty args
- | (StaticTarget ext label _) <- target
- = generatePrimCall d0 s p label (staticTargetUnit ext) result_ty args
+ | (StaticTarget _ label _) <- target
+ = generatePrimCall d0 s p label result_ty args
| otherwise
= panic "GHC.StgToByteCode.generateCCall: primcall convention only supports static targets"
generateCCall d0 s p (CCallSpec target _ safety) result_ty args
@@ -2643,7 +2640,7 @@ isFollowableArg P = True
isFollowableArg _ = False
-- | Indicate if the calling convention is supported
-isSupportedCConv :: CCallSpec p -> Bool
+isSupportedCConv :: CCallSpec -> Bool
isSupportedCConv (CCallSpec _ cconv _) = case cconv of
CCallConv -> True -- we explicitly pattern match on every
StdCallConv -> False -- convention to ensure that a warning
=====================================
compiler/GHC/StgToCmm/Foreign.hs
=====================================
@@ -81,8 +81,9 @@ cgForeignCall (CCall (CCallSpec target cconv safety)) typ stg_args res_ty
StaticTarget _ _ ForeignValue ->
panic "cgForeignCall: unexpected FFI value import"
StaticTarget ext lbl ForeignFunction ->
- let labelSource =
- ForeignLabelInPackage . toUnitId $ staticTargetUnit ext
+ let labelSource = case staticTargetUnit ext of
+ TargetIsInThisUnit -> ForeignLabelInThisPackage
+ TargetIsInThat unit -> ForeignLabelInPackage $ toUnitId unit
in ( unzip cmm_args
, CmmLit
(CmmLabel (mkForeignLabel lbl labelSource IsFunction)))
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -197,7 +197,6 @@ import GHC.Types.Basic
import GHC.Types.Error
import GHC.Types.Avail
import GHC.Types.Hint
-import GHC.Types.ForeignCall ( CLabelString )
import GHC.Types.Id.Info ( RecSelParent(..) )
import GHC.Types.InlinePragma (InlinePragma(..))
import GHC.Types.Name (NamedThing(..), Name, OccName, getSrcLoc, getSrcSpan)
=====================================
compiler/GHC/Tc/Gen/Foreign.hs
=====================================
@@ -292,7 +292,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport src (L lc cconv) safety mh (CLabel c
check (isFFILabelTy (mkScaledFunTys arg_tys res_ty))
(TcRnIllegalForeignType Nothing)
cconv' <- checkCConv (Right idecl) cconv
- return $ CImport src (L lc cconv') safety mh (CLabel cLabel)
+ return $ CImport src (L lc cconv') safety (typeCheckHeader <$> mh) (CLabel cLabel)
tcCheckFIType arg_tys res_ty idecl@(CImport src (L lc cconv) safety mh CWrapper) = do
-- Foreign wrapper (former foreign export dynamic)
@@ -310,7 +310,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport src (L lc cconv) safety mh CWrapper)
where
(arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
_ -> addErrTc (TcRnIllegalForeignType Nothing OneArgExpected)
- return (CImport src (L lc cconv') safety mh CWrapper)
+ return (CImport src (L lc cconv') safety (typeCheckHeader <$> mh) CWrapper)
tcCheckFIType arg_tys res_ty idecl@(CImport src (L lc cconv) (L ls safety) mh
(CFunction target))
@@ -361,7 +361,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport src (L lc cconv) (L ls safety) mh
_ -> return ()
return $ cImport' cconv'
where
- cImport' cConv = CImport src (L lc cConv) cSafe mh cFun
+ cImport' cConv = CImport src (L lc cConv) cSafe (typeCheckHeader <$> mh) cFun
cFun = CFunction $ rnCCallTarget target
cSafe = L ls safety
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -75,7 +75,7 @@ import GHC.Core.TyCon
import GHC.Core.DataCon
import GHC.Core.Unify
-import GHC.Types.ForeignCall ( CType(..) )
+import GHC.Types.ForeignCall ( typeCheckCType )
import GHC.Types.Id
import GHC.Types.Id.Make
import GHC.Types.Var
@@ -3599,13 +3599,11 @@ tcDataDefn err_ctxt roles_info tc_name
{ data_cons <- tcConDecls DDataType rec_tycon tc_bndrs res_kind cons
; tc_rhs <- mk_tc_rhs hsc_src rec_tycon data_cons
; tc_rep_nm <- newTyConRepName tc_name
- ; let tc_ctype :: CType GhcRn -> CType GhcTc
- tc_ctype (CType x y z) = CType x y z
; return (mkAlgTyCon tc_name kind
bndrs nb_eta
res_kind
(roles_info tc_name)
- (fmap (tc_ctype . unLoc) cType)
+ (fmap (typeCheckCType . unLoc) cType)
stupid_theta tc_rhs
(VanillaAlgTyCon tc_rep_nm)
gadt_syntax)
=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -69,7 +69,7 @@ import GHC.Types.Var as Var
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Basic
-import GHC.Types.ForeignCall ( CType(..) )
+import GHC.Types.ForeignCall ( typeCheckCType )
import GHC.Types.Id
import GHC.Types.InlinePragma
import GHC.Types.SourceFile
@@ -827,13 +827,11 @@ tcDataFamInstDecl mb_clsinfo tv_skol_env
-- NB: Use the full ty_binders from the pats. See bullet toward
-- the end of Note [Data type families] in GHC.Core.TyCon
- tc_ctype :: CType GhcRn -> CType GhcTc
- tc_ctype (CType x y z) = CType x y z
rep_tc = mkAlgTyCon rep_tc_name user_kind
ty_binders (length extra_tcbs)
res_kind
(map (const Nominal) ty_binders)
- (fmap (tc_ctype . unLoc) cType) stupid_theta
+ (fmap (typeCheckCType . unLoc) cType) stupid_theta
tc_rhs parent
gadt_syntax
-- We always assume that indexed types are recursive. Why?
=====================================
compiler/GHC/Tc/Types/ErrCtxt.hs
=====================================
@@ -39,7 +39,6 @@ import GHC.Utils.Outputable ( Outputable(..) )
import Language.Haskell.Syntax
import Language.Haskell.Syntax.Basic ( FieldLabelString(..) )
-import Language.Haskell.Syntax.Decls.Foreign ( ForeignDecl(..) )
import GHC.Boot.TH.Syntax qualified as TH
import qualified Data.List.NonEmpty as NE
=====================================
compiler/GHC/Types/ForeignCall.hs
=====================================
@@ -39,6 +39,8 @@ module GHC.Types.ForeignCall (
ForeignExport(..),
-- ** Specification
CExportSpec(..),
+ -- ** Linking flags
+ ExportLinking(..),
-- * Foreign import types
-- ** Data-type
@@ -47,6 +49,7 @@ module GHC.Types.ForeignCall (
CCallTarget(..),
-- *** GHC extension point
StaticTargetGhc(..),
+ CCallStaticTargetUnit(..),
-- *** Queries
isDynamicTarget,
-- ** Foreign target kind
@@ -65,6 +68,8 @@ module GHC.Types.ForeignCall (
-- *** Construction
defaultCType,
mkCType,
+ -- *** Conversion
+ typeCheckCType,
-- *** GHC extension point
CTypeGhc(..),
@@ -83,6 +88,9 @@ module GHC.Types.ForeignCall (
pprCLabelString,
-- ** Header
Header(..),
+ -- *** Conversion
+ renameHeader,
+ typeCheckHeader,
) where
import GHC.Prelude
@@ -101,7 +109,6 @@ import Language.Haskell.Syntax.Extension
import Data.Char
import Data.Data (Data)
import Data.Functor ((<&>))
-import Data.String (fromString)
import Control.DeepSeq (NFData(..))
@@ -113,8 +120,8 @@ import Control.DeepSeq (NFData(..))
************************************************************************
-}
-newtype ForeignCall = CCall (CCallSpec GhcTc)
- deriving ( Eq )
+newtype ForeignCall = CCall CCallSpec
+ deriving (Eq)
isSafeForeignCall :: ForeignCall -> Bool
isSafeForeignCall (CCall (CCallSpec _ _ safe)) = playSafe safe
@@ -141,12 +148,12 @@ playInterruptible _ = False
************************************************************************
-}
-data CCallSpec pass
- = CCallSpec (CCallTarget pass) -- What to call
- CCallConv -- Calling convention to use.
- Safety
-
-deriving instance forall p. IsPass p => Eq (CCallSpec (GhcPass p))
+data CCallSpec
+ = CCallSpec
+ (CCallTarget GhcTc) -- What to call
+ CCallConv -- Calling convention to use.
+ Safety
+ deriving (Eq)
isDynamicTarget :: CCallTarget p -> Bool
isDynamicTarget DynamicTarget{} = True
@@ -180,7 +187,7 @@ isCLabelString lbl
-- Printing into C files:
-instance forall p. IsPass p => Outputable (CCallSpec (GhcPass p)) where
+instance Outputable CCallSpec where
ppr (CCallSpec fun cconv safety)
= hcat [ whenPprDebug callconv, ppr_fun fun, text " ::" ]
where
@@ -191,15 +198,14 @@ instance forall p. IsPass p => Outputable (CCallSpec (GhcPass p)) where
ppr_fun = \case
DynamicTarget{} -> text "__ffi_dyn_ccall" <> gc_suf <+> text "\"\""
- st@(StaticTarget _ label isFun) ->
+ StaticTarget ext label isFun ->
let pCallType = case isFun of
ForeignValue -> text "__ffi_static_ccall_value"
ForeignFunction -> text "__ffi_static_ccall"
- (srcTxt, pPkgId) = case ghcPass @p of
- GhcPs | StaticTarget ext _ _ <- st -> (ext, empty)
- GhcRn | StaticTarget ext _ _ <- st -> (staticTargetLabel ext, ppr $ staticTargetUnit ext)
- GhcTc | StaticTarget ext _ _ <- st -> (staticTargetLabel ext, ppr $ staticTargetUnit ext)
-
+ pprUnit ext = case staticTargetUnit ext of
+ TargetIsInThisUnit -> empty
+ TargetIsInThat unit -> ppr unit
+ (srcTxt, pPkgId) = (staticTargetLabel ext, pprUnit ext)
in pCallType
<> gc_suf
<+> pPkgId
@@ -209,12 +215,21 @@ instance forall p. IsPass p => Outputable (CCallSpec (GhcPass p)) where
defaultCType :: String -> CType (GhcPass p)
defaultCType =
- CType (CTypeGhc NoSourceText NoSourceText) Nothing . fromString
+ CType (CTypeGhc NoSourceText NoSourceText) Nothing . fsLit
-mkCType :: SourceText -> SourceText -> Maybe Header -> FastString -> CType (GhcPass p)
+mkCType :: SourceText -> SourceText -> Maybe (Header (GhcPass p)) -> FastString -> CType (GhcPass p)
mkCType x y m =
CType (CTypeGhc x y) m
+typeCheckCType :: CType GhcRn -> CType GhcTc
+typeCheckCType (CType x y z) = CType x (typeCheckHeader <$> y) z
+
+typeCheckHeader :: Header GhcRn -> Header GhcTc
+typeCheckHeader (Header a b) = Header a b
+
+renameHeader :: Header GhcPs -> Header GhcRn
+renameHeader (Header a b) = Header a b
+
{-
************************************************************************
* *
@@ -227,7 +242,7 @@ instance Binary ForeignCall where
put_ bh (CCall aa) = put_ bh aa
get bh = do aa <- get bh; return (CCall aa)
-instance forall p. IsPass p => Binary (CCallSpec (GhcPass p)) where
+instance Binary CCallSpec where
put_ bh (CCallSpec aa ab ac) = do
put_ bh aa
put_ bh ab
@@ -241,7 +256,7 @@ instance forall p. IsPass p => Binary (CCallSpec (GhcPass p)) where
instance NFData ForeignCall where
rnf (CCall c) = rnf c
-instance forall p. IsPass p => NFData (CCallSpec (GhcPass p)) where
+instance NFData CCallSpec where
rnf (CCallSpec t c s) = rnf t `seq` rnf c `seq` rnf s
instance Binary CCallConv where
@@ -264,12 +279,27 @@ instance Binary CCallConv where
3 -> return CApiConv
_ -> return JavaScriptCallConv
--- If Nothing, then it's taken to be in the current package.
+-- |
+-- Determine whether the JavaScript Foreign Function export should be
+-- dynamically linked or statically linked.
+data ExportLinking
+ = ExportIsDynamic
+ | ExportIsStatic
+
+-- |
+-- Which compilation 'Unit' is the static target in,
+-- either it is in this currently compiling compilation 'Unit',
+-- or it is in /that other/, compilation 'Unit'.
+data CCallStaticTargetUnit
+ = TargetIsInThisUnit -- ^ In this current 'Unit'.
+ | TargetIsInThat Unit -- ^ In that other 'Unit'.
+ deriving (Data, Eq)
+
data StaticTargetGhc = StaticTargetGhc
{ staticTargetLabel :: SourceText
- , staticTargetUnit :: CCallStaticUnit
+ , staticTargetUnit :: CCallStaticTargetUnit
-- ^ What package the function is in.
- -- If 'CCallStaticThisUnit', then it's taken to be in the current package
+ -- If 'CCallStaticTargetUnit', then it's taken to be in the current package
-- Note: This information is only used for PrimCalls on Windows.
-- See CLabel.labelDynamic and CoreToStg.coreToStgApp
-- for the difference in representation between PrimCalls
@@ -290,13 +320,36 @@ type instance XStaticTarget GhcTc = StaticTargetGhc
type instance XDynamicTarget (GhcPass p) = NoExtField
type instance XXCCallTarget (GhcPass p) = DataConCantHappen
-type instance XCType (GhcPass p) = CTypeGhc
-type instance XXCType (GhcPass p) = DataConCantHappen
+type instance XCType (GhcPass p) = CTypeGhc
+type instance XXCType (GhcPass p) = DataConCantHappen
+
+type instance XHeader (GhcPass p) = SourceText
+type instance XXHeader (GhcPass p) = DataConCantHappen
+
+deriving instance Eq (Header (GhcPass p))
instance NFData (CType (GhcPass p)) where
rnf (CType ext mh fs) =
rnf ext `seq` rnf mh `seq` rnf fs
+instance NFData (Header (GhcPass p)) where
+ rnf (Header s h) =
+ rnf s `seq` rnf h
+
+instance NFData CCallStaticTargetUnit where
+ rnf = \case
+ TargetIsInThisUnit -> ()
+ TargetIsInThat unit -> rnf unit
+
+instance Binary CCallStaticTargetUnit where
+ put_ bh = \case
+ TargetIsInThisUnit -> putByte bh 0
+ TargetIsInThat unit -> putByte bh 1 *> put_ bh unit
+
+ get bh = getByte bh >>= \case
+ 0 -> pure TargetIsInThisUnit
+ _ -> TargetIsInThat <$> get bh
+
instance NFData CTypeGhc where
rnf st =
rnf (cTypeSourceText st) `seq`
@@ -406,7 +459,7 @@ instance Binary ForeignKind where
0 -> ForeignValue
_ -> ForeignFunction
-instance Binary Header where
+instance Binary (Header (GhcPass p)) where
put_ bh (Header s h) = put_ bh s >> put_ bh h
get bh = do
s <- get bh
@@ -447,7 +500,7 @@ instance Outputable (CType (GhcPass p)) where
Nothing -> empty
Just h -> ppr h
-instance Outputable Header where
+instance Outputable (Header (GhcPass p)) where
ppr (Header st h) = pprWithSourceText st (doubleQuotes $ ppr h)
instance Outputable Safety where
=====================================
compiler/Language/Haskell/Syntax/Decls.hs
=====================================
@@ -51,12 +51,10 @@ module Language.Haskell.Syntax.Decls (
-- ** Template haskell declaration splice
SpliceDecoration(..),
SpliceDecl(..), LSpliceDecl,
-{-
-- ** Foreign function interface declarations
ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
CCallConv(..), CCallTarget(..), CExportSpec(..), CImportSpec(..), CLabelString,
CType(..), Header(..), Safety(..),
--}
-- ** Data-constructor declarations
ConDecl(..), LConDecl,
HsConDeclH98Details,
=====================================
compiler/Language/Haskell/Syntax/Decls/Foreign.hs
=====================================
@@ -61,19 +61,21 @@ module Language.Haskell.Syntax.Decls.Foreign (
-- ** CType
XCType,
XXCType,
+ -- ** Header
+ XHeader,
+ XXHeader,
) where
import Language.Haskell.Syntax.Extension
import Language.Haskell.Syntax.Type
import GHC.Data.FastString (FastString)
-import GHC.Types.SourceText (SourceText)
import Control.DeepSeq
import Data.Data hiding (TyCon, Fixity, Infix)
import Data.Maybe
import Data.Eq
-import Prelude (Enum, Show, seq)
+import Prelude (Enum, Show)
{-
************************************************************************
@@ -120,27 +122,27 @@ data ForeignDecl pass
-- |
-- Specification Of an imported external entity in dependence on the calling
-- convention
---
--- Import of a C entity
---
--- * the two strings specifying a header file or library
--- may be empty, which indicates the absence of a
--- header or object specification (both are not used
--- in the case of `CWrapper' and when `CFunction'
--- has a dynamic target)
---
--- * the calling convention is irrelevant for code
--- generation in the case of `CLabel', but is needed
--- for pretty printing
---
--- * `Safety' is irrelevant for `CLabel' and `CWrapper'
---
data ForeignImport pass
- = CImport
+ = -- |
+ -- Import of a C entity
+ --
+ -- * the two strings specifying a header file or library
+ -- may be empty, which indicates the absence of a
+ -- header or object specification (both are not used
+ -- in the case of `CWrapper' and when `CFunction'
+ -- has a dynamic target)
+ --
+ -- * the calling convention is irrelevant for code
+ -- generation in the case of `CLabel', but is needed
+ -- for pretty printing
+ --
+ -- * `Safety' is irrelevant for `CLabel' and `CWrapper'
+ --
+ CImport
(XCImport pass)
(XRec pass CCallConv) -- ccall
(XRec pass Safety) -- interruptible, safe or unsafe
- (Maybe Header) -- name of C header
+ (Maybe (Header pass)) -- name of C header
(CImportSpec pass) -- details of the C entity
| XForeignImport !(XXForeignImport pass)
@@ -208,12 +210,6 @@ data CCallTarget pass
| DynamicTarget (XDynamicTarget pass)
| XCCallTarget !(XXCCallTarget pass)
-deriving instance {-# OVERLAPPABLE #-} (
- Eq (XStaticTarget pass),
- Eq (XDynamicTarget pass),
- Eq (XXCCallTarget pass)) =>
- Eq (CCallTarget pass)
-
data CExportSpec
-- | foreign export ccall foo :: ty
= CExportStatic
@@ -227,33 +223,17 @@ type CLabelString = FastString -- A C label, completely unencoded
data CType pass
= CType
(XCType pass)
- (Maybe Header) -- header to include for this type
+ (Maybe (Header pass)) -- header to include for this type
FastString
| XCType !(XXCType pass)
-deriving instance {-# OVERLAPPABLE #-}
- ( Eq (XCType pass)
- , Eq (XXCType pass)
- ) =>
- Eq (CType pass)
-
-instance {-# OVERLAPPABLE #-}
- ( NFData (XCType pass)
- , NFData (XXCType pass)
- ) => NFData (CType pass) where
- rnf = \case
- CType ext mh fs -> rnf ext `seq` rnf mh `seq` rnf fs
- XCType ext -> rnf ext
-
-- The filename for a C header file
-- See Note [Pragma source text] in "GHC.Types.SourceText"
-data Header = Header
- SourceText -- pretty printing to EXT point
- FastString
- deriving (Eq, Data)
-
-instance NFData Header where
- rnf (Header s h) = rnf s `seq` rnf h
+data Header pass
+ = Header
+ (XHeader pass)
+ FastString
+ | XHeader !(XXHeader pass)
data Safety
= PlaySafe -- ^ Might invoke Haskell GC, or do a call back, or
=====================================
compiler/Language/Haskell/Syntax/Extension.hs
=====================================
@@ -392,6 +392,11 @@ type family XXCCallTarget x
type family XCType x
type family XXCType x
+-- -------------------------------------
+-- Header type family
+type family XHeader x
+type family XXHeader x
+
-- -------------------------------------
-- ForeignDecl type families
type family XForeignImport x
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
=====================================
@@ -29,7 +29,7 @@ import Data.Foldable (toList)
import Data.List (intercalate, isPrefixOf)
import Data.Maybe
import Data.Version
-import GHC
+import GHC hiding (Header)
import GHC.Core.InstEnv
import qualified GHC.Driver.DynFlags as DynFlags
import GHC.Driver.Ppr
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
=====================================
@@ -27,7 +27,7 @@ import Data.List (sort)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
-import GHC hiding (HsTypeGhcPsExt (..), fromMaybeContext)
+import GHC hiding (Header, HsTypeGhcPsExt (..), fromMaybeContext)
import GHC.Core.Type (Specificity (..))
import GHC.Data.FastString (unpackFS)
import GHC.Types.Name (getOccString, nameOccName, tidyNameOcc)
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
=====================================
@@ -24,7 +24,7 @@ module Haddock.Backends.Xhtml.DocMarkup
import Data.List (intersperse)
import Data.Maybe (fromMaybe)
-import GHC
+import GHC hiding (Header)
import GHC.Types.Name
import Text.XHtml hiding (name, p, quote)
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/LexParseRn.hs
=====================================
@@ -30,7 +30,7 @@ import Data.Functor
import Data.List (maximumBy, (\\))
import Data.Ord
import qualified Data.Set as Set
-import GHC
+import GHC hiding (Header)
import GHC.Data.EnumSet as EnumSet
import GHC.Data.FastString (unpackFS)
import GHC.Driver.Session
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
=====================================
@@ -33,13 +33,14 @@ import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Data.Traversable (mapM)
-import GHC hiding (NoLink, HsTypeGhcPsExt (..))
+import GHC hiding (Header, NoLink, HsTypeGhcPsExt (..))
import GHC.Builtin.Types (eqTyCon_RDR, tupleDataConName, tupleTyConName)
import GHC.Core.TyCon (tyConResKind)
import GHC.Driver.DynFlags (getDynFlags)
import GHC.Hs.Decls.Overlap (OverlapMode(..))
import GHC.Types.Basic (TupleSort (..))
-import GHC.Types.ForeignCall
+import GHC.Types.ForeignCall hiding (Header)
+import qualified GHC.Types.ForeignCall as Hs (Header(..))
import GHC.Types.Name
import GHC.Types.Name.Reader (RdrName (Exact))
import Language.Haskell.Syntax.BooleanFormula(BooleanFormula(..))
@@ -683,7 +684,10 @@ renameDataDefn
)
renameCType :: CType GhcRn -> CType DocNameI
-renameCType (CType _ y z) = CType NoExtField y z
+renameCType (CType _ y z) = CType NoExtField (renameHeader' <$> y) z
+
+renameHeader' :: Hs.Header GhcRn -> Hs.Header DocNameI
+renameHeader' (Hs.Header _ s) = Hs.Header NoExtField s
renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI)
renameCon
@@ -834,7 +838,8 @@ renameForD (ForeignExport _ lname ltype x) = do
return (ForeignExport noExtField lname' ltype' (renameForE x))
renameForI :: ForeignImport GhcRn -> ForeignImport DocNameI
-renameForI (CImport _ cconv safety mHeader spec) = CImport noExtField cconv safety mHeader (renameForISpec spec)
+renameForI (CImport _ cconv safety mHeader spec) =
+ CImport noExtField cconv safety (renameHeader' <$> mHeader) (renameForISpec spec)
renameForE :: ForeignExport GhcRn -> ForeignExport DocNameI
renameForE (CExport _ spec) = CExport noExtField spec
=====================================
utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs
=====================================
@@ -42,7 +42,7 @@ import Data.IORef
import Data.Map (Map)
import Data.Version
import Data.Word
-import GHC hiding (NoLink)
+import GHC hiding (Header, NoLink)
import GHC.Data.FastMutInt
import GHC.Data.FastString
import GHC.Iface.Binary (getWithUserData, putSymbolTable)
=====================================
utils/haddock/haddock-api/src/Haddock/Types.hs
=====================================
@@ -51,7 +51,7 @@ import Data.Data (Data)
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Set as Set
-import GHC
+import GHC hiding (Header)
import GHC.Data.BooleanFormula (BooleanFormula)
import GHC.Driver.Session (Language)
import qualified GHC.LanguageExtensions as LangExt
@@ -833,6 +833,7 @@ type instance Anno (HsSigType DocNameI) = SrcSpanAnnA
type instance Anno (BooleanFormula DocNameI) = SrcSpanAnnL
type instance Anno (OverlapMode DocNameI) = EpAnn AnnPragma
type instance Anno (CType DocNameI) = EpAnn AnnPragma
+type instance Anno (Header DocNameI) = EpAnn AnnPragma
type XRecCond a =
( XParTy a ~ (EpToken "(", EpToken ")")
@@ -934,6 +935,9 @@ type instance XXCCallTarget DocNameI = DataConCantHappen
type instance XCType DocNameI = NoExtField
type instance XXCType DocNameI = DataConCantHappen
+type instance XHeader DocNameI = NoExtField
+type instance XXHeader DocNameI = DataConCantHappen
+
type instance XConDeclGADT DocNameI = NoExtField
type instance XConDeclH98 DocNameI = NoExtField
type instance XXConDecl DocNameI = DataConCantHappen
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/be1dab4db2cea22c4a7b8548fbc68d…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/be1dab4db2cea22c4a7b8548fbc68d…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
06 Feb '26
Andreas Klebinger pushed to branch wip/andreask/hadrian_race at Glasgow Haskell Compiler / GHC
Commits:
75e48726 by Andreas Klebinger at 2026-02-06T21:11:05+01:00
wibbles
- - - - -
2 changed files:
- libraries/ghc-boot/GHC/Unit/Database.hs
- utils/ghc-pkg/Main.hs
Changes:
=====================================
libraries/ghc-boot/GHC/Unit/Database.hs
=====================================
@@ -418,7 +418,6 @@ isDbOpenReadMode = \case
--
readPackageDbForGhc :: FilePath -> IO [DbUnitInfo]
readPackageDbForGhc file = do
- hPutStrLn stderr $ "readPackageDbForGhc:" ++ show file
withLockedPackageDb DbOpenReadOnly file $ \_ -> do
decodeFromFile file DbOpenReadOnly getDbForGhc >>= \case
(pkgs, DbOpenReadOnly) -> return pkgs
=====================================
utils/ghc-pkg/Main.hs
=====================================
@@ -2249,4 +2249,4 @@ dieOnSingleFileDb :: FilePath -> IO a
dieOnSingleFileDb path =
die $ "ghc no longer supports single-file style package "
++ "databases (" ++ path ++ ") use 'ghc-pkg init'"
- ++ "to create the database with the correct format."
\ No newline at end of file
+ ++ "to create the database with the correct format."
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/75e48726b1a5d92fdb4ce6558fbada7…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/75e48726b1a5d92fdb4ce6558fbada7…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/andreask/hadrian_race] ghc-pkg: Rework locking to make it more stable under concurrent accesses.
by Andreas Klebinger (＠AndreasK) 06 Feb '26
by Andreas Klebinger (＠AndreasK) 06 Feb '26
06 Feb '26
Andreas Klebinger pushed to branch wip/andreask/hadrian_race at Glasgow Haskell Compiler / GHC
Commits:
1b7bcd0d by Andreas Klebinger at 2026-02-06T21:01:35+01:00
ghc-pkg: Rework locking to make it more stable under concurrent accesses.
ghc-pkg will now keep a database locked while reading it.
See Note [ghc-pkg database locking] for details.
I also killed of the remaining workarounds for single file package
databases.
This should fix #22870.
- - - - -
3 changed files:
- docs/users_guide/9.16.1-notes.rst
- libraries/ghc-boot/GHC/Unit/Database.hs
- utils/ghc-pkg/Main.hs
Changes:
=====================================
docs/users_guide/9.16.1-notes.rst
=====================================
@@ -160,6 +160,13 @@ Cmm
the recompilation checker will look at to determine if a module needs to be
recompiled.
+``ghc-pkg`` utility
+~~~~~~~~~~~~~~~~~~~
+
+- A slight rework how package databases are being locked should make ghc-pkg more
+ reliable when multiple invocations try to read/modify a package database at the
+ same time.
+
Included libraries
~~~~~~~~~~~~~~~~~~
=====================================
libraries/ghc-boot/GHC/Unit/Database.hs
=====================================
@@ -58,6 +58,9 @@ module GHC.Unit.Database
, DbMode(..)
, DbOpenMode(..)
, isDbOpenReadMode
+ , dbMode
+ , modeWithLock
+
, readPackageDbForGhc
, readPackageDbForGhcPkg
, writePackageDb
@@ -65,6 +68,7 @@ module GHC.Unit.Database
, PackageDbLock
, lockPackageDb
, unlockPackageDb
+ , withLockedPackageDb
-- * Misc
, mkMungePathUrl
, mungeUnitInfoPaths
@@ -313,6 +317,22 @@ data DbInstUnitId
-- | Represents a lock of a package db.
newtype PackageDbLock = PackageDbLock Handle
+-- | Run the action under a lock, then return the result.
+-- If the mode is R/W the *caller* needs to either free the lock or pass it
+-- on to code that will.
+--
+-- If an exception is raised the lock is released.
+withLockedPackageDb :: DbOpenMode m t -> FilePath -> (PackageDbLock -> IO a) -> IO a
+withLockedPackageDb mode file act = do
+ lock <- lockPackageDbWith (lock_mode mode) file
+ r <- act lock `onException` unlockPackageDb lock
+ when (isDbOpenReadMode mode ) $ unlockPackageDb lock
+ pure r
+ where
+ lock_mode :: DbOpenMode m t -> LockMode
+ lock_mode DbOpenReadOnly = SharedLock
+ lock_mode DbOpenReadWrite{} = ExclusiveLock
+
-- | Acquire an exclusive lock related to package DB under given location.
lockPackageDb :: FilePath -> IO PackageDbLock
@@ -362,12 +382,13 @@ lockPackageDbWith mode file = do
return $ PackageDbLock hnd
lockPackageDb = lockPackageDbWith ExclusiveLock
+
unlockPackageDb (PackageDbLock hnd) = do
hUnlock hnd
hClose hnd
-- | Mode to open a package db in.
-data DbMode = DbReadOnly | DbReadWrite
+data DbMode = DbReadOnly | DbReadWrite deriving Eq
-- | 'DbOpenMode' holds a value of type @t@ but only in 'DbReadWrite' mode. So
-- it is like 'Maybe' but with a type argument for the mode to enforce that the
@@ -380,6 +401,14 @@ deriving instance Functor (DbOpenMode mode)
deriving instance F.Foldable (DbOpenMode mode)
deriving instance F.Traversable (DbOpenMode mode)
+dbMode :: DbOpenMode m t -> DbMode
+dbMode DbOpenReadOnly = DbReadOnly
+dbMode DbOpenReadWrite{} = DbReadWrite
+
+modeWithLock :: PackageDbLock -> DbOpenMode m t -> DbOpenMode m PackageDbLock
+modeWithLock _ DbOpenReadOnly = DbOpenReadOnly
+modeWithLock l DbOpenReadWrite{} = DbOpenReadWrite l
+
isDbOpenReadMode :: DbOpenMode mode t -> Bool
isDbOpenReadMode = \case
DbOpenReadOnly -> True
@@ -388,9 +417,11 @@ isDbOpenReadMode = \case
-- | Read the part of the package DB that GHC is interested in.
--
readPackageDbForGhc :: FilePath -> IO [DbUnitInfo]
-readPackageDbForGhc file =
- decodeFromFile file DbOpenReadOnly getDbForGhc >>= \case
- (pkgs, DbOpenReadOnly) -> return pkgs
+readPackageDbForGhc file = do
+ hPutStrLn stderr $ "readPackageDbForGhc:" ++ show file
+ withLockedPackageDb DbOpenReadOnly file $ \_ -> do
+ decodeFromFile file DbOpenReadOnly getDbForGhc >>= \case
+ (pkgs, DbOpenReadOnly) -> return pkgs
where
getDbForGhc = do
_version <- getHeader
@@ -405,11 +436,13 @@ readPackageDbForGhc file =
-- is not defined in this package. This is because ghc-pkg uses Cabal types
-- (and Binary instances for these) which this package does not depend on.
--
+-- The incoming mode carries the exclusive lock if we are in R/W mode.
+--
-- If we open the package db in read only mode, we get its contents. Otherwise
-- we additionally receive a PackageDbLock that represents a lock on the
-- database, so that we can safely update it later.
--
-readPackageDbForGhcPkg :: Binary pkgs => FilePath -> DbOpenMode mode t ->
+readPackageDbForGhcPkg :: Binary pkgs => FilePath -> DbOpenMode mode PackageDbLock ->
IO (pkgs, DbOpenMode mode PackageDbLock)
readPackageDbForGhcPkg file mode =
decodeFromFile file mode getDbForGhcPkg
@@ -496,26 +529,19 @@ headerMagic = BS.Char8.pack "\0ghcpkg\0"
-- | Feed a 'Get' decoder with data chunks from a file.
--
-decodeFromFile :: FilePath -> DbOpenMode mode t -> Get pkgs ->
+-- The file is already locked when we call this. We only need to pass it on
+-- if we are in R/W mode.
+decodeFromFile :: FilePath -> DbOpenMode mode PackageDbLock -> Get pkgs ->
IO (pkgs, DbOpenMode mode PackageDbLock)
decodeFromFile file mode decoder = case mode of
DbOpenReadOnly -> do
- -- Note [Locking package database on Windows]
- -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- -- When we open the package db in read only mode, there is no need to acquire
- -- shared lock on non-Windows platform because we update the database with an
- -- atomic rename, so readers will always see the database in a consistent
- -- state.
-#if defined(mingw32_HOST_OS)
- bracket (lockPackageDbWith SharedLock file) unlockPackageDb $ \_ -> do
-#endif
(, DbOpenReadOnly) <$> decodeFileContents
DbOpenReadWrite{} -> do
- -- When we open the package db in read/write mode, acquire an exclusive lock
- -- on the database and return it so we can keep it for the duration of the
+ -- When we open the package db in read/write mode, we receive an exclusive lock
+ -- on the database via the mode and return it so we can keep it for the duration of the
-- update.
- bracketOnError (lockPackageDb file) unlockPackageDb $ \lock -> do
- (, DbOpenReadWrite lock) <$> decodeFileContents
+ -- If an exception is raised the caller releases the lock.
+ (, mode) <$> decodeFileContents
where
decodeFileContents = withBinaryFile file ReadMode $ \hnd ->
feed hnd (runGetIncremental decoder)
=====================================
utils/ghc-pkg/Main.hs
=====================================
@@ -8,6 +8,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE PartialTypeSignatures #-}
{-# OPTIONS_GHC -Wno-orphans -Wno-x-partial #-}
-- Fine if this comes from make/Hadrian or the pre-built base.
@@ -872,6 +873,23 @@ lookForPackageDBIn dir = do
exists_file <- doesFileExist path_file
if exists_file then return (Just path_file) else return Nothing
+{- Note [ghc-pkg database locking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We differentiate the read only (RO) and read write (R/W) cases.
+
+The general idea is we use `withLockedPackageDb` to lock an already existing
+database in both modes. In RO mode we simply unlock the DB once we read it.
+The unlocking is also handled by withLockedPackageDb.
+
+For the R/W case withLockedPackageDb will *lock* the database, and handle unlocking
+in the case of exceptions. But rather than unlocking it once the argument has been
+executed without error we simply pass along the lock inside either a `DbOpenMode` or `PackageDB`
+so we can keep holding while doing one or more modifications.
+
+The alternative would be to rewrite much of this in a CPS/bracket style and I couldn't
+quite bring myself to do so.
+
+-}
readParseDatabase :: forall mode t. Verbosity
-> Maybe (FilePath,Bool)
-> GhcPkg.DbOpenMode mode t
@@ -889,83 +907,79 @@ readParseDatabase verbosity mb_user_conf mode use_cache path
= do e <- tryIO $ getDirectoryContents path
case e of
Left err
- | ioeGetErrorType err == InappropriateType -> do
- -- We provide a limited degree of backwards compatibility for
- -- old single-file style db:
- mdb <- tryReadParseOldFileStyleDatabase verbosity
- mb_user_conf mode use_cache path
- case mdb of
- Just db -> return db
- Nothing ->
- die $ "ghc no longer supports single-file style package "
- ++ "databases (" ++ path ++ ") use 'ghc-pkg init'"
- ++ "to create the database with the correct format."
-
+ | ioeGetErrorType err == InappropriateType -> dieOnSingleFileDb path
| otherwise -> ioError err
- Right fs
- | not use_cache -> ignore_cache (const $ return ())
- | otherwise -> do
- e_tcache <- tryIO $ getModificationTime cache
- case e_tcache of
- Left ex -> do
- whenReportCacheErrors $
- if isDoesNotExistError ex
- then
- -- It's fine if the cache is not there as long as the
- -- database is empty.
- when (not $ null confs) $ do
- warn ("WARNING: cache does not exist: " ++ cache)
- warn ("ghc will fail to read this package db. " ++
- recacheAdvice)
- else do
- warn ("WARNING: cache cannot be read: " ++ show ex)
- warn "ghc will fail to read this package db."
- ignore_cache (const $ return ())
- Right tcache -> do
- when (verbosity >= Verbose) $ do
- warn ("Timestamp " ++ show tcache ++ " for " ++ cache)
- -- If any of the .conf files is newer than package.cache, we
- -- assume that cache is out of date.
- cache_outdated <- (`anyM` confs) $ \conf ->
- (tcache <) <$> getModificationTime conf
- if not cache_outdated
- then do
- when (verbosity > Normal) $
- infoLn ("using cache: " ++ cache)
- GhcPkg.readPackageDbForGhcPkg cache mode
- >>= uncurry mkPackageDB
- else do
- whenReportCacheErrors $ do
- warn ("WARNING: cache is out of date: " ++ cache)
- warn ("ghc will see an old view of this " ++
- "package db. " ++ recacheAdvice)
- ignore_cache $ \file -> do
- when (verbosity >= Verbose) $ do
- tFile <- getModificationTime file
- let rel = case tcache `compare` tFile of
- LT -> " (NEWER than cache)"
- GT -> " (older than cache)"
- EQ -> " (same as cache)"
- warn ("Timestamp " ++ show tFile
- ++ " for " ++ file ++ rel)
- where
- confs = map (path </>) $ filter (".conf" `isSuffixOf`) fs
-
- ignore_cache :: (FilePath -> IO ()) -> IO (PackageDB mode)
- ignore_cache checkTime = do
- -- If we're opening for modification, we need to acquire a
- -- lock even if we don't open the cache now, because we are
- -- going to modify it later.
- lock <- F.mapM (const $ GhcPkg.lockPackageDb cache) mode
- let doFile f = do checkTime f
- parseSingletonPackageConf verbosity f
- pkgs <- mapM doFile confs
- mkPackageDB pkgs lock
-
- -- We normally report cache errors for read-only commands,
- -- since modify commands will usually fix the cache.
- whenReportCacheErrors = when $ verbosity > Normal
- || verbosity >= Normal && GhcPkg.isDbOpenReadMode mode
+ -- Take a lock to use while we read the DB
+ Right fs -> withLockedPackageDb mode cache $ \lock -> do
+ if not use_cache
+ then ignore_cache (lock) (const $ return ())
+ else do
+ e_tcache <- tryIO $ getModificationTime cache
+ case e_tcache of
+ Left ex -> do
+ whenReportCacheErrors $
+ if isDoesNotExistError ex
+ then
+ -- It's fine if the cache is not there as long as the
+ -- database is empty.
+ when (not $ null confs) $ do
+ warn ("WARNING: cache does not exist: " ++ cache)
+ warn ("ghc will fail to read this package db. " ++
+ recacheAdvice)
+ else do
+ warn ("WARNING: cache cannot be read: " ++ show ex)
+ warn "ghc will fail to read this package db."
+ ignore_cache (lock) (const $ return ())
+ Right tcache -> do
+ when (verbosity >= Verbose) $ do
+ warn ("Timestamp " ++ show tcache ++ " for " ++ cache)
+ -- If any of the .conf files is newer than package.cache, we
+ -- assume that cache is out of date.
+ cache_outdated <- (`anyM` confs) $ \conf ->
+ (tcache <) <$> getModificationTime conf
+ if not cache_outdated
+ then do
+ when (verbosity > Normal) $
+ infoLn ("using cache: " ++ cache)
+ GhcPkg.readPackageDbForGhcPkg cache (modeWithLock lock mode)
+ >>= uncurry mkPackageDB
+ else do
+ whenReportCacheErrors $ do
+ warn ("WARNING: cache is out of date: " ++ cache)
+ warn ("ghc will see an old view of this " ++
+ "package db. " ++ recacheAdvice)
+ ignore_cache (lock) $ \file -> do
+ when (verbosity >= Verbose) $ do
+ tFile <- getModificationTime file
+ let rel = case tcache `compare` tFile of
+ LT -> " (NEWER than cache)"
+ GT -> " (older than cache)"
+ EQ -> " (same as cache)"
+ warn ("Timestamp " ++ show tFile
+ ++ " for " ++ file ++ rel)
+ where
+ confs = map (path </>) $ filter (".conf" `isSuffixOf`) fs
+
+ -- Read the package db, potentially locking the .cache file for r/w mode.
+ ignore_cache :: PackageDbLock -> (FilePath -> IO ()) -> IO (PackageDB mode)
+ ignore_cache lock checkTime = do
+ -- If we're opening for modification, we need to acquire a
+ -- lock even if we don't open the cache now, because we are
+ -- going to modify it later.
+
+ -- mode' <- F.mapM (const $ GhcPkg.lockPackageDb cache) mode
+
+ let doFile f = do checkTime f
+ parseSingletonPackageConf verbosity f
+ pkgs <- mapM doFile confs
+
+ -- mkPackageDB pkgs mode'
+ mkPackageDB pkgs (modeWithLock lock mode)
+
+ -- We normally report cache errors for read-only commands,
+ -- since modify commands will usually fix the cache.
+ whenReportCacheErrors = when $ verbosity > Normal
+ || verbosity >= Normal && GhcPkg.isDbOpenReadMode mode
where
cache = path </> cachefilename
@@ -1060,75 +1074,16 @@ mkMungePathUrl top_dir pkgroot = (munge_path, munge_url)
Just cs@(c : _) | isPathSeparator c -> Just cs
_ -> Nothing
--- -----------------------------------------------------------------------------
--- Workaround for old single-file style package dbs
-
--- Single-file style package dbs have been deprecated for some time, but
--- it turns out that Cabal was using them in one place. So this code is for a
--- workaround to allow older Cabal versions to use this newer ghc.
-
--- We check if the file db contains just "[]" and if so, we look for a new
--- dir-style db in path.d/, ie in a dir next to the given file.
--- We cannot just replace the file with a new dir style since Cabal still
--- assumes it's a file and tries to overwrite with 'writeFile'.
-
--- ghc itself also cooperates in this workaround
-
-tryReadParseOldFileStyleDatabase :: Verbosity -> Maybe (FilePath, Bool)
- -> GhcPkg.DbOpenMode mode t -> Bool -> FilePath
- -> IO (Maybe (PackageDB mode))
-tryReadParseOldFileStyleDatabase verbosity mb_user_conf
- mode use_cache path = do
- -- assumes we've already established that path exists and is not a dir
- content <- readFile path `catchIO` \_ -> return ""
- if take 2 content == "[]"
- then do
- path_abs <- absolutePath path
- let path_dir = adjustOldDatabasePath path
- warn $ "Warning: ignoring old file-style db and trying " ++ path_dir
- direxists <- doesDirectoryExist path_dir
- if direxists
- then do
- db <- readParseDatabase verbosity mb_user_conf mode use_cache path_dir
- -- but pretend it was at the original location
- return $ Just db {
- location = path,
- locationAbsolute = path_abs
- }
- else do
- lock <- F.forM mode $ \_ -> do
- createDirectoryIfMissing True path_dir
- GhcPkg.lockPackageDb $ path_dir </> cachefilename
- return $ Just PackageDB {
- location = path,
- locationAbsolute = path_abs,
- packageDbLock = lock,
- packages = []
- }
-
- -- if the path is not a file, or is not an empty db then we fail
- else return Nothing
-
+-- | Just preserved to give a more informative error
adjustOldFileStylePackageDB :: PackageDB mode -> IO (PackageDB mode)
adjustOldFileStylePackageDB db = do
-- assumes we have not yet established if it's an old style or not
mcontent <- liftM Just (readFile (location db)) `catchIO` \_ -> return Nothing
- case fmap (take 2) mcontent of
+ case mcontent of
-- it is an old style and empty db, so look for a dir kind in location.d/
- Just "[]" -> return db {
- location = adjustOldDatabasePath $ location db,
- locationAbsolute = adjustOldDatabasePath $ locationAbsolute db
- }
- -- it is old style but not empty, we have to bail
- Just _ -> die $ "ghc no longer supports single-file style package "
- ++ "databases (" ++ location db ++ ") use 'ghc-pkg init'"
- ++ "to create the database with the correct format."
- -- probably not old style, carry on as normal
+ Just _ -> dieOnSingleFileDb (location db)
Nothing -> return db
-adjustOldDatabasePath :: FilePath -> FilePath
-adjustOldDatabasePath = (<.> "d")
-
-- -----------------------------------------------------------------------------
-- Creating a new package DB
@@ -2289,3 +2244,9 @@ removeFileSafe fn =
-- absolute path.
absolutePath :: FilePath -> IO FilePath
absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory
+
+dieOnSingleFileDb :: FilePath -> IO a
+dieOnSingleFileDb path =
+ die $ "ghc no longer supports single-file style package "
+ ++ "databases (" ++ path ++ ") use 'ghc-pkg init'"
+ ++ "to create the database with the correct format."
\ No newline at end of file
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1b7bcd0d7caf8e96d6b2ae5fd3b5a54…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1b7bcd0d7caf8e96d6b2ae5fd3b5a54…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc] Pushed new branch wip/andreask/hadrian_race
by Andreas Klebinger (＠AndreasK) 06 Feb '26
by Andreas Klebinger (＠AndreasK) 06 Feb '26
06 Feb '26
Andreas Klebinger pushed new branch wip/andreask/hadrian_race at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/andreask/hadrian_race
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 9 commits: Fix subtle bug in GHC.Core.Utils.mkTick
by Marge Bot (＠marge-bot) 06 Feb '26
by Marge Bot (＠marge-bot) 06 Feb '26
06 Feb '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
cbe4300e by Simon Peyton Jones at 2026-02-05T04:31:04-05:00
Fix subtle bug in GHC.Core.Utils.mkTick
This patch fixes a decade-old bug in `mkTick`, which
could generate type-incorrect code! See the diagnosis
in #26772.
The new code is simpler and easier to understand.
(As #26772 says, I think it could be improved further.)
- - - - -
a193a8da by Simon Peyton Jones at 2026-02-05T04:31:04-05:00
Modify a debug-trace in the Simplifier
...just to show a bit more information.
- - - - -
b579dfdc by Simon Peyton Jones at 2026-02-05T04:31:04-05:00
Fix long-standing interaction between ticks and casts
The code for Note [Eliminate Identity Cases] was simply wrong when
ticks and casts interacted. This patch fixes the interaction.
It was shown up when validating #26772, although it's not the exactly
the bug that's reported by #26772. Nor is it easy to reproduce, hence
no regression test.
- - - - -
fac0de1e by Cheng Shao at 2026-02-05T04:31:49-05:00
libraries: bump Cabal submodule to 3.16.1.0
- - - - -
00589122 by Cheng Shao at 2026-02-05T04:31:49-05:00
libraries: bump deepseq submodule to 1.5.2.0
Also:
- Get rid of usage of deprecated `NFData` function instance in the
compiler
- `T21391` still relies on `NFData` function instance, add
`-Wno-deprecations` for the time being.
- - - - -
84474c71 by Cheng Shao at 2026-02-05T04:31:50-05:00
libraries: bump directory submodule to 1.3.10.1
- - - - -
1a9f4662 by Cheng Shao at 2026-02-05T04:31:50-05:00
libraries: bump exceptions submodule to 0.10.12
- - - - -
b1fa7890 by Teo Camarasu at 2026-02-06T13:43:54-05:00
ghc-internal: Delete unnecessary GHC.Internal.Data.Ix
This module merely re-exports GHC.Internal.Ix. It was copied from
`base` when `ghc-internal` was split, but there is no reason to have
this now. So, let's delete it.
Resolves #26848
- - - - -
2bfb6339 by Andreas Klebinger at 2026-02-06T13:43:55-05:00
hadrian/build-cabal: Better respect and utilize -j
* We now respect -j<n> for the cabal invocation to build hadrian rather
than hardcoding -j
* We use the --semaphore flag to ensure cabal/ghc build the hadrian
executable in parallel using the -jsem mechanism.
Saves 10-15s on fresh builds for me.
Fixes #26876
- - - - -
23 changed files:
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/Unit/Module/ModIface.hs
- hadrian/build-cabal
- libraries/Cabal
- libraries/base/src/Data/Ix.hs
- libraries/deepseq
- libraries/directory
- libraries/exceptions
- libraries/ghc-internal/ghc-internal.cabal.in
- − libraries/ghc-internal/src/GHC/Internal/Data/Ix.hs
- testsuite/tests/ghci.debugger/scripts/T26042b.stdout
- testsuite/tests/ghci.debugger/scripts/T26042c.stdout
- testsuite/tests/ghci.debugger/scripts/T26042d2.stdout
- testsuite/tests/ghci.debugger/scripts/T26042f2.stdout
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- testsuite/tests/simplCore/should_compile/T21391.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -1713,6 +1713,7 @@ simplCast env body co0 cont0
, sc_hole_ty = coercionLKind co }) }
-- NB! As the cast goes past, the
-- type of the hole changes (#16312)
+
-- (f |> co) e ===> (f (e |> co1)) |> co2
-- where co :: (s1->s2) ~ (t1->t2)
-- co1 :: t1 ~ s1
@@ -1838,7 +1839,7 @@ simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se
, not ( isSimplified dup && -- See (SR2) in Note [Avoiding simplifying repeatedly]
not (exprIsTrivial arg) &&
not (isDeadOcc (idOccInfo bndr)) )
- -> do { simplTrace "SimplBindr:inline-uncond3" (ppr bndr) $
+ -> do { simplTrace "SimplBindr:inline-uncond3" (ppr bndr <+> text ":=" <+> ppr arg $$ ppr (seIdSubst env)) $
tick (PreInlineUnconditionally bndr)
; simplLam env' body cont }
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -72,6 +72,7 @@ import GHC.Types.Tickish
import GHC.Types.Demand
import GHC.Types.Var.Set
import GHC.Types.Basic
+import GHC.Types.Name.Env
import GHC.Data.OrdList ( isNilOL )
import GHC.Data.FastString ( fsLit )
@@ -81,9 +82,9 @@ import GHC.Utils.Monad
import GHC.Utils.Outputable
import GHC.Utils.Panic
-import Control.Monad ( when )
+import Control.Monad ( guard, when )
import Data.List ( sortBy )
-import GHC.Types.Name.Env
+import Data.Maybe
import Data.Graph
{- *********************************************************************
@@ -2570,7 +2571,27 @@ Note [Eliminate Identity Case]
True -> True;
False -> False
-and similar friends.
+and similar friends. There are some tricky wrinkles:
+
+(EIC1) Casts. We've seen this:
+ case e of x { _ -> x `cast` c }
+ And we definitely want to eliminate this case, to give
+ e `cast` c
+(EIC2) Ticks. Similarly
+ case e of x { _ -> Tick t x }
+ At least if the tick is 'floatable' we want to eliminate the case
+ to give
+ Tick t e
+
+So `check_eq` strips off enclosing casts and ticks from the RHS of the
+alternative, returning a wrapper function that will rebuild them around
+the scrutinee if case-elim is successful.
+
+(EIC3) What if there are many alternatives, all identities. If casts
+ are involved they must be the same cast, to make the types line up.
+ In principle there could be different ticks in each RHS, but we just
+ pick the ticks from the first alternative. (In the common case there
+ is only one alternative.)
Note [Scrutinee Constant Folding]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2764,45 +2785,47 @@ mkCase mode scrut outer_bndr alts_ty alts
-- See Note [Eliminate Identity Case]
--------------------------------------------------
-mkCase1 _mode scrut case_bndr _ alts@(Alt _ _ rhs1 : alts') -- Identity case
- | all identity_alt alts
+mkCase1 _mode scrut case_bndr _ (alt1 : alts) -- Identity case
+ | Just wrap <- identity_alt alt1 -- `wrap`: see (EIC1) and (EIC2)
+ , all (isJust . identity_alt) alts -- See (EIC3) in Note [Eliminate Identity Case]
= do { tick (CaseIdentity case_bndr)
- ; return (mkTicks ticks $ re_cast scrut rhs1) }
+ ; return (wrap scrut) }
where
- ticks = concatMap (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) alts'
- identity_alt (Alt con args rhs) = check_eq rhs con args
-
- check_eq (Cast rhs co) con args -- See Note [RHS casts]
- = not (any (`elemVarSet` tyCoVarsOfCo co) args) && check_eq rhs con args
- check_eq (Tick t e) alt args
- = tickishFloatable t && check_eq e alt args
-
- check_eq (Lit lit) (LitAlt lit') _ = lit == lit'
- check_eq (Var v) _ _ | v == case_bndr = True
- check_eq (Var v) (DataAlt con) args
- | null arg_tys, null args = v == dataConWorkId con
- -- Optimisation only
- check_eq rhs (DataAlt con) args = cheapEqExpr' tickishFloatable rhs $
- mkConApp2 con arg_tys args
- check_eq _ _ _ = False
+ identity_alt :: CoreAlt -> Maybe (CoreExpr -> CoreExpr)
+ identity_alt (Alt con args rhs) = check_eq con args rhs
+
+ check_eq :: AltCon -> [Var] -> CoreExpr -> Maybe (CoreExpr -> CoreExpr)
+ -- (check_eq con args e) return True if
+ -- e looks like (Tick (Cast (Tick (con args))))
+ -- where (con args) is the LHS of the alternative
+ -- In that case it returns (\e. Tick (Cast (Tick e))),
+ -- a wrapper function that can rebuild the tick/cast stuff
+ -- See (EIC1) and (EIC2) in Note [Eliminate Identity Case]
+ check_eq alt_con args (Cast e co) -- See (EIC1)
+ = do { guard (not (any (`elemVarSet` tyCoVarsOfCo co) args))
+ ; wrap <- check_eq alt_con args e
+ ; return (flip mkCast co . wrap) }
+ check_eq alt_con args (Tick t e) -- See (EIC2)
+ = do { guard (tickishFloatable t)
+ ; wrap <- check_eq alt_con args e
+ ; return (Tick t . wrap) }
+ check_eq alt_con args e
+ | is_id alt_con args e = Just (\e -> e)
+ | otherwise = Nothing
+
+ is_id :: AltCon -> [Var] -> CoreExpr -> Bool
+ is_id _ _ (Var v) | v == case_bndr = True
+ is_id (LitAlt lit') _ (Lit lit) = lit == lit'
+ is_id (DataAlt con) args rhs
+ | Var v <- rhs -- Optimisation only
+ , null arg_tys
+ , null args = v == dataConWorkId con
+ | otherwise = cheapEqExpr' tickishFloatable rhs $
+ mkConApp2 con arg_tys args
+ is_id _ _ _ = False
arg_tys = tyConAppArgs (idType case_bndr)
- -- Note [RHS casts]
- -- ~~~~~~~~~~~~~~~~
- -- We've seen this:
- -- case e of x { _ -> x `cast` c }
- -- And we definitely want to eliminate this case, to give
- -- e `cast` c
- -- So we throw away the cast from the RHS, and reconstruct
- -- it at the other end. All the RHS casts must be the same
- -- if (all identity_alt alts) holds.
- --
- -- Don't worry about nested casts, because the simplifier combines them
-
- re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co
- re_cast scrut _ = scrut
-
mkCase1 mode scrut bndr alts_ty alts = mkCase2 mode scrut bndr alts_ty alts
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -252,7 +252,7 @@ applyTypeToArgs op_ty args
mkCastMCo :: CoreExpr -> MCoercionR -> CoreExpr
mkCastMCo e MRefl = e
-mkCastMCo e (MCo co) = Cast e co
+mkCastMCo e (MCo co) = mkCast e co
-- We are careful to use (MCo co) only when co is not reflexive
-- Hence (Cast e co) rather than (mkCast e co)
@@ -305,40 +305,41 @@ mkCast expr co
-- | Wraps the given expression in the source annotation, dropping the
-- annotation if possible.
mkTick :: CoreTickish -> CoreExpr -> CoreExpr
-mkTick t orig_expr = mkTick' id id orig_expr
+mkTick t orig_expr = mkTick' id orig_expr
where
-- Some ticks (cost-centres) can be split in two, with the
-- non-counting part having laxer placement properties.
canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t
+
-- mkTick' handles floating of ticks *into* the expression.
- -- In this function, `top` is applied after adding the tick, and `rest` before.
- -- This will result in applications that look like (top $ Tick t $ rest expr).
- -- If we want to push the tick deeper, we pre-compose `top` with a function
- -- adding the tick.
- mkTick' :: (CoreExpr -> CoreExpr) -- apply after adding tick (float through)
- -> (CoreExpr -> CoreExpr) -- apply before adding tick (float with)
- -> CoreExpr -- current expression
+ mkTick' :: (CoreExpr -> CoreExpr) -- Apply before adding tick (float with)
+ -- Always a composition of (Tick t) wrappers
+ -> CoreExpr -- Current expression
-> CoreExpr
- mkTick' top rest expr = case expr of
+ -- So in the call (mkTick' rest e), the expression
+ -- (rest e)
+ -- has the same type as e
+ -- Returns an expression equivalent to (Tick t (rest e))
+ mkTick' rest expr = case expr of
-- Float ticks into unsafe coerce the same way we would do with a cast.
Case scrut bndr ty alts@[Alt ac abs _rhs]
| Just rhs <- isUnsafeEqualityCase scrut bndr alts
- -> top $ mkTick' (\e -> Case scrut bndr ty [Alt ac abs e]) rest rhs
+ -> Case scrut bndr ty [Alt ac abs (mkTick' rest rhs)]
-- Cost centre ticks should never be reordered relative to each
-- other. Therefore we can stop whenever two collide.
Tick t2 e
- | ProfNote{} <- t2, ProfNote{} <- t -> top $ Tick t $ rest expr
+ | ProfNote{} <- t2, ProfNote{} <- t -> Tick t $ rest expr
-- Otherwise we assume that ticks of different placements float
-- through each other.
- | tickishPlace t2 /= tickishPlace t -> mkTick' (top . Tick t2) rest e
+ | tickishPlace t2 /= tickishPlace t -> Tick t2 $ mkTick' rest e
-- For annotations this is where we make sure to not introduce
-- redundant ticks.
- | tickishContains t t2 -> mkTick' top rest e
- | tickishContains t2 t -> orig_expr
- | otherwise -> mkTick' top (rest . Tick t2) e
+ | tickishContains t t2 -> mkTick' rest e -- Drop t2
+ | tickishContains t2 t -> rest e -- Drop t
+ | otherwise -> mkTick' (rest . Tick t2) e
-- Ticks don't care about types, so we just float all ticks
-- through them. Note that it's not enough to check for these
@@ -346,14 +347,14 @@ mkTick t orig_expr = mkTick' id id orig_expr
-- expressions below ticks, such constructs can be the result of
-- unfoldings. We therefore make an effort to put everything into
-- the right place no matter what we start with.
- Cast e co -> mkTick' (top . flip Cast co) rest e
- Coercion co -> Coercion co
+ Cast e co -> mkCast (mkTick' rest e) co
+ Coercion co -> Tick t $ rest (Coercion co)
Lam x e
-- Always float through type lambdas. Even for non-type lambdas,
-- floating is allowed for all but the most strict placement rule.
| not (isRuntimeVar x) || tickishPlace t /= PlaceRuntime
- -> mkTick' (top . Lam x) rest e
+ -> Lam x $ mkTick' rest e
-- If it is both counting and scoped, we split the tick into its
-- two components, often allowing us to keep the counting tick on
@@ -362,25 +363,25 @@ mkTick t orig_expr = mkTick' id id orig_expr
-- floated, and the lambda may then be in a position to be
-- beta-reduced.
| canSplit
- -> top $ Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e
+ -> Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e
App f arg
-- Always float through type applications.
| not (isRuntimeArg arg)
- -> mkTick' (top . flip App arg) rest f
+ -> App (mkTick' rest f) arg
-- We can also float through constructor applications, placement
-- permitting. Again we can split.
| isSaturatedConApp expr && (tickishPlace t==PlaceCostCentre || canSplit)
-> if tickishPlace t == PlaceCostCentre
- then top $ rest $ tickHNFArgs t expr
- else top $ Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr
+ then rest $ tickHNFArgs t expr
+ else Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr
Var x
| notFunction && tickishPlace t == PlaceCostCentre
- -> orig_expr
+ -> rest expr -- Drop t
| notFunction && canSplit
- -> top $ Tick (mkNoScope t) $ rest expr
+ -> Tick (mkNoScope t) $ rest expr
where
-- SCCs can be eliminated on variables provided the variable
-- is not a function. In these cases the SCC makes no difference:
@@ -392,10 +393,10 @@ mkTick t orig_expr = mkTick' id id orig_expr
Lit{}
| tickishPlace t == PlaceCostCentre
- -> orig_expr
+ -> rest expr -- Drop t
-- Catch-all: Annotate where we stand
- _any -> top $ Tick t $ rest expr
+ _any -> Tick t $ rest expr
mkTicks :: [CoreTickish] -> CoreExpr -> CoreExpr
mkTicks ticks expr = foldr mkTick expr ticks
=====================================
compiler/GHC/Tc/Instance/Class.hs
=====================================
@@ -49,6 +49,7 @@ import GHC.Core.Make ( mkCharExpr, mkNaturalExpr, mkStringExprFS, mkCoreLams )
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Core.Class
+import GHC.Core.Utils( mkCast )
import GHC.Core ( Expr(..), mkConApp )
import GHC.StgToCmm.Closure ( isSmallFamily )
@@ -455,7 +456,7 @@ matchWithDict [cls_ty, mty]
= mkCoreLams [ runtimeRep1TyVar, openAlphaTyVar, sv, k ] $
Var k `App` (evUnaryDictAppE cls dict_args meth_arg)
where
- meth_arg = Var sv `Cast` mkSubCo (evExprCoercion ev_expr)
+ meth_arg = Var sv `mkCast` mkSubCo (evExprCoercion ev_expr)
; let mk_ev [c] = evDictApp wd_cls [cls_ty, mty] [evWithDict c]
mk_ev e = pprPanic "matchWithDict" (ppr e)
@@ -657,7 +658,7 @@ matchDataToTag dataToTagClass [levity, dty] = do
(mkReflCo Representational intPrimTy)
-> do { addUsedDataCons rdr_env repTyCon -- See wrinkles DTW2 and DTW3
; let mk_ev _ = evDictApp dataToTagClass [levity, dty] $
- [methodRep `Cast` methodCo]
+ [methodRep `mkCast` methodCo]
; pure (OneInst { cir_new_theta = [] -- (Ignore stupid theta.)
, cir_mk_ev = mk_ev
, cir_canonical = EvCanonical
=====================================
compiler/GHC/Tc/Types/Evidence.hs
=====================================
@@ -59,6 +59,7 @@ import GHC.Tc.Utils.TcType
import GHC.Core
import GHC.Core.Coercion.Axiom
import GHC.Core.Coercion
+import GHC.Core.Utils( mkCast )
import GHC.Core.Ppr () -- Instance OutputableBndr TyVar
import GHC.Core.Predicate
import GHC.Core.Type
@@ -930,7 +931,7 @@ evCastE ee co
| assertPpr (coercionRole co == Representational)
(vcat [text "Coercion of wrong role passed to evCastE:", ppr ee, ppr co]) $
isReflCo co = ee
- | otherwise = Cast ee co
+ | otherwise = mkCast ee co
evDFunApp :: DFunId -> [Type] -> [EvExpr] -> EvTerm
-- Dictionary instance application, including when the "dictionary function"
=====================================
compiler/GHC/Unit/Module/ModIface.hs
=====================================
@@ -894,13 +894,7 @@ instance (NFData (IfaceAbiHashesExts phase), NFData (IfaceDeclExts phase)) => NF
`seq` rnf a14
instance NFData IfaceCache where
- rnf (IfaceCache a1 a2 a3 a4)
- = rnf a1
- `seq` rnf a2
- `seq` rnf a3
- `seq` rnf a4
-
-
+ rnf = rwhnf
forceModIface :: ModIface -> IO ()
forceModIface iface = () <$ (evaluate $ force iface)
=====================================
hadrian/build-cabal
=====================================
@@ -23,9 +23,47 @@ fi
CABVERSTR=$("$CABAL" --numeric-version)
CABVER=( ${CABVERSTR//./ } )
+THREADS="-j1"
+GC_THREADS=""
+SEMAPHORE=""
+
+echo "$@"
+
+# Try building hadrian in parallel. We check for -j<n>.
+# If threads > 1 we pass --semaphore to allow ghc to build more than one module in parallel
+# If threads > 4 we pass -qn as higher parallel gc thread counts can lead to slow downs
+# We only do any of thise for cabal >= 3.14, because I don't trust older versions to handle --semaphore right
+if [ "${CABVER[0]}" -gt 3 ] || [ "${CABVER[0]}" -eq 3 -a "${CABVER[1]}" -ge 14 ];
+then
+
+ for arg in "$@"; do
+ case "$arg" in
+ -j)
+ GC_THREADS="-qn4"
+ SEMAPHORE="--semaphore"
+ THREADS="-j"
+ ;;
+ -j[0-9]*)
+ threads="${arg#-j}"
+ if [[ "$threads" =~ ^[0-9]+$ ]] && [ "$threads" -ne 0 ]; then
+ THREADS="-j${threads}"
+ if [ $threads -ge 4 ]; then
+ GC_THREADS="-qn4"
+ fi
+ if [ $threads -gt 1 ]; then
+ SEMAPHORE="--semaphore"
+ fi
+ fi
+ ;;
+ esac
+
+ done
+
+fi
+
if [ "${CABVER[0]}" -gt 2 -o "${CABVER[0]}" -eq 2 -a "${CABVER[1]}" -ge 2 ];
then
- "$CABAL" --project-file="$PROJ" new-build "${CABFLAGS[@]}" -j exe:hadrian
+ "$CABAL" --project-file="$PROJ" new-build "${CABFLAGS[@]}" ${THREADS} ${SEMAPHORE} --ghc-options="+RTS ${GC_THREADS} -RTS" exe:hadrian
# use new-exec instead of new-run to make sure that the build-tools (alex & happy) are in PATH
"$CABAL" --project-file="$PROJ" new-exec "${CABFLAGS[@]}" hadrian -- \
--directory "$PWD" \
=====================================
libraries/Cabal
=====================================
@@ -1 +1 @@
-Subproject commit d9b0904b49dc84e0bfc79062daf2bbdf9d22a422
+Subproject commit 8d1f5a33662be0db0654061fb53fb00e3f4417e0
=====================================
libraries/base/src/Data/Ix.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE Safe #-}
+{-# LANGUAGE Trustworthy #-}
-- |
--
@@ -42,4 +42,4 @@ module Data.Ix
-- <https://www.haskell.org/onlinereport/haskell2010/haskellch19.html>.
) where
-import GHC.Internal.Data.Ix
+import GHC.Internal.Ix
=====================================
libraries/deepseq
=====================================
@@ -1 +1 @@
-Subproject commit ae2762ac241a61852c9ff4c287af234fb1ad931f
+Subproject commit 882f52f51854544a467babd8cb075e3271f5913e
=====================================
libraries/directory
=====================================
@@ -1 +1 @@
-Subproject commit 6442a3cf04f74d82cdf8c9213324313d52b23d28
+Subproject commit 8c712e834f277544fc03e96dfbbb769126dc0a7c
=====================================
libraries/exceptions
=====================================
@@ -1 +1 @@
-Subproject commit 81bfd6e0ca631f315658201ae02e30046678f056
+Subproject commit a3da039855479e3c8542e8b45986599d0414ff68
=====================================
libraries/ghc-internal/ghc-internal.cabal.in
=====================================
@@ -153,7 +153,6 @@ Library
GHC.Internal.Data.Functor.Identity
GHC.Internal.Data.Functor.Utils
GHC.Internal.Data.IORef
- GHC.Internal.Data.Ix
GHC.Internal.Data.List
GHC.Internal.Data.List.NonEmpty
GHC.Internal.Data.Maybe
=====================================
libraries/ghc-internal/src/GHC/Internal/Data/Ix.hs deleted
=====================================
@@ -1,64 +0,0 @@
-{-# LANGUAGE Trustworthy #-}
-
------------------------------------------------------------------------------
--- |
--- Module : GHC.Internal.Data.Ix
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries(a)haskell.org
--- Stability : stable
--- Portability : portable
---
--- The 'Ix' class is used to map a contiguous subrange of values in
--- type onto integers. It is used primarily for array indexing
--- (see the array package). 'Ix' uses row-major order.
---
------------------------------------------------------------------------------
-
-module GHC.Internal.Data.Ix
- (
- -- * The 'Ix' class
- Ix
- ( range
- , index
- , inRange
- , rangeSize
- )
- -- Ix instances:
- --
- -- Ix Char
- -- Ix Int
- -- Ix Integer
- -- Ix Bool
- -- Ix Ordering
- -- Ix ()
- -- (Ix a, Ix b) => Ix (a, b)
- -- ...
-
- -- * Deriving Instances of 'Ix'
- -- | Derived instance declarations for the class 'Ix' are only possible
- -- for enumerations (i.e. datatypes having only nullary constructors)
- -- and single-constructor datatypes, including arbitrarily large tuples,
- -- whose constituent types are instances of 'Ix'.
- --
- -- * For an enumeration, the nullary constructors are assumed to be
- -- numbered left-to-right with the indices being 0 to n-1 inclusive. This
- -- is the same numbering defined by the 'Enum' class. For example, given
- -- the datatype:
- --
- -- > data Colour = Red | Orange | Yellow | Green | Blue | Indigo | Violet
- --
- -- we would have:
- --
- -- > range (Yellow,Blue) == [Yellow,Green,Blue]
- -- > index (Yellow,Blue) Green == 1
- -- > inRange (Yellow,Blue) Red == False
- --
- -- * For single-constructor datatypes, the derived instance declarations
- -- are as shown for tuples in chapter 19, section 2 of the Haskell 2010 report:
- -- <https://www.haskell.org/onlinereport/haskell2010/haskellch19.html>.
-
- ) where
-
-import GHC.Internal.Ix
=====================================
testsuite/tests/ghci.debugger/scripts/T26042b.stdout
=====================================
@@ -22,30 +22,18 @@ _result ::
-> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld,
Int #) = _
Stopped in Main.foo, T26042b.hs:14:3-18
-_result ::
- GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld
- -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld,
- Int #) = _
+_result :: IO Int = _
13 y = 4
14 n <- bar (x + y)
^^^^^^^^^^^^^^^^
15 return n
-_result ::
- GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld
- -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld,
- Int #) = _
+_result :: IO Int = _
Stopped in Main.main, T26042b.hs:5:3-26
-_result ::
- GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld
- -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld,
- () #) = _
+_result :: IO () = _
4 main = do
5 a <- foo False undefined
^^^^^^^^^^^^^^^^^^^^^^^^
6 print a
-_result ::
- GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld
- -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld,
- () #) = _
+_result :: IO () = _
14
14
=====================================
testsuite/tests/ghci.debugger/scripts/T26042c.stdout
=====================================
@@ -1,18 +1,12 @@
Breakpoint 0 activated at T26042c.hs:10:15-22
Stopped in Main.foo, T26042c.hs:10:15-22
-_result ::
- GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld
- -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld,
- Int #) = _
+_result :: IO Int = _
9 foo :: Bool -> Int -> IO Int
10 foo True i = return i
^^^^^^^^
11 foo False _ = do
Stopped in Main.main, T26042c.hs:5:3-26
-_result ::
- GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld
- -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld,
- () #) = _
+_result :: IO () = _
4 main = do
5 a <- foo False undefined
^^^^^^^^^^^^^^^^^^^^^^^^
=====================================
testsuite/tests/ghci.debugger/scripts/T26042d2.stdout
=====================================
@@ -1,10 +1,7 @@
Breakpoint 0 activated at T26042d2.hs:11:3-21
hello1
Stopped in Main.f, T26042d2.hs:11:3-21
-_result ::
- GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld
- -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld,
- () #) = _
+_result :: IO () = _
10 f = do
11 putStrLn "hello2.1"
^^^^^^^^^^^^^^^^^^^
=====================================
testsuite/tests/ghci.debugger/scripts/T26042f2.stdout
=====================================
@@ -1,6 +1,6 @@
Breakpoint 0 activated at T26042f.hs:(20,7)-(21,14)
Stopped in T8.t, T26042f.hs:(20,7)-(21,14)
-_result :: Int = _
+_result :: Identity Int = _
x :: Int = 450
19 t :: Int -> Identity Int
vv
@@ -18,12 +18,12 @@ _result :: Identity Int = _
^^^^^^^^^^^^
15 n <- pure (a+a)
Stopped in T8.f, T26042f.hs:8:3-14
-_result :: Identity Int = _
+_result :: Int = _
x :: Int = 15
7 f x = do
8 b <- g (x*x)
^^^^^^^^^^^^
9 y <- pure (b+b)
x :: Int = 15
-_result :: Identity Int = _
+_result :: Int = _
7248
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -1286,7 +1286,7 @@ module Data.Int where
data Int8 = ...
module Data.Ix where
- -- Safety: Safe
+ -- Safety: Trustworthy
type Ix :: * -> Constraint
class GHC.Internal.Classes.Ord a => Ix a where
range :: (a, a) -> [a]
=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -1286,7 +1286,7 @@ module Data.Int where
data Int8 = ...
module Data.Ix where
- -- Safety: Safe
+ -- Safety: Trustworthy
type Ix :: * -> Constraint
class GHC.Internal.Classes.Ord a => Ix a where
range :: (a, a) -> [a]
=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -1286,7 +1286,7 @@ module Data.Int where
data Int8 = ...
module Data.Ix where
- -- Safety: Safe
+ -- Safety: Trustworthy
type Ix :: * -> Constraint
class GHC.Internal.Classes.Ord a => Ix a where
range :: (a, a) -> [a]
=====================================
testsuite/tests/interface-stability/base-exports.stdout-ws-32
=====================================
@@ -1286,7 +1286,7 @@ module Data.Int where
data Int8 = ...
module Data.Ix where
- -- Safety: Safe
+ -- Safety: Trustworthy
type Ix :: * -> Constraint
class GHC.Internal.Classes.Ord a => Ix a where
range :: (a, a) -> [a]
=====================================
testsuite/tests/simplCore/should_compile/T21391.hs
=====================================
@@ -2,6 +2,8 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
+{-# OPTIONS_GHC -Wno-deprecations #-}
+
module Web.Routing.SafeRouting where
import Control.DeepSeq (NFData (..))
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/edd7ef1748fbf3fd6fa64064b88572…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/edd7ef1748fbf3fd6fa64064b88572…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fix-26700] Apply 22 suggestion(s) to 5 file(s)
by recursion-ninja (＠recursion-ninja) 06 Feb '26
by recursion-ninja (＠recursion-ninja) 06 Feb '26
06 Feb '26
recursion-ninja pushed to branch wip/fix-26700 at Glasgow Haskell Compiler / GHC
Commits:
be1dab4d by recursion-ninja at 2026-02-06T18:18:44+00:00
Apply 22 suggestion(s) to 5 file(s)
Co-authored-by: Rodrigo Mesquita <rodrigo.m.mesquita(a)gmail.com>
- - - - -
5 changed files:
- compiler/GHC/HsToCore/Foreign/C.hs
- compiler/GHC/HsToCore/Foreign/Decl.hs
- compiler/GHC/HsToCore/Foreign/JavaScript.hs
- compiler/GHC/Types/ForeignCall.hs
- compiler/Language/Haskell/Syntax/Decls/Foreign.hs
Changes:
=====================================
compiler/GHC/HsToCore/Foreign/C.hs
=====================================
@@ -93,14 +93,14 @@ dsCFExport fn_id co ext_name cconv target_kind = do
-- If it's plain t, return (t, ForeignValue)
(res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of
-- The function already returns IO t
- Just (_ioTyCon, res_ty) -> (res_ty, ForeignFunction)
+ Just (_ioTyCon, res_ty) -> (res_ty, True)
-- The function returns t
- Nothing -> (orig_res_ty, ForeignValue)
+ Nothing -> (orig_res_ty, False)
dflags <- getDynFlags
return $
mkFExportCBits dflags ext_name
- (if target_kind == ForeignFunction then Nothing else Just fn_id)
+ (if isDyn then Nothing else Just fn_id)
fe_arg_tys res_ty is_IO_res_ty cconv
dsCImport :: Id
@@ -186,7 +186,7 @@ dsCFExportDynamic id co0 cconv = do
export_ty = mkVisFunTyMany stable_ptr_ty arg_ty
bindIOId <- dsLookupGlobalId bindIOName
stbl_value <- newSysLocalMDs stable_ptr_ty
- (h_code, c_code, typestring) <- dsCFExport id (mkRepReflCo export_ty) fe_nm cconv ForeignFunction
+ (h_code, c_code, typestring) <- dsCFExport id (mkRepReflCo export_ty) fe_nm cconv True
let
{-
The arguments to the external function which will
@@ -279,7 +279,7 @@ dsFCall fn_id co fcall mDeclHeader = do
| isVoidRes = cCall
| otherwise = text "return" <+> cCall
cCall
- | targetKind == ForeignFunction = ppr cName <> parens argVals
+ | ForeignFunction <- targetKind = ppr cName <> parens argVals
| null arg_tys = ppr cName
| otherwise = panic "dsFCall: Unexpected arguments to FFI value import"
raw_res_ty = case tcSplitIOType_maybe io_res_ty of
=====================================
compiler/GHC/HsToCore/Foreign/Decl.hs
=====================================
@@ -93,7 +93,7 @@ dsForeigns' fos = do
, fd_e_ext = co
, fd_fe = CExport _
(L _ (CExportStatic ext_nm cconv)) }) = do
- (h, c, _, ids, bs) <- dsFExport id co ext_nm cconv ForeignValue
+ (h, c, _, ids, bs) <- dsFExport id co ext_nm cconv False
return (h, c, ids, bs)
{-
@@ -165,8 +165,7 @@ dsFExport :: Id -- Either the exported Id,
-- from C, and its representation type
-> CLabelString -- The name to export to C land
-> CCallConv
- -> ForeignKind -- If it is a function,
- -- then is foreign export dynamic
+ -> Bool -- True => foreign export dynamic
-- so invoke IO action that's hanging off
-- the first argument's stable pointer
-> DsM ( CHeader -- contents of Module_stub.h
@@ -175,16 +174,16 @@ dsFExport :: Id -- Either the exported Id,
, [Id] -- function closures to be registered as GC roots
, [Binding] -- additional bindings used by desugared foreign export
)
-dsFExport fn_id co ext_name cconv target_kind = do
+dsFExport fn_id co ext_name cconv is_dyn = do
platform <- getPlatform
case (platformArch platform, cconv) of
(ArchJavaScript, _) -> do
- (h, c, ts) <- dsJsFExport fn_id co ext_name cconv target_kind
+ (h, c, ts) <- dsJsFExport fn_id co ext_name cconv is_dyn
pure (h, c, ts, [fn_id], [])
(ArchWasm32, JavaScriptCallConv) ->
dsWasmJSExport fn_id co ext_name
_ -> do
- (h, c, ts) <- dsCFExport fn_id co ext_name cconv target_kind
+ (h, c, ts) <- dsCFExport fn_id co ext_name cconv is_dyn
pure (h, c, ts, [fn_id], [])
=====================================
compiler/GHC/HsToCore/Foreign/JavaScript.hs
=====================================
@@ -72,8 +72,7 @@ dsJsFExport
-- from C, and its representation type
-> CLabelString -- The name to export to C land
-> CCallConv
- -> ForeignKind -- If it is a function,
- -- then is foreign export dynamic
+ -> Bool -- True => foreign export dynamic
-- so invoke IO action that's hanging off
-- the first argument's stable pointer
-> DsM ( CHeader -- contents of Module_stub.h
@@ -81,7 +80,7 @@ dsJsFExport
, String -- string describing type to pass to createAdj.
)
-dsJsFExport fn_id co ext_name cconv target_kind = do
+dsJsFExport fn_id co ext_name cconv isDyn = do
let
ty = coercionRKind co
(_tvs,sans_foralls) = tcSplitForAllTyVars ty
@@ -103,7 +102,7 @@ dsJsFExport fn_id co ext_name cconv target_kind = do
platform <- targetPlatform <$> getDynFlags
return $
mkFExportJSBits platform ext_name
- (if target_kind == ForeignFunction then Nothing else Just fn_id)
+ (if isDyn then Nothing else Just fn_id)
(map scaledThing fe_arg_tys) res_ty is_IO_res_ty cconv
mkFExportJSBits
@@ -284,7 +283,7 @@ dsJsFExportDynamic id co0 cconv = do
export_ty = mkVisFunTyMany stable_ptr_ty arg_ty
bindIOId <- dsLookupGlobalId bindIOName
stbl_value <- newSysLocalMDs stable_ptr_ty
- (h_code, c_code, typestring) <- dsJsFExport id (mkRepReflCo export_ty) fe_nm cconv ForeignFunction
+ (h_code, c_code, typestring) <- dsJsFExport id (mkRepReflCo export_ty) fe_nm cconv True
let
{-
The arguments to the external function which will
=====================================
compiler/GHC/Types/ForeignCall.hs
=====================================
@@ -244,19 +244,6 @@ instance NFData ForeignCall where
instance forall p. IsPass p => NFData (CCallSpec (GhcPass p)) where
rnf (CCallSpec t c s) = rnf t `seq` rnf c `seq` rnf s
--- TODO: The orphan instance should be moved to the 'GHC.Utils.Binary' module and
--- and the 'GHC.Utils.Outputable' module after the 'Language.Haskell.Syntax.Decls'
--- module no longer imports 'GHC.Hs.Doc'.
---
--- Instances for the following types eventually need to be relocated:
---
--- * CCallConv
--- * CCallTarget
--- * CExportSpec
--- * CType
--- * Header
--- * Safety
---
instance Binary CCallConv where
put_ bh CCallConv =
putByte bh 0
@@ -280,8 +267,9 @@ instance Binary CCallConv where
-- If Nothing, then it's taken to be in the current package.
data StaticTargetGhc = StaticTargetGhc
{ staticTargetLabel :: SourceText
- , staticTargetUnit :: Unit
+ , staticTargetUnit :: CCallStaticUnit
-- ^ What package the function is in.
+ -- If 'CCallStaticThisUnit', then it's taken to be in the current package
-- Note: This information is only used for PrimCalls on Windows.
-- See CLabel.labelDynamic and CoreToStg.coreToStgApp
-- for the difference in representation between PrimCalls
@@ -305,7 +293,7 @@ type instance XXCCallTarget (GhcPass p) = DataConCantHappen
type instance XCType (GhcPass p) = CTypeGhc
type instance XXCType (GhcPass p) = DataConCantHappen
-instance {-# OVERLAPPING #-} NFData (CType (GhcPass p)) where
+instance NFData (CType (GhcPass p)) where
rnf (CType ext mh fs) =
rnf ext `seq` rnf mh `seq` rnf fs
@@ -344,7 +332,7 @@ instance Binary StaticTargetGhc where
, staticTargetUnit = unit
}
-instance {-# OVERLAPPING #-} forall p. IsPass p => Eq (CCallTarget (GhcPass p)) where
+instance forall p. IsPass p => Eq (CCallTarget (GhcPass p)) where
(==) = \case
DynamicTarget{} -> \case
DynamicTarget{} -> True
=====================================
compiler/Language/Haskell/Syntax/Decls/Foreign.hs
=====================================
@@ -201,12 +201,10 @@ data CCallTarget pass
= StaticTarget
(XStaticTarget pass)
CLabelString -- C-land name of label.
- -- Used when importing a label as "foreign import ccall "dynamic" ..."
- ForeignKind -- True => really a function
- -- False => a value; only
- -- allowed in CAPI imports
+ ForeignKind -- only allowed in CAPI imports
- -- The first argument of the import is the name of a function pointer (an Addr#).
+ -- | The first argument of the import is the name of a function pointer (an Addr#).
+ -- Used when importing a label as "foreign import ccall "dynamic" ..."
| DynamicTarget (XDynamicTarget pass)
| XCCallTarget !(XXCCallTarget pass)
@@ -216,8 +214,8 @@ deriving instance {-# OVERLAPPABLE #-} (
Eq (XXCCallTarget pass)) =>
Eq (CCallTarget pass)
--- foreign export ccall foo :: ty
data CExportSpec
+ -- | foreign export ccall foo :: ty
= CExportStatic
CLabelString -- C Name of exported function
CCallConv
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/be1dab4db2cea22c4a7b8548fbc68df…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/be1dab4db2cea22c4a7b8548fbc68df…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fix-26700] 2 commits: Adding TTG extension point for 'CType'
by recursion-ninja (＠recursion-ninja) 06 Feb '26
by recursion-ninja (＠recursion-ninja) 06 Feb '26
06 Feb '26
recursion-ninja pushed to branch wip/fix-26700 at Glasgow Haskell Compiler / GHC
Commits:
740d2f68 by Recursion Ninja at 2026-02-06T10:56:27-05:00
Adding TTG extension point for 'CType'
- - - - -
0c23fdd0 by Recursion Ninja at 2026-02-06T11:07:19-05:00
Refactoring module name; correcting test-suite dependency counting test cases
- - - - -
22 changed files:
- compiler/GHC/Builtin/Types.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/HsToCore/Foreign/C.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/Types/ErrCtxt.hs
- compiler/GHC/Types/ForeignCall.hs
- compiler/Language/Haskell/Syntax/Decls.hs
- compiler/Language/Haskell/Syntax/Decls/ForeignCall.hs → compiler/Language/Haskell/Syntax/Decls/Foreign.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- compiler/ghc.cabal.in
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- utils/check-exact/ExactPrint.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
Changes:
=====================================
compiler/GHC/Builtin/Types.hs
=====================================
@@ -189,6 +189,8 @@ import GHC.Core.Class ( Class, mkClass )
import GHC.Core.Map.Type ( TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap )
import qualified GHC.Core.TyCo.Rep as TyCoRep ( Type(TyConApp) )
+import GHC.Hs.Extension (GhcTc)
+
import GHC.Types.TyThing
import GHC.Types.SourceText
import GHC.Types.Var ( VarBndr (Bndr), tyVarName )
@@ -617,7 +619,7 @@ consDataCon_RDR = nameRdrName consDataConName
-- This function assumes that the types it creates have all parameters at
-- Representational role, and that there is no kind polymorphism.
-pcTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
+pcTyCon :: Name -> Maybe (CType GhcTc) -> [TyVar] -> [DataCon] -> TyCon
pcTyCon name cType tyvars cons
= mkAlgTyCon name (mkTyConKind bndrs res_kind) bndrs 0 res_kind
(map (const Representational) tyvars)
@@ -2301,14 +2303,17 @@ int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,
* *
********************************************************************* -}
+-- | Generic constructor for primative C Types.
+mkCTypeCon :: Name -> String -> [DataCon] -> TyCon
+mkCTypeCon cName str =
+ pcTyCon cName (Just (defaultCType str)) []
+
charTy :: Type
charTy = mkTyConTy charTyCon
charTyCon :: TyCon
-charTyCon = pcTyCon charTyConName
- (Just (CType NoSourceText Nothing
- (NoSourceText,fsLit "HsChar")))
- [] [charDataCon]
+charTyCon = mkCTypeCon charTyConName "HsChar" [charDataCon]
+
charDataCon :: DataCon
charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon
@@ -2327,9 +2332,8 @@ intTy :: Type
intTy = mkTyConTy intTyCon
intTyCon :: TyCon
-intTyCon = pcTyCon intTyConName
- (Just (CType NoSourceText Nothing (NoSourceText,fsLit "HsInt")))
- [] [intDataCon]
+intTyCon = mkCTypeCon intTyConName "HsInt" [intDataCon]
+
intDataCon :: DataCon
intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon
@@ -2337,9 +2341,8 @@ wordTy :: Type
wordTy = mkTyConTy wordTyCon
wordTyCon :: TyCon
-wordTyCon = pcTyCon wordTyConName
- (Just (CType NoSourceText Nothing (NoSourceText, fsLit "HsWord")))
- [] [wordDataCon]
+wordTyCon = mkCTypeCon wordTyConName "HsWord" [wordDataCon]
+
wordDataCon :: DataCon
wordDataCon = pcDataCon wordDataConName [] [wordPrimTy] wordTyCon
@@ -2347,10 +2350,8 @@ word8Ty :: Type
word8Ty = mkTyConTy word8TyCon
word8TyCon :: TyCon
-word8TyCon = pcTyCon word8TyConName
- (Just (CType NoSourceText Nothing
- (NoSourceText, fsLit "HsWord8"))) []
- [word8DataCon]
+word8TyCon = mkCTypeCon word8TyConName "HsWord8" [word8DataCon]
+
word8DataCon :: DataCon
word8DataCon = pcDataCon word8DataConName [] [word8PrimTy] word8TyCon
@@ -2358,21 +2359,16 @@ floatTy :: Type
floatTy = mkTyConTy floatTyCon
floatTyCon :: TyCon
-floatTyCon = pcTyCon floatTyConName
- (Just (CType NoSourceText Nothing
- (NoSourceText, fsLit "HsFloat"))) []
- [floatDataCon]
+floatTyCon = mkCTypeCon floatTyConName "HsFloat" [floatDataCon]
+
floatDataCon :: DataCon
-floatDataCon = pcDataCon floatDataConName [] [floatPrimTy] floatTyCon
+floatDataCon = pcDataCon floatDataConName [] [floatPrimTy] floatTyCon
doubleTy :: Type
doubleTy = mkTyConTy doubleTyCon
doubleTyCon :: TyCon
-doubleTyCon = pcTyCon doubleTyConName
- (Just (CType NoSourceText Nothing
- (NoSourceText,fsLit "HsDouble"))) []
- [doubleDataCon]
+doubleTyCon = mkCTypeCon doubleTyConName "HsDouble" [doubleDataCon]
doubleDataCon :: DataCon
doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon
@@ -2565,10 +2561,7 @@ boolTy :: Type
boolTy = mkTyConTy boolTyCon
boolTyCon :: TyCon
-boolTyCon = pcTyCon boolTyConName
- (Just (CType NoSourceText Nothing
- (NoSourceText, fsLit "HsBool")))
- [] [falseDataCon, trueDataCon]
+boolTyCon = mkCTypeCon boolTyConName "HsBool" [falseDataCon, trueDataCon]
falseDataCon, trueDataCon :: DataCon
falseDataCon = pcDataCon falseDataConName [] [] boolTyCon
=====================================
compiler/GHC/Core/TyCon.hs
=====================================
@@ -158,6 +158,8 @@ import GHC.Builtin.Uniques
( tyConRepNameUnique
, dataConTyRepNameUnique )
+import GHC.Hs.Extension (GhcTc)
+
import GHC.Utils.Binary
import GHC.Types.Var
import GHC.Types.Var.Set
@@ -822,7 +824,8 @@ data TyConDetails =
-- Note that it does /not/ scope over the data
-- constructors.
- tyConCType :: Maybe CType,-- ^ The C type that should be used
+ tyConCType :: Maybe (CType GhcTc),
+ -- ^ The C type that should be used
-- for this type when using the FFI
-- and CAPI
@@ -2066,18 +2069,18 @@ well be different from 'mkTyConKind binders res_kind'.
-- | This is the making of an algebraic 'TyCon'.
mkAlgTyCon :: Name
- -> Kind -- ^ TyCon kind
- -> [TyConBinder] -- ^ Binders of the 'TyCon'
- -> Int -- ^ Number of binders introduced by eta expansion
- -> Kind -- ^ Result kind
- -> [Role] -- ^ The roles for each TyVar
- -> Maybe CType -- ^ The C type this type corresponds to
- -- when using the CAPI FFI
- -> [PredType] -- ^ Stupid theta: see 'algTcStupidTheta'
- -> AlgTyConRhs -- ^ Information about data constructors
- -> AlgTyConFlav -- ^ What flavour is it?
- -- (e.g. vanilla, type family)
- -> Bool -- ^ Was the 'TyCon' declared with GADT syntax?
+ -> Kind -- ^ TyCon kind
+ -> [TyConBinder] -- ^ Binders of the 'TyCon'
+ -> Int -- ^ Number of binders introduced by eta expansion
+ -> Kind -- ^ Result kind
+ -> [Role] -- ^ The roles for each TyVar
+ -> Maybe (CType GhcTc) -- ^ The C type this type corresponds to
+ -- when using the CAPI FFI
+ -> [PredType] -- ^ Stupid theta: see 'algTcStupidTheta'
+ -> AlgTyConRhs -- ^ Information about data constructors
+ -> AlgTyConFlav -- ^ What flavour is it?
+ -- (e.g. vanilla, type family)
+ -> Bool -- ^ Was the 'TyCon' declared with GADT syntax?
-> TyCon
mkAlgTyCon name kind binders nb_eta_bndrs res_kind roles cType stupid rhs parent gadt_syn
= mkTyCon name kind binders nb_eta_bndrs res_kind roles $
@@ -2708,7 +2711,7 @@ isImplicitTyCon (TyCon { tyConName = name, tyConDetails = details }) = go detail
| SumTyCon {} <- rhs = True
| otherwise = False
-tyConCType_maybe :: TyCon -> Maybe CType
+tyConCType_maybe :: TyCon -> Maybe (CType GhcTc)
tyConCType_maybe (TyCon { tyConDetails = details })
| AlgTyCon { tyConCType = mb_ctype} <- details = mb_ctype
| otherwise = Nothing
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -102,7 +102,7 @@ import GHC.Prelude
import Language.Haskell.Syntax.Binds
import Language.Haskell.Syntax.Decls
-import Language.Haskell.Syntax.Decls.ForeignCall
+import Language.Haskell.Syntax.Decls.Foreign
import Language.Haskell.Syntax.Decls.Overlap (OverlapMode(..))
import Language.Haskell.Syntax.Extension
@@ -1483,7 +1483,7 @@ type instance Anno (FunDep (GhcPass p)) = SrcSpanAnnA
type instance Anno (FamilyResultSig (GhcPass p)) = EpAnnCO
type instance Anno (FamilyDecl (GhcPass p)) = SrcSpanAnnA
type instance Anno (InjectivityAnn (GhcPass p)) = EpAnnCO
-type instance Anno CType = SrcSpanAnnP
+type instance Anno (CType (GhcPass p)) = SrcSpanAnnP
type instance Anno (HsDerivingClause (GhcPass p)) = EpAnnCO
type instance Anno (DerivClauseTys (GhcPass _)) = SrcSpanAnnC
type instance Anno (StandaloneKindSig (GhcPass p)) = SrcSpanAnnA
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -33,7 +33,7 @@ import GHC.Types.Name.Reader (WithUserRdr(..))
import GHC.Types.InlinePragma (ActivationGhc)
import GHC.Data.BooleanFormula (BooleanFormula(..))
import Language.Haskell.Syntax.Decls
-import Language.Haskell.Syntax.Decls.ForeignCall
+import Language.Haskell.Syntax.Decls.Foreign
import Language.Haskell.Syntax.Decls.Overlap (OverlapMode(..))
import Language.Haskell.Syntax.Extension (Anno)
import Language.Haskell.Syntax.Binds.InlinePragma (ActivationX(..), InlinePragma(..))
@@ -255,6 +255,11 @@ deriving instance Data (CCallTarget GhcPs)
deriving instance Data (CCallTarget GhcRn)
deriving instance Data (CCallTarget GhcTc)
+-- deriving instance (DataIdLR p p) => Data (CImportSpec p)
+deriving instance Data (CType GhcPs)
+deriving instance Data (CType GhcRn)
+deriving instance Data (CType GhcTc)
+
-- deriving instance (DataIdLR p p) => Data (RuleDecls p)
deriving instance Data (RuleDecls GhcPs)
deriving instance Data (RuleDecls GhcRn)
=====================================
compiler/GHC/HsToCore/Foreign/C.hs
=====================================
@@ -347,7 +347,7 @@ toCType = f False
-- Note that we aren't looking through type synonyms or
-- anything, as it may be the synonym that is annotated.
| Just tycon <- tyConAppTyConPicky_maybe t
- , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon
+ , Just (CType _ mHeader cType) <- tyConCType_maybe tycon
= (mHeader, ftext cType)
-- If we don't know a C type for this type, then try looking
-- through one layer of type synonym etc.
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -84,7 +84,7 @@ import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..))
import GHC.Builtin.Types ( constraintKindTyConName )
import GHC.Stg.EnforceEpt.TagSig
import GHC.Parser.Annotation (noLocA)
-import GHC.Hs.Extension ( GhcRn )
+import GHC.Hs.Extension ( GhcPass, GhcRn, GhcTc )
import GHC.Hs.Decls.Overlap ( OverlapFlag )
import GHC.Hs.Doc ( WithHsDocIdentifiers(..) )
@@ -196,7 +196,7 @@ data IfaceDecl
ifBinders :: [IfaceTyConBinder],
ifNbEtaBinders :: Int, -- ^ number of binders introduced by eta-expansion
ifResKind :: IfaceType, -- Result kind of type constructor
- ifCType :: Maybe CType, -- C type for CAPI FFI
+ ifCType :: Maybe (CType GhcTc), -- C type for CAPI FFI
ifRoles :: [Role], -- Roles
ifCtxt :: IfaceContext, -- The "stupid theta"
ifCons :: IfaceConDecls, -- Includes new/data/data family info
@@ -1450,7 +1450,7 @@ pprIfaceDecl _ (IfaceAxiom { ifName = name, ifTyCon = tycon
= hang (text "axiom" <+> ppr name <+> dcolon)
2 (vcat $ unzipWith (pprAxBranch (ppr tycon)) $ zip [0..] branches)
-pprCType :: Maybe CType -> SDoc
+pprCType :: Maybe (CType (GhcPass p)) -> SDoc
pprCType Nothing = Outputable.empty
pprCType (Just cType) = text "C type:" <+> ppr cType
=====================================
compiler/GHC/Parser.y
=====================================
@@ -1680,14 +1680,14 @@ datafam_inst_hdr :: { Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs
| type { sL1 $1 (Nothing, mkHsOuterImplicit, $1) }
-capi_ctype :: { Maybe (LocatedP CType) }
+capi_ctype :: { Maybe (LocatedP (CType GhcPs)) }
capi_ctype : '{-# CTYPE' STRING STRING '#-}'
- {% fmap Just $ amsr (sLL $1 $> (CType (getCTYPEs $1) (Just (Header (getSTRINGs $2) (getSTRING $2)))
- (getSTRINGs $3,getSTRING $3)))
+ {% fmap Just $ amsr (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $3) (Just (Header (getSTRINGs $2) (getSTRING $2)))
+ (getSTRING $3)))
(AnnPragma (glR $1) (epTok $4) noAnn (glR $2) (glR $3) noAnn noAnn) }
| '{-# CTYPE' STRING '#-}'
- {% fmap Just $ amsr (sLL $1 $> (CType (getCTYPEs $1) Nothing (getSTRINGs $2, getSTRING $2)))
+ {% fmap Just $ amsr (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $2) Nothing (getSTRING $2)))
(AnnPragma (glR $1) (epTok $3) noAnn noAnn (glR $2) noAnn noAnn) }
| { Nothing }
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -229,7 +229,7 @@ mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layout annsIn
mkTyData :: SrcSpan
-> Bool
-> NewOrData
- -> Maybe (LocatedP CType)
+ -> Maybe (LocatedP (CType GhcPs))
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Maybe (LHsKind GhcPs)
-> [LConDecl GhcPs]
@@ -250,7 +250,7 @@ mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr))
tcdFixity = fixity,
tcdDataDefn = defn })) }
-mkDataDefn :: Maybe (LocatedP CType)
+mkDataDefn :: Maybe (LocatedP (CType GhcPs))
-> Maybe (LHsContext GhcPs)
-> Maybe (LHsKind GhcPs)
-> DataDefnCons (LConDecl GhcPs)
@@ -325,7 +325,7 @@ mkTyFamInstEqn loc bndrs lhs rhs annEq
mkDataFamInst :: SrcSpan
-> NewOrData
- -> Maybe (LocatedP CType)
+ -> Maybe (LocatedP (CType GhcPs))
-> (Maybe ( LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs
, LHsType GhcPs)
-> Maybe (LHsKind GhcPs)
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -2029,13 +2029,15 @@ rnDataDefn doc (HsDataDefn { dd_cType = cType, dd_ctxt = context, dd_cons = cond
; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`
con_fvs `plusFV` sig_fvs
- ; return ( HsDataDefn { dd_ext = noAnn, dd_cType = cType
+ ; return ( HsDataDefn { dd_ext = noAnn, dd_cType = fmap rn_ctype <$> cType
, dd_ctxt = context', dd_kindSig = m_sig'
, dd_cons = condecls'
, dd_derivs = derivs' }
, all_fvs )
}
where
+ rn_ctype :: CType GhcPs -> CType GhcRn
+ rn_ctype (CType x y z) = CType x y z
h98_style = not $ anyLConIsGadt condecls -- Note [Stupid theta]
rn_derivs ds
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -75,6 +75,7 @@ import GHC.Core.TyCon
import GHC.Core.DataCon
import GHC.Core.Unify
+import GHC.Types.ForeignCall ( CType(..) )
import GHC.Types.Id
import GHC.Types.Id.Make
import GHC.Types.Var
@@ -3598,12 +3599,13 @@ tcDataDefn err_ctxt roles_info tc_name
{ data_cons <- tcConDecls DDataType rec_tycon tc_bndrs res_kind cons
; tc_rhs <- mk_tc_rhs hsc_src rec_tycon data_cons
; tc_rep_nm <- newTyConRepName tc_name
-
+ ; let tc_ctype :: CType GhcRn -> CType GhcTc
+ tc_ctype (CType x y z) = CType x y z
; return (mkAlgTyCon tc_name kind
bndrs nb_eta
res_kind
(roles_info tc_name)
- (fmap unLoc cType)
+ (fmap (tc_ctype . unLoc) cType)
stupid_theta tc_rhs
(VanillaAlgTyCon tc_rep_nm)
gadt_syntax)
=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -69,6 +69,7 @@ import GHC.Types.Var as Var
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Basic
+import GHC.Types.ForeignCall ( CType(..) )
import GHC.Types.Id
import GHC.Types.InlinePragma
import GHC.Types.SourceFile
@@ -826,11 +827,13 @@ tcDataFamInstDecl mb_clsinfo tv_skol_env
-- NB: Use the full ty_binders from the pats. See bullet toward
-- the end of Note [Data type families] in GHC.Core.TyCon
+ tc_ctype :: CType GhcRn -> CType GhcTc
+ tc_ctype (CType x y z) = CType x y z
rep_tc = mkAlgTyCon rep_tc_name user_kind
ty_binders (length extra_tcbs)
res_kind
(map (const Nominal) ty_binders)
- (fmap unLoc cType) stupid_theta
+ (fmap (tc_ctype . unLoc) cType) stupid_theta
tc_rhs parent
gadt_syntax
-- We always assume that indexed types are recursive. Why?
=====================================
compiler/GHC/Tc/Types/ErrCtxt.hs
=====================================
@@ -39,7 +39,7 @@ import GHC.Utils.Outputable ( Outputable(..) )
import Language.Haskell.Syntax
import Language.Haskell.Syntax.Basic ( FieldLabelString(..) )
-import Language.Haskell.Syntax.Decls.ForeignCall ( ForeignDecl(..) )
+import Language.Haskell.Syntax.Decls.Foreign ( ForeignDecl(..) )
import GHC.Boot.TH.Syntax qualified as TH
import qualified Data.List.NonEmpty as NE
=====================================
compiler/GHC/Types/ForeignCall.hs
=====================================
@@ -21,19 +21,69 @@ To be resolved at a later time, see TODO at the end of this module.
-}
module GHC.Types.ForeignCall (
- ForeignCall(..),
- isSafeForeignCall,
- Safety(..), playSafe, playInterruptible,
-
- CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
- CCallSpec(..),
- CCallTarget(..), isDynamicTarget,
- CCallConv(..), defaultCCallConv, ccallConvAttribute,
- ForeignKind(..),
-
- Header(..), CType(..),
- StaticTargetGhc(..),
- ) where
+ -- * Foreign function interface declarations
+ -- ** Data-type
+ ForeignDecl(..),
+ -- ** Record synonym
+ LForeignDecl,
+
+ -- * Foreign call
+ ForeignCall(..),
+ -- ** Queries
+ isSafeForeignCall,
+ -- ** CCallSpec
+ CCallSpec(..),
+
+ -- * Foreign export types
+ -- ** Data-type
+ ForeignExport(..),
+ -- ** Specification
+ CExportSpec(..),
+
+ -- * Foreign import types
+ -- ** Data-type
+ ForeignImport(..),
+ -- ** Call target
+ CCallTarget(..),
+ -- *** GHC extension point
+ StaticTargetGhc(..),
+ -- *** Queries
+ isDynamicTarget,
+ -- ** Foreign target kind
+ ForeignKind(..),
+ -- ** Safety
+ Safety(..),
+ -- *** Queries
+ playSafe,
+ playInterruptible,
+ -- ** Specification
+ CImportSpec(..),
+
+ -- * Foreign binding type
+ -- ** Data-type
+ CType(..),
+ -- *** Construction
+ defaultCType,
+ mkCType,
+ -- *** GHC extension point
+ CTypeGhc(..),
+
+ -- * General sub-types
+ -- ** CCallConv
+ CCallConv(..),
+ -- *** Default construction
+ defaultCCallConv,
+ -- *** Pretty-printing
+ ccallConvAttribute,
+ -- ** CLabelString
+ CLabelString,
+ -- *** Queries
+ isCLabelString,
+ -- *** Pretty-printing
+ pprCLabelString,
+ -- ** Header
+ Header(..),
+ ) where
import GHC.Prelude
@@ -42,17 +92,16 @@ import GHC.Hs.Extension
import GHC.Utils.Binary
import GHC.Utils.Outputable
import GHC.Utils.Panic
-import GHC.Types.SourceText (SourceText, pprWithSourceText)
+import GHC.Types.SourceText (SourceText(..), pprWithSourceText)
import GHC.Unit.Types
-import Language.Haskell.Syntax.Decls.ForeignCall
- (CCallConv(..), CCallTarget(..), CExportSpec(..), CLabelString,
- CType(..), ForeignKind(..), Header(..), Safety(..))
+import Language.Haskell.Syntax.Decls.Foreign
import Language.Haskell.Syntax.Extension
import Data.Char
import Data.Data (Data)
import Data.Functor ((<&>))
+import Data.String (fromString)
import Control.DeepSeq (NFData(..))
@@ -158,6 +207,14 @@ instance forall p. IsPass p => Outputable (CCallSpec (GhcPass p)) where
<> ppr label
<+> (pprWithSourceText srcTxt empty)
+defaultCType :: String -> CType (GhcPass p)
+defaultCType =
+ CType (CTypeGhc NoSourceText NoSourceText) Nothing . fromString
+
+mkCType :: SourceText -> SourceText -> Maybe Header -> FastString -> CType (GhcPass p)
+mkCType x y m =
+ CType (CTypeGhc x y) m
+
{-
************************************************************************
* *
@@ -233,12 +290,42 @@ data StaticTargetGhc = StaticTargetGhc
}
deriving (Data, Eq)
+data CTypeGhc = CTypeGhc
+ { cTypeSourceText :: SourceText
+ , cTypeOtherText :: SourceText
+ }
+ deriving (Data, Eq)
+
type instance XStaticTarget GhcPs = SourceText
type instance XStaticTarget GhcRn = StaticTargetGhc
type instance XStaticTarget GhcTc = StaticTargetGhc
type instance XDynamicTarget (GhcPass p) = NoExtField
type instance XXCCallTarget (GhcPass p) = DataConCantHappen
+type instance XCType (GhcPass p) = CTypeGhc
+type instance XXCType (GhcPass p) = DataConCantHappen
+
+instance {-# OVERLAPPING #-} NFData (CType (GhcPass p)) where
+ rnf (CType ext mh fs) =
+ rnf ext `seq` rnf mh `seq` rnf fs
+
+instance NFData CTypeGhc where
+ rnf st =
+ rnf (cTypeSourceText st) `seq`
+ rnf (cTypeOtherText st)
+
+instance Binary CTypeGhc where
+ put_ bh ct = do
+ put_ bh (cTypeSourceText ct)
+ put_ bh (cTypeOtherText ct)
+ get bh = do
+ str1 <- get bh
+ str2 <- get bh
+ return $ CTypeGhc
+ { cTypeSourceText = str1
+ , cTypeOtherText = str2
+ }
+
instance NFData StaticTargetGhc where
rnf st =
rnf (staticTargetLabel st) `seq`
@@ -258,24 +345,24 @@ instance Binary StaticTargetGhc where
}
instance {-# OVERLAPPING #-} forall p. IsPass p => Eq (CCallTarget (GhcPass p)) where
- (==) = \case
- DynamicTarget{} -> \case
- DynamicTarget{} -> True
- _ -> False
- StaticTarget x1 a1 b1 -> \case
- StaticTarget x2 a2 b2 -> a1 == a2 && b1 == b2 && case ghcPass @p of
- GhcPs -> x1 == x2
- GhcRn -> x1 == x2
- GhcTc -> x1 == x2
- _ -> False
+ (==) = \case
+ DynamicTarget{} -> \case
+ DynamicTarget{} -> True
+ _ -> False
+ StaticTarget x1 a1 b1 -> \case
+ StaticTarget x2 a2 b2 -> a1 == a2 && b1 == b2 && case ghcPass @p of
+ GhcPs -> x1 == x2
+ GhcRn -> x1 == x2
+ GhcTc -> x1 == x2
+ _ -> False
instance forall p. IsPass p => NFData (CCallTarget (GhcPass p)) where
- rnf = \case
- DynamicTarget NoExtField -> ()
- StaticTarget x a b -> rnf a `seq` rnf b `seq` case ghcPass @p of
- GhcPs -> rnf x
- GhcRn -> rnf x
- GhcTc -> rnf x
+ rnf = \case
+ DynamicTarget NoExtField -> ()
+ StaticTarget x a b -> rnf a `seq` rnf b `seq` case ghcPass @p of
+ GhcPs -> rnf x
+ GhcRn -> rnf x
+ GhcTc -> rnf x
instance forall p. IsPass p => Binary (CCallTarget (GhcPass p)) where
put_ bh = \case
@@ -312,16 +399,16 @@ instance Binary CExportSpec where
ab <- get bh
return (CExportStatic aa ab)
-instance Binary CType where
- put_ bh (CType s mh fs) = do
- put_ bh s
- put_ bh mh
- put_ bh fs
+instance Binary (CType (GhcPass p)) where
+ put_ bh (CType ext mh fs) = do
+ put_ bh ext
+ put_ bh mh
+ put_ bh fs
get bh = do
- s <- get bh
- mh <- get bh
- fs <- get bh
- return (CType s mh fs)
+ ext <- get bh
+ mh <- get bh
+ fs <- get bh
+ return (CType ext mh fs)
instance Binary ForeignKind where
put_ bh = putByte bh . \case
@@ -352,27 +439,30 @@ instance Binary Safety where
_ -> return PlayRisky
instance Outputable CCallConv where
- ppr StdCallConv = text "stdcall"
- ppr CCallConv = text "ccall"
- ppr CApiConv = text "capi"
- ppr PrimCallConv = text "prim"
- ppr JavaScriptCallConv = text "javascript"
+ ppr StdCallConv = text "stdcall"
+ ppr CCallConv = text "ccall"
+ ppr CApiConv = text "capi"
+ ppr PrimCallConv = text "prim"
+ ppr JavaScriptCallConv = text "javascript"
instance Outputable CExportSpec where
- ppr (CExportStatic str _) = pprCLabelString str
-
-instance Outputable CType where
- ppr (CType stp mh (stct,ct))
- = pprWithSourceText stp (text "{-# CTYPE") <+> hDoc
- <+> pprWithSourceText stct (doubleQuotes (ftext ct)) <+> text "#-}"
- where hDoc = case mh of
- Nothing -> empty
- Just h -> ppr h
+ ppr (CExportStatic str _) = pprCLabelString str
+
+instance Outputable (CType (GhcPass p)) where
+ ppr (CType ext mh ct) =
+ pprWithSourceText stp (text "{-# CTYPE") <+> hDoc <+>
+ pprWithSourceText stct (doubleQuotes (ftext ct)) <+> text "#-}"
+ where
+ stp = cTypeSourceText ext
+ stct = cTypeOtherText ext
+ hDoc = case mh of
+ Nothing -> empty
+ Just h -> ppr h
instance Outputable Header where
ppr (Header st h) = pprWithSourceText st (doubleQuotes $ ppr h)
instance Outputable Safety where
- ppr PlaySafe = text "safe"
- ppr PlayInterruptible = text "interruptible"
- ppr PlayRisky = text "unsafe"
+ ppr PlaySafe = text "safe"
+ ppr PlayInterruptible = text "interruptible"
+ ppr PlayRisky = text "unsafe"
=====================================
compiler/Language/Haskell/Syntax/Decls.hs
=====================================
@@ -97,9 +97,9 @@ import {-# SOURCE #-} Language.Haskell.Syntax.Expr
import Language.Haskell.Syntax.Basic
(LexicalFixity, Role, RuleName, TopLevelFlag)
import Language.Haskell.Syntax.Binds
+import Language.Haskell.Syntax.Decls.Foreign
import Language.Haskell.Syntax.Binds.InlinePragma (Activation)
import Language.Haskell.Syntax.Decls.Overlap (OverlapMode)
-import Language.Haskell.Syntax.Decls.ForeignCall
import Language.Haskell.Syntax.Extension
import Language.Haskell.Syntax.Specificity (Specificity)
import Language.Haskell.Syntax.Type
@@ -808,7 +808,7 @@ data HsDataDefn pass -- The payload of a data type defn
-- @
HsDataDefn { dd_ext :: XCHsDataDefn pass,
dd_ctxt :: Maybe (LHsContext pass), -- ^ Context
- dd_cType :: Maybe (XRec pass CType),
+ dd_cType :: Maybe (XRec pass (CType pass)),
dd_kindSig:: Maybe (LHsKind pass),
-- ^ Optional kind signature.
--
=====================================
compiler/Language/Haskell/Syntax/Decls/ForeignCall.hs → compiler/Language/Haskell/Syntax/Decls/Foreign.hs
=====================================
@@ -10,26 +10,58 @@
-- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.*
--- | Abstract syntax of global declarations.
---
--- Definitions for: @SynDecl@ and @ConDecl@, @ClassDecl@,
--- @InstDecl@, @DefaultDecl@ and @ForeignDecl@.
-module Language.Haskell.Syntax.Decls.ForeignCall (
- -- ** Foreign function interface declarationss
- ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..), ForeignKind(..),
- CCallConv(..), CCallTarget(..), CExportSpec(..), CImportSpec(..), CLabelString,
- CType(..), Header(..), Safety(..),
-
- -- ** Extension
- XCExport,
- XCImport,
- XDynamicTarget,
+-- |
+-- Abstract syntax of foreign function interface declarations.
+module Language.Haskell.Syntax.Decls.Foreign (
+ -- * Foreign function interface declarations
+ -- ** Data-type
+ ForeignDecl(..),
+ -- ** Record synonym
+ LForeignDecl,
+
+ -- * Foreign export types
+ -- ** Data-type
+ ForeignExport(..),
+ -- ** Specification
+ CExportSpec(..),
+
+ -- * Foreign import types
+ -- ** Data-type
+ ForeignImport(..),
+ -- ** Specification
+ CImportSpec(..),
+ -- ** Sub-types
+ CCallTarget(..),
+ ForeignKind(..),
+ Safety(..),
+
+ -- * Foreign binding type
+ CType(..),
+
+ -- * General sub-types
+ CLabelString,
+ CCallConv(..),
+ Header(..),
+
+ -- * Extension points
+ -- ** ForeignDecl
XForeignExport,
XForeignImport,
+ XXForeignDecl,
+ -- ** ForeignExport
+ XCExport,
+ XXForeignExport,
+ -- ** ForeignImport
+ XCImport,
+ XXForeignImport,
+ -- ** CCallTarget
XStaticTarget,
+ XDynamicTarget,
XXCCallTarget,
- XXForeignDecl,
- ) where
+ -- ** CType
+ XCType,
+ XXCType,
+ ) where
import Language.Haskell.Syntax.Extension
import Language.Haskell.Syntax.Type
@@ -193,18 +225,27 @@ data CExportSpec
type CLabelString = FastString -- A C label, completely unencoded
--- TODO: TTG
-
-- | A C type, used in CAPI FFI calls
-data CType = CType SourceText -- To EXT point
- -- ^ See Note [Pragma source text] in "GHC.Types.SourceText"
- (Maybe Header) -- header to include for this type
- ( SourceText -- TO EXT Point
- , FastString) -- the type itself
- deriving (Eq, Data)
-
-instance NFData CType where
- rnf (CType s mh fs) = rnf s `seq` rnf mh `seq` rnf fs
+data CType pass
+ = CType
+ (XCType pass)
+ (Maybe Header) -- header to include for this type
+ FastString
+ | XCType !(XXCType pass)
+
+deriving instance {-# OVERLAPPABLE #-}
+ ( Eq (XCType pass)
+ , Eq (XXCType pass)
+ ) =>
+ Eq (CType pass)
+
+instance {-# OVERLAPPABLE #-}
+ ( NFData (XCType pass)
+ , NFData (XXCType pass)
+ ) => NFData (CType pass) where
+ rnf = \case
+ CType ext mh fs -> rnf ext `seq` rnf mh `seq` rnf fs
+ XCType ext -> rnf ext
-- The filename for a C header file
-- See Note [Pragma source text] in "GHC.Types.SourceText"
=====================================
compiler/Language/Haskell/Syntax/Extension.hs
=====================================
@@ -387,6 +387,11 @@ type family XStaticTarget x
type family XDynamicTarget x
type family XXCCallTarget x
+-- -------------------------------------
+-- CType type family
+type family XCType x
+type family XXCType x
+
-- -------------------------------------
-- ForeignDecl type families
type family XForeignImport x
=====================================
compiler/ghc.cabal.in
=====================================
@@ -1025,8 +1025,8 @@ Library
Language.Haskell.Syntax.Binds.InlinePragma
Language.Haskell.Syntax.BooleanFormula
Language.Haskell.Syntax.Decls
+ Language.Haskell.Syntax.Decls.Foreign
Language.Haskell.Syntax.Decls.Overlap
- Language.Haskell.Syntax.Decls.ForeignCall
Language.Haskell.Syntax.Expr
Language.Haskell.Syntax.Extension
Language.Haskell.Syntax.ImpExp
=====================================
testsuite/tests/count-deps/CountDepsAst.stdout
=====================================
@@ -242,6 +242,7 @@ Language.Haskell.Syntax.Binds
Language.Haskell.Syntax.Binds.InlinePragma
Language.Haskell.Syntax.BooleanFormula
Language.Haskell.Syntax.Decls
+Language.Haskell.Syntax.Decls.Foreign
Language.Haskell.Syntax.Decls.Overlap
Language.Haskell.Syntax.Expr
Language.Haskell.Syntax.Extension
=====================================
testsuite/tests/count-deps/CountDepsParser.stdout
=====================================
@@ -271,6 +271,7 @@ Language.Haskell.Syntax.Binds
Language.Haskell.Syntax.Binds.InlinePragma
Language.Haskell.Syntax.BooleanFormula
Language.Haskell.Syntax.Decls
+Language.Haskell.Syntax.Decls.Foreign
Language.Haskell.Syntax.Decls.Overlap
Language.Haskell.Syntax.Expr
Language.Haskell.Syntax.Extension
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -1901,10 +1901,10 @@ instance ExactPrint (ForeignExport GhcPs) where
instance ExactPrint CExportSpec where
getAnnotationEntry = const NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact (CExportStatic st lbl cconv) = do
+ exact (CExportStatic lbl cconv) = do
debugM $ "CExportStatic starting"
cconv' <- markAnnotated cconv
- return (CExportStatic st lbl cconv')
+ return (CExportStatic lbl cconv')
-- ---------------------------------------------------------------------
@@ -4445,11 +4445,13 @@ exactBang ((o,c,tk), mt) str = do
-- ---------------------------------------------------------------------
-instance ExactPrint (LocatedP CType) where
+instance Typeable p => ExactPrint (LocatedP (CType (GhcPass p))) where
getAnnotationEntry = entryFromLocatedA
setAnnotationAnchor = setAnchorAn
- exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (CType stp mh (stct,ct))) = do
+ exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (CType ext mh ct)) = do
+ let stp = cTypeSourceText ext
+ stct = cTypeOtherText ext
o' <- markAnnOpen'' o stp "{-# CTYPE"
l1' <- case mh of
Nothing -> return l1
@@ -4457,7 +4459,7 @@ instance ExactPrint (LocatedP CType) where
printStringAtAA l1 (toSourceTextWithSuffix srcH "" "")
l2' <- printStringAtAA l2 (toSourceTextWithSuffix stct (unpackFS ct) "")
c' <- markEpToken c
- return (L (EpAnn l (AnnPragma o' c' s l1' l2' t m) cs) (CType stp mh (stct,ct)))
+ return (L (EpAnn l (AnnPragma o' c' s l1' l2' t m) cs) (CType ext mh ct))
-- ---------------------------------------------------------------------
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
=====================================
@@ -39,6 +39,7 @@ import GHC.Core.TyCon (tyConResKind)
import GHC.Driver.DynFlags (getDynFlags)
import GHC.Hs.Decls.Overlap (OverlapMode(..))
import GHC.Types.Basic (TupleSort (..))
+import GHC.Types.ForeignCall
import GHC.Types.Name
import GHC.Types.Name.Reader (RdrName (Exact))
import Language.Haskell.Syntax.BooleanFormula(BooleanFormula(..))
@@ -674,13 +675,16 @@ renameDataDefn
( HsDataDefn
{ dd_ext = noExtField
, dd_ctxt = lcontext'
- , dd_cType = cType
+ , dd_cType = fmap renameCType <$> cType
, dd_kindSig = k'
, dd_cons = cons'
, dd_derivs = []
}
)
+renameCType :: CType GhcRn -> CType DocNameI
+renameCType (CType _ y z) = CType NoExtField y z
+
renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI)
renameCon
decl@( ConDeclH98
@@ -830,11 +834,22 @@ renameForD (ForeignExport _ lname ltype x) = do
return (ForeignExport noExtField lname' ltype' (renameForE x))
renameForI :: ForeignImport GhcRn -> ForeignImport DocNameI
-renameForI (CImport _ cconv safety mHeader spec) = CImport noExtField cconv safety mHeader spec
+renameForI (CImport _ cconv safety mHeader spec) = CImport noExtField cconv safety mHeader (renameForISpec spec)
renameForE :: ForeignExport GhcRn -> ForeignExport DocNameI
renameForE (CExport _ spec) = CExport noExtField spec
+renameForISpec :: CImportSpec GhcRn -> CImportSpec DocNameI
+renameForISpec = \case
+ CLabel str -> CLabel str
+ CFunction cTarget -> CFunction $ renameCCallTarget cTarget
+ CWrapper -> CWrapper
+
+renameCCallTarget :: CCallTarget GhcRn -> CCallTarget DocNameI
+renameCCallTarget = \case
+ DynamicTarget {} -> DynamicTarget NoExtField
+ StaticTarget _ cStr fKind -> StaticTarget NoExtField cStr fKind
+
renameInstD :: InstDecl GhcRn -> RnM (InstDecl DocNameI)
renameInstD (ClsInstD{cid_inst = d}) = do
d' <- renameClsInstD d
=====================================
utils/haddock/haddock-api/src/Haddock/Types.hs
=====================================
@@ -57,6 +57,7 @@ import GHC.Driver.Session (Language)
import qualified GHC.LanguageExtensions as LangExt
import GHC.Core.InstEnv (is_dfun_name)
import GHC.Hs.Decls.Overlap (OverlapMode)
+import GHC.Types.ForeignCall (CType)
import GHC.Types.Name (stableNameCmp)
import GHC.Types.Name.Occurrence
import GHC.Types.Name.Reader (RdrName (..))
@@ -831,6 +832,7 @@ type instance Anno (HsOuterTyVarBndrs Specificity DocNameI) = SrcSpanAnnA
type instance Anno (HsSigType DocNameI) = SrcSpanAnnA
type instance Anno (BooleanFormula DocNameI) = SrcSpanAnnL
type instance Anno (OverlapMode DocNameI) = EpAnn AnnPragma
+type instance Anno (CType DocNameI) = EpAnn AnnPragma
type XRecCond a =
( XParTy a ~ (EpToken "(", EpToken ")")
@@ -925,6 +927,13 @@ type instance XCExport DocNameI = NoExtField
type instance XXForeignImport DocNameI = DataConCantHappen
type instance XXForeignExport DocNameI = DataConCantHappen
+type instance XStaticTarget DocNameI = NoExtField
+type instance XDynamicTarget DocNameI = NoExtField
+type instance XXCCallTarget DocNameI = DataConCantHappen
+
+type instance XCType DocNameI = NoExtField
+type instance XXCType DocNameI = DataConCantHappen
+
type instance XConDeclGADT DocNameI = NoExtField
type instance XConDeclH98 DocNameI = NoExtField
type instance XXConDecl DocNameI = DataConCantHappen
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bf8c77a01fbb260be04cfd3438a276…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bf8c77a01fbb260be04cfd3438a276…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc] Pushed new branch wip/andreask/bump_shake
by Andreas Klebinger (＠AndreasK) 06 Feb '26
by Andreas Klebinger (＠AndreasK) 06 Feb '26
06 Feb '26
Andreas Klebinger pushed new branch wip/andreask/bump_shake at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/andreask/bump_shake
You're receiving this email because of your account on gitlab.haskell.org.
1
0