Duncan Coutts pushed to branch wip/dcoutts/foreign-label-source-refactoring at Glasgow Haskell Compiler / GHC Commits: cb09cb45 by Duncan Coutts at 2026-04-22T14:55:53+01:00 Change data PrimOp to use a UnitId rather than Unit This simplifies the conversions slightly, but more importantly in a later change we are going to want to specify a unit where we will only have a UnitId to hand, not a Unit. - - - - - 61b96618 by Duncan Coutts at 2026-04-23T10:01:45+01:00 Extend 'foreign import prim' syntax to allow specifying the source package that is: the package where the cmm entity comes from. The package name is stashed in the "header" field for the FFI call, and then the renamer resolves the package name to a unit id (with a new ghc error for the failure of the package name resolution). Fixes issue #27206 Adds test case T27206 - - - - - 4ccca9f9 by Duncan Coutts at 2026-04-23T10:23:23+01:00 Use new package name syntax for primops from the RTS foreign import prim "rts stg_thething" Most uses of foreign import prim in the libraries are for primops defined in .cmm files local to that library, but some import primops defined in the rts. These cases should use the new syntax to specify the package name in the ffi entity string. - - - - - 861f3fc8 by Duncan Coutts at 2026-04-23T10:29:59+01:00 Extend ForeignLabelSource with ForeignLabelInUnknownPackage case Initially this is treated the same way as ForeignLabelInExternalPackage. Later we will extend this for Windows/PE to support building each Haskell unit as a separate DLL, to support this unknown case specifically. - - - - - 7dbd9494 by Duncan Coutts at 2026-04-23T10:29:59+01:00 Extend CLabelTargetLibrary with CLabelTargetUnknown case Initially unused, but this will become the typical case, because in fact when Haskell code uses ffi imports, we do not know where the name comes from: we do not know if the named entity is defined in the current shared lib or in another one. Knowing where C entities come from is the exception rather than the rule. - - - - - 00071f9c by Duncan Coutts at 2026-04-23T10:29:59+01:00 Extend LitLabel with CLabelTargetLibrary Bundle the three fields of LitLabel into a new data CLabelSpec, defined in GHC.Types.ForeignCall Apart from the binary format, this should not change behaviour. Behaviour changes are in the next patch - - - - - e42fdc4c by Duncan Coutts at 2026-04-23T10:29:59+01:00 Change FFI imports to use CLabelTargetUnknown We never know the target for normal foreign imports. Historically, this information was only actually used for "foreign import prim", and only on Windows when building with one DLL per unit (which bitrotted). The previous default of using the current package as the source was wrong, even for the limited case of Windows DLLs, because many of the imports are for primops defined in the RTS, which is certainly not the current package. - - - - - 0ed42b9b by Duncan Coutts at 2026-04-23T10:39:57+01:00 Pass through the label source in stg->cmm conversion Previously we had to hard code the (often incorrect) source ForeignLabelInThisPackage. Now the Core label literal representation carries the source, so we just convert that and pass it down. As a consequence, if the source will now be either ForeignLabelInUnknownPackage or ForeignLabelInPackage. The typical value will be ForeignLabelInUnknownPackage, since that's what we get for FFI imports of addresses. In practice is not an immediate change of behaviour, because the only user of this information is on Windows when building each Haskell unit as a separate DLl, which isn't (yet) supported. - - - - - 8c97091f by Duncan Coutts at 2026-04-23T10:47:05+01:00 Fix source for generated C name for 'foreign import "wrapper"' For a 'foreign import "wrapper"' construct we generate a local wrapper C function. We need to refer to the name of this local C function. We _know_ that this function lives in the local shared lib, because it is compiled into the same library. Thus we set the label source to be CLabelTargetInUnit. - - - - - c31ce7e0 by Duncan Coutts at 2026-04-23T10:48:14+01:00 Fix source for generated C name for 'foreign import capi' For a 'foreign import capi' we generate a local wrapper function and then call that. We need to refer to the name of this local C function. We _know_ that this function lives in the local shared lib, because it is compiled into the same library. Thus we set the label source to be CLabelTargetInUnit. - - - - - 22 changed files: - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/Cmm/CLabel.hs - compiler/GHC/HsToCore/Foreign/C.hs - compiler/GHC/HsToCore/Foreign/JavaScript.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm/Lit.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Literal.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/ForeignCall.hs - compiler/GHC/Types/Literal.hs - libraries/ghc-internal/src/GHC/Internal/AllocationLimitHandler.hs - libraries/ghc-internal/src/GHC/Internal/Prim/Ext.hs - libraries/ghc-internal/src/GHC/Internal/Prim/Panic.hs - + testsuite/tests/rename/should_fail/T27206.hs - + testsuite/tests/rename/should_fail/T27206.stderr - testsuite/tests/rename/should_fail/all.T Changes: ===================================== compiler/GHC/Builtin/PrimOps.hs ===================================== @@ -50,7 +50,7 @@ import GHC.Types.SrcLoc ( wiredInSrcSpan ) import GHC.Types.ForeignCall ( CLabelString ) import GHC.Types.Unique ( Unique ) -import GHC.Unit.Types ( Unit ) +import GHC.Unit.Types ( UnitId ) import GHC.Utils.Binary import GHC.Utils.Outputable @@ -929,11 +929,11 @@ pprPrimOp other_op = pprOccName (primOpOcc other_op) ************************************************************************ -} -data PrimCall = PrimCall CLabelString Unit +data PrimCall = PrimCall CLabelString UnitId instance Outputable PrimCall where - ppr (PrimCall lbl pkgId) - = text "__primcall" <+> ppr pkgId <+> ppr lbl + ppr (PrimCall lbl unitId) + = text "__primcall" <+> ppr unitId <+> ppr lbl -- | Indicate if a primop is really inline: that is, it isn't out-of-line and it -- isn't DataToTagOp which are two primops that evaluate their argument ===================================== compiler/GHC/ByteCode/Asm.hs ===================================== @@ -868,7 +868,7 @@ assembleI platform i = case i of emit_ = emit word_size literal :: Literal -> m Word - literal (LitLabel fs _) = litlabel fs + literal (LitLabel lbl) = litlabel lbl literal LitNullAddr = word 0 literal (LitFloating LitFloat x) = float (litFloatingToHostFloat x) literal (LitFloating LitDouble x) = double (litFloatingToHostDouble x) @@ -893,7 +893,7 @@ assembleI platform i = case i of -- analysis messed up. literal (LitRubbish {}) = word 0 - litlabel fs = lit1 (BCONPtrLbl fs) + litlabel (CLabelSpec fs _ _) = lit1 (BCONPtrLbl fs) words ws = lit (fmap BCONPtrWord ws) word w = words (OnlyOne w) word2 w1 w2 = words (OnlyTwo w1 w2) ===================================== compiler/GHC/Cmm/CLabel.hs ===================================== @@ -115,6 +115,7 @@ module GHC.Cmm.CLabel ( hasIdLabelInfo, isBytesLabel, isForeignLabel, + isForeignLabelUnknownPackage, isSomeRODataLabel, isStaticClosureLabel, @@ -448,8 +449,32 @@ data ForeignLabelSource -- contain compiled Haskell code, and is not associated with any .hi files. -- We don't have to worry about Haskell code being inlined from -- external packages. It is safe to treat the RTS package as "external". + -- + -- On Windows in particular, we assume the label is definately in an + -- external DLL and expect to link it against a __imp_* symbol. Thus it + -- will /not/ link correctly if the symbol is actually in the same DLL. | ForeignLabelInExternalPackage + -- | The label is somewhere, but we do not know if it is in this package or + -- an external package. This is the case we end up with for Haskell FFI + -- declarations like @foreign import ccall@. There is not enough + -- information to tell us if the label is from the same package (e.g. in + -- a local @cbits/blah.c@ file) or is from an external foreign library. + -- + -- On ELF, this is not a problem and the symbol can be resolved without + -- knowing if its local or external. + -- + -- On Windows/PE, this is a bit of a problem. On Windows one normally + -- needs to know if it's local or external since the symbol names and + -- ABI differ. However, GCC & LLVM have extensions to help porting Unix + -- software (that is not used to making these distinctions). There are a + -- number of useful mechanisms including \"auto import\" (to import + -- symbols found in DLLs automatically), a @.refptr@ mechanism to load + -- data via an indirection (which the linker can relocate) and + -- \"pseudo relocations\" which is a runtime feature to do additional + -- relocations beyond what the Win32 native linker does. + | ForeignLabelInUnknownPackage + -- | Label is in the package currently being compiled. -- This is only used for creating hacky tmp labels during code generation. -- Don't use it in any code that might be inlined across a package boundary @@ -477,8 +502,8 @@ data ForeignLabelSource -- from, e.g. the RTS, which then fall into the 'CLabelTargetInUnit' case. -- toForeignLabelSource :: CLabelTargetLibrary -> ForeignLabelSource -toForeignLabelSource (CLabelTargetInUnit unit) = ForeignLabelInPackage - (toUnitId unit) +toForeignLabelSource CLabelTargetUnknown = ForeignLabelInUnknownPackage +toForeignLabelSource (CLabelTargetInUnit unit) = ForeignLabelInPackage unit -- | For debugging problems with the CLabel representation. @@ -774,8 +799,8 @@ mkApEntryLabel platform upd arity = -- A call to some primitive hand written Cmm code mkPrimCallLabel :: PrimCall -> CLabel -mkPrimCallLabel (PrimCall str pkg) - = CmmLabel (toUnitId pkg) (NeedExternDecl True) str CmmPrimCall +mkPrimCallLabel (PrimCall str unitid) + = CmmLabel unitid (NeedExternDecl True) str CmmPrimCall -- Constructing ForeignLabels @@ -799,6 +824,10 @@ isForeignLabel :: CLabel -> Bool isForeignLabel (ForeignLabel _ _ _) = True isForeignLabel _lbl = False +isForeignLabelUnknownPackage :: CLabel -> Bool +isForeignLabelUnknownPackage (ForeignLabel _ ForeignLabelInUnknownPackage _) = True +isForeignLabelUnknownPackage _lbl = False + -- | Whether label is a static closure label (can come from haskell or cmm) isStaticClosureLabel :: CLabel -> Bool -- Closure defined in haskell (.hs) @@ -1329,9 +1358,9 @@ labelDynamic this_mod platform external_dynamic_refs lbl = LocalBlockLabel _ -> False - ForeignLabel _ source _ -> - if os == OSMinGW32 - then case source of + ForeignLabel _ source _ + | os == OSMinGW32 -> + case source of -- Foreign label is in some un-named foreign package (or DLL). ForeignLabelInExternalPackage -> True @@ -1339,16 +1368,22 @@ labelDynamic this_mod platform external_dynamic_refs lbl = -- source file currently being compiled. ForeignLabelInThisPackage -> False + -- Foreign label is either in the same package or is in some + -- foreign package/DLL/DSO. Neither yes nor no is the correct + -- answer here, because on Windows these are a distinct case + -- that need special treatment in the code generator. + ForeignLabelInUnknownPackage -> True + -- Foreign label is in some named package. -- When compiling in the "dyn" way, each package is to be -- linked into its own DLL. ForeignLabelInPackage pkgId -> external_dynamic_refs && (this_unit /= pkgId) - else -- On Mac OS X and on ELF platforms, false positives are OK, - -- so we claim that all foreign imports come from dynamic - -- libraries - True + -- On Mac OS X and on ELF platforms, false positives are OK, + -- so we claim that all foreign imports come from dynamic + -- libraries + | otherwise -> True CC_Label cc -> external_dynamic_refs && not (ccFromThisModule cc this_mod) @@ -1699,6 +1734,7 @@ instance Outputable ForeignLabelSource where ForeignLabelInPackage pkgId -> parens $ text "package: " <> ppr pkgId ForeignLabelInThisPackage -> parens $ text "this package" ForeignLabelInExternalPackage -> parens $ text "external package" + ForeignLabelInUnknownPackage -> parens $ text "unknown package" -- ----------------------------------------------------------------------------- -- Machine-dependent knowledge about labels. ===================================== compiler/GHC/HsToCore/Foreign/C.hs ===================================== @@ -116,7 +116,7 @@ dsCImport id co (CLabel cid) _ _ _ = do (resTy, foRhs) <- resultWrapper ty assert (fromJust resTy `eqType` addrPrimTy) $ -- typechecker ensures this let - rhs = foRhs (Lit (LitLabel cid fod)) + rhs = foRhs (Lit (LitLabel (CLabelSpec cid fod CLabelTargetUnknown))) rhs' = Cast rhs co in return ([(id, rhs')], mempty, mempty) @@ -191,8 +191,10 @@ dsCFExportDynamic id co0 cconv = do to be entered using an external calling convention (ccall). -} + fe_lbl = CLabelSpec fe_nm ForeignLabelIsFunction + (CLabelTargetInUnit (moduleUnitId mod)) adj_args = [ Var stbl_value - , Lit (LitLabel fe_nm ForeignLabelIsFunction) + , Lit (LitLabel fe_lbl) , Lit (mkLitString typestring) ] -- name of external entry point providing these services. @@ -200,7 +202,7 @@ dsCFExportDynamic id co0 cconv = do adjustor = CCallSpec (StaticTarget (StaticTargetGhc NoSourceText - (CLabelTargetInUnit rtsUnit)) + (CLabelTargetInUnit rtsUnitId)) (fsLit "createAdjustor") ForeignFunction) CCallConv @@ -263,15 +265,19 @@ dsFCall fn_id co fcall mDeclHeader = do (fcall', cDoc) <- case fcall of - CCall (CCallSpec (StaticTarget stExt cName targetKind) + CCall (CCallSpec (StaticTarget _ cName targetKind) CApiConv safety) -> do nextWrapperNum <- ds_next_wrapper_num <$> getGblEnv wrapperName <- mkWrapperName nextWrapperNum "ghc_wrapper" (unpackFS cName) - let fcall' = CCall (CCallSpec - (StaticTarget (stExt { staticTargetLabel = NoSourceText} ) - wrapperName - ForeignFunction) - CApiConv safety) + mod <- getModule + let thisUnit = moduleUnitId mod + -- the C wrapper function is linked into this unit (shared lib) + wrapperTarget = StaticTarget (StaticTargetGhc + NoSourceText + (CLabelTargetInUnit thisUnit)) + wrapperName + ForeignFunction + fcall' = CCall (CCallSpec wrapperTarget CApiConv safety) c = includes $$ fun_proto <+> braces (cRet <> semi) includes = vcat [ text "#include \"" <> ftext h ===================================== compiler/GHC/HsToCore/Foreign/JavaScript.hs ===================================== @@ -240,7 +240,7 @@ dsJsImport id co (CLabel cid) _ _ _ = do _ -> ForeignLabelIsData (_resTy, foRhs) <- jsResultWrapper ty -- ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this - let rhs = foRhs (Lit (LitLabel cid fod)) + let rhs = foRhs (Lit (LitLabel (CLabelSpec cid fod CLabelTargetUnknown))) rhs' = Cast rhs co return ([(id, rhs')], mempty, mempty) @@ -290,8 +290,10 @@ dsJsFExportDynamic id co0 cconv = do to be entered using an external calling convention (ccall). -} + fe_lbl = CLabelSpec fe_nm ForeignLabelIsFunction + (CLabelTargetInUnit (moduleUnitId mod)) adj_args = [ Var stbl_value - , Lit (LitLabel fe_nm ForeignLabelIsFunction) + , Lit (LitLabel fe_lbl) , Lit (mkLitString typestring) ] -- name of external entry point providing these services. @@ -299,7 +301,7 @@ dsJsFExportDynamic id co0 cconv = do adjustor = CCallSpec (StaticTarget (StaticTargetGhc NoSourceText - (CLabelTargetInUnit rtsUnit)) + (CLabelTargetInUnit rtsUnitId)) (fsLit "createAdjustor") ForeignFunction) CCallConv @@ -655,7 +657,7 @@ mkJsCall u tgt args t = mkFCall u ccall args t where stExt = StaticTargetGhc { staticTargetLabel = NoSourceText - , staticTargetUnit = CLabelTargetInUnit ghcInternalUnit + , staticTargetUnit = CLabelTargetInUnit ghcInternalUnitId } ccall = CCall $ CCallSpec (StaticTarget stExt tgt ForeignFunction) ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -3136,7 +3136,7 @@ mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) (timport, td) then addFatalError $ mkPlainErrorMsgEnvelope loc PsErrInvalidCApiImport else returnSpec imp StdCallConv -> returnSpec =<< mkCImport - PrimCallConv -> mkOtherImport + PrimCallConv -> returnSpec =<< mkPrimImport JavaScriptCallConv -> mkOtherImport where -- Parse a C-like entity string of the following form: @@ -3145,7 +3145,9 @@ mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) (timport, td) -- name (cf section 8.5.1 in Haskell 2010 report). mkCImport = do let e = unpackFS entity - case parseCImport (reLoc cconv) (reLoc safety) (mkExtName (unLoc v)) e (L loc esrc) of + case parseCImport (reLoc cconv) (reLoc safety) + (mkExtName (unLoc v)) + e (L loc esrc) of Nothing -> addFatalError $ mkPlainErrorMsgEnvelope loc $ PsErrMalformedEntityString Just importSpec -> return importSpec @@ -3153,6 +3155,15 @@ mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) (timport, td) isCWrapperImport (CImport _ _ _ _ CWrapper) = True isCWrapperImport _ = False + mkPrimImport = do + let e = unpackFS entity + case parsePrimImport (reLoc cconv) (reLoc safety) + (mkExtName (unLoc v)) + e (L loc esrc) of + Nothing -> addFatalError $ mkPlainErrorMsgEnvelope loc $ + PsErrMalformedEntityString + Just importSpec -> return importSpec + -- currently, all the other import conventions only support a symbol name in -- the entity string. If it is missing, we use the function name instead. mkOtherImport = returnSpec importSpec @@ -3230,6 +3241,49 @@ parseCImport cconv safety nm str sourceText = cs <- many (satisfy id_char) return (mkFastString (c:cs))) +-- Parse a Cmm name entity string of the following form: +-- "[pkgname] cmmid" +-- If 'cmmid' is missing, the function name 'v' is used instead as symbol +-- name (cf section 8.5.1 in Haskell 2010 report). + +-- Note: the PackageName is stashed in the Header field. It gets pulled out +-- in the renamer, see rnHsForeignImport case for PrimCallConv. It would be +-- nicer if the ForeignImport representation had a case for each calling +-- convention. See issue #27209. +-- +parsePrimImport :: LocatedE CCallConv -> LocatedE Safety -> FastString -> String + -> Located SourceText + -> Maybe (ForeignImport GhcPs) +parsePrimImport cconv safety nm str sourceText = + listToMaybe $ map fst $ filter (null.snd) $ + readP_to_S parse str + where + parse = do + skipSpaces + pkgname <- return Nothing + +++ (do pkgname <- parse_pkgname + skipSpaces + return (Just (Header NoSourceText pkgname))) + cmmid <- return nm +++ parse_cmmid + skipSpaces + let !cfun = CFunction (StaticTarget NoSourceText cmmid ForeignFunction) + !cimp = CImport (reLoc sourceText) (reLoc cconv) + (reLoc safety) pkgname cfun + return cimp + + parse_cmmid = mkFastString <$> + ((:) <$> satisfy cmmid_first_char + <*> many (satisfy cmmid_char)) + + parse_pkgname = do str <- many1 (satisfy pkgname_char) + if looksLikePackageName str + then return (mkFastString str) + else fail "invalid package name syntax" + + cmmid_first_char c = isAlpha c || c == '_' + cmmid_char c = isAlphaNum c || c == '_' + + pkgname_char c = isAlphaNum c || c == '_' || c == '-' -- construct a foreign export declaration -- ===================================== compiler/GHC/Rename/Module.hs ===================================== @@ -61,7 +61,7 @@ import GHC.Types.Unique.Set import GHC.Types.SrcLoc as SrcLoc import GHC.Driver.DynFlags -import GHC.Driver.Env ( HscEnv(..), hsc_home_unit) +import GHC.Driver.Env ( HscEnv(..), hsc_home_unit, hsc_units ) import GHC.Utils.Misc ( lengthExceeds ) import GHC.Utils.Panic @@ -393,14 +393,9 @@ rnDefaultDecl (DefaultDecl _ mb_cls tys) rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeNames) rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec }) - = do { topEnv :: HscEnv <- getTopEnv - ; name' <- lookupLocatedTopBndrRnN WL_TermVariable name + = do { name' <- lookupLocatedTopBndrRnN WL_TermVariable name ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty - - -- Mark any PackageTarget style imports as coming from the current package - ; let home_unit = hsc_home_unit topEnv - spec' = patchForeignImport (homeUnitAsUnit home_unit) spec - + ; spec' <- rnHsForeignImport spec ; return (ForeignImport { fd_i_ext = noExtField , fd_name = name', fd_sig_ty = ty' , fd_fi = spec' }, fvs) } @@ -416,28 +411,62 @@ rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec }) -- we add it to the free-variable list. It might, for example, -- be imported from another module --- | For Windows DLLs we need to know what packages imported symbols are from --- to generate correct calls. Imported symbols are tagged with the current --- package, so if they get inlined across a package boundary we'll still --- know where they're from. --- -patchForeignImport :: Unit -> (ForeignImport GhcPs) -> (ForeignImport GhcRn) -patchForeignImport unit (CImport ext cconv safety fs spec) - = CImport ext cconv safety (renameHeader <$> fs) (patchCImportSpec unit spec) +rnHsForeignImport :: ForeignImport GhcPs -> RnM (ForeignImport GhcRn) -patchCImportSpec :: Unit -> CImportSpec GhcPs -> CImportSpec GhcRn -patchCImportSpec unit = \case - CFunction callTarget -> CFunction $ patchCCallTarget unit callTarget +-- | Rename 'foreign import prim "[pkgname] cmmid"': the (optional) package name +-- is used to specify in which unit the cmm primitive lives. Resolve the +-- package name to a unit. If the package name is not specified, it means the +-- target lives in the current unit. +-- +-- Note: the PackageName is stashed in the Header field in parsePrimImport. +-- It gets pulled out below in the rnHsForeignImport case for PrimCallConv. +-- It would be nicer if the ForeignImport representation had a case for each +-- calling convention. See issue #27209. +-- +-- The typical use cases are: +-- * cmm primops defined in the rts but bound in a library like ghc-internal +-- e.g. foreign import prim "rts blah" +-- * cmm primops defined in a local .cmm file in the same library. +-- +rnHsForeignImport (CImport ext cconv@(L _ PrimCallConv) safety header spec) + = do { topEnv :: HscEnv <- getTopEnv + ; target <- getPrimTargetUnit topEnv header + ; return (CImport ext cconv safety Nothing + (renameCImportSpec target spec)) + } + where + getPrimTargetUnit topEnv Nothing = + let this = homeUnitId (hsc_home_unit topEnv) in + return (CLabelTargetInUnit this) + + getPrimTargetUnit topEnv (Just (Header _ fs)) = + let pkgname = PackageName fs in + case lookupPackageName (hsc_units topEnv) pkgname of + Just that -> + return (CLabelTargetInUnit that) + Nothing -> do + addErrAt (locA ext) (TcRnUnknownPrimCallPackageName pkgname) + let this = homeUnitId (hsc_home_unit topEnv) + return (CLabelTargetInUnit this) + +rnHsForeignImport (CImport ext cconv safety header spec) + = return (CImport ext cconv safety + (renameHeader <$> header) + (renameCImportSpec CLabelTargetUnknown spec)) + +renameCImportSpec :: CLabelTargetLibrary -> CImportSpec GhcPs -> CImportSpec GhcRn +renameCImportSpec targetLib = \case + CFunction callTarget -> CFunction $ renameCCallTarget targetLib callTarget CLabel cLabel -> CLabel cLabel CWrapper -> CWrapper -patchCCallTarget :: Unit -> CCallTarget GhcPs -> CCallTarget GhcRn -patchCCallTarget unit = \case +renameCCallTarget :: CLabelTargetLibrary -> CCallTarget GhcPs -> CCallTarget GhcRn +renameCCallTarget targetLib = \case DynamicTarget x -> DynamicTarget x StaticTarget sTxt label targetKind -> let ext = StaticTargetGhc { staticTargetLabel = sTxt - , staticTargetUnit = CLabelTargetInUnit unit + , staticTargetUnit = targetLib } in StaticTarget ext label targetKind ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -1909,7 +1909,9 @@ generatePrimCall d s p target _result_ty args prim_args_offsets = mapFst stgArgRepU args_offsets shifted_args_offsets = mapSnd (+ d) args_offsets - push_target = PUSH_UBX (LitLabel target ForeignLabelIsFunction) 1 + labelspec = CLabelSpec target ForeignLabelIsFunction + CLabelTargetUnknown + push_target = PUSH_UBX (LitLabel labelspec) 1 push_info = PUSH_UBX (mkNativeCallInfoLit platform args_info) 1 {- compute size to move payload (without stg_primcall_info header) @@ -2062,7 +2064,8 @@ generateCCall d0 s p (CCallSpec target _ safety) result_ty args StaticTarget _ _ ForeignValue -> panic "generateCCall: unexpected FFI value import" StaticTarget _ target ForeignFunction -> - Just (LitLabel target ForeignLabelIsFunction) + Just (LitLabel (CLabelSpec target ForeignLabelIsFunction + CLabelTargetUnknown)) let is_static = isJust maybe_static_target ===================================== compiler/GHC/StgToCmm/Lit.hs ===================================== @@ -94,8 +94,7 @@ mkSimpleLit platform = \case (LitNumber LitNumWord32 i) -> CmmInt i W32 (LitNumber LitNumWord64 i) -> CmmInt i W64 (LitFloating fty r) -> CmmFloat r fty - (LitLabel fs fod) - -> let -- TODO: Literal labels might not actually be in the current package... - labelSrc = ForeignLabelInThisPackage - in CmmLabel (mkForeignLabel fs labelSrc fod) - other -> pprPanic "mkSimpleLit" (ppr other) + (LitLabel + (CLabelSpec lbl fod tgt)) -> CmmLabel (mkForeignLabel lbl lblsrc fod) + where lblsrc = toForeignLabelSource tgt + other -> pprPanic "mkSimpleLit" (ppr other) ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -36,7 +36,7 @@ import GHC.Cmm.BlockId import GHC.Cmm.Graph import GHC.Stg.Syntax import GHC.Cmm -import GHC.Unit ( rtsUnit ) +import GHC.Unit ( rtsUnitId ) import GHC.Core.Type ( Type, tyConAppTyCon_maybe ) import GHC.Core.TyCon import GHC.Cmm.CLabel @@ -3842,7 +3842,7 @@ emitCopyUpdRemSetPush platform hdr_size dst dst_off n = emit graph where lbl = mkLblExpr $ mkPrimCallLabel - $ PrimCall (fsLit "stg_copyArray_barrier") rtsUnit + $ PrimCall (fsLit "stg_copyArray_barrier") rtsUnitId args = [ mkIntExpr platform hdr_size , dst ===================================== compiler/GHC/StgToJS/Literal.hs ===================================== @@ -61,12 +61,12 @@ genLit = \case LitNumBigNat -> panic "genLit: unexpected BigNat that should have been removed in CorePrep" LitFloating LitFloat r -> return [ toJExpr (float2Double $ litFloatingToHostFloat r) ] LitFloating LitDouble r -> return [ toJExpr (litFloatingToHostDouble r) ] - LitLabel name ForeignLabelIsFunction + LitLabel (CLabelSpec name ForeignLabelIsFunction _) -> return [ ApplExpr hdMkFunctionPtr [global (mkRawSymbol True name)] , ValExpr (JInt 0) ] - LitLabel name ForeignLabelIsData + LitLabel (CLabelSpec name ForeignLabelIsData _) -> return [ toJExpr (global (mkRawSymbol True name)) , ValExpr (JInt 0) ] @@ -115,8 +115,10 @@ genStaticLit = \case LitNumBigNat -> panic "genStaticLit: unexpected BigNat that should have been removed in CorePrep" LitFloating LitFloat r -> return [ DoubleLit . SaneDouble $ float2Double $ litFloatingToHostFloat r ] LitFloating LitDouble r -> return [ DoubleLit . SaneDouble $ litFloatingToHostDouble r ] - LitLabel name fod -> return [ LabelLit (fod == ForeignLabelIsFunction) (mkRawSymbol True name) - , IntLit 0 ] + LitLabel (CLabelSpec name fod _) + -> return [ LabelLit (fod == ForeignLabelIsFunction) + (mkRawSymbol True name) + , IntLit 0 ] LitRubbish _ rep -> let prim_reps = runtimeRepPrimRep (text "GHC.StgToJS.Literal.genStaticLit") rep in case expectOnly prim_reps of -- Note [Post-unarisation invariants] ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -2060,6 +2060,9 @@ instance Diagnostic TcRnMessage where TcRnUnexpectedTypeSyntaxInTerms syntax -> mkSimpleDecorated $ text "Unexpected" <+> pprTypeSyntaxName syntax + TcRnUnknownPrimCallPackageName pkgname -> mkSimpleDecorated $ + text "Unknown source package" <+> quotes (ppr pkgname) <+> "in foreign import prim." + diagnosticReason :: TcRnMessage -> DiagnosticReason diagnosticReason = \case TcRnUnknownMessage m @@ -2701,6 +2704,8 @@ instance Diagnostic TcRnMessage where -> ErrorWithoutFlag TcRnUnexpectedTypeSyntaxInTerms{} -> ErrorWithoutFlag + TcRnUnknownPrimCallPackageName {} + -> ErrorWithoutFlag diagnosticHints = \case TcRnUnknownMessage m @@ -3427,6 +3432,8 @@ instance Diagnostic TcRnMessage where -> noHints TcRnUnexpectedTypeSyntaxInTerms syntax -> [suggestExtension (typeSyntaxExtension syntax)] + TcRnUnknownPrimCallPackageName {} + -> noHints diagnosticCode = constructorCode @GHC ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -212,7 +212,7 @@ import GHC.Types.Var.Set (TyVarSet, VarSet) import GHC.Types.DefaultEnv (ClassDefaults) import GHC.Unit.Types (Module) -import GHC.Unit.State (UnitState) +import GHC.Unit.State (UnitState, PackageName) import GHC.Unit.Module.ModIface (ModIface) import GHC.Utils.Outputable @@ -4436,6 +4436,20 @@ data TcRnMessage where Test cases: T24159_type_syntax_rn_fail -} TcRnUnexpectedTypeSyntaxInTerms :: TypeSyntax -> TcRnMessage + + {-| TcRnUnknownPrimCallPackageName is an error that occurs when + a 'foreign import prim "pkgname cmmid"' refers to a pkgname + that is not a declared dependency (direct or indirect) of the + current unit. + + Example: + foreign import prim "bad stg_paniczh" panic# :: ... + + Test cases: + T27206 + -} + TcRnUnknownPrimCallPackageName :: PackageName -> TcRnMessage + deriving Generic ---- ===================================== compiler/GHC/Types/Error/Codes.hs ===================================== @@ -697,6 +697,7 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "TcRnUnexpectedTypeSyntaxInTerms" = 31244 GhcDiagnosticCode "TcRnTypeApplicationsDisabled" = 23482 GhcDiagnosticCode "TcRnUnpromotableLit" = 51819 + GhcDiagnosticCode "TcRnUnknownPrimCallPackageName" = 57392 -- TcRnIllegalInvisibleTypePattern GhcDiagnosticCode "InvisPatWithoutFlag" = 78249 ===================================== compiler/GHC/Types/ForeignCall.hs ===================================== @@ -33,6 +33,8 @@ module GHC.Types.ForeignCall ( isSafeForeignCall, -- ** CCallSpec CCallSpec(..), + -- ** CLabelSpec + CLabelSpec(..), -- * Foreign export types -- ** Data-type @@ -203,6 +205,7 @@ instance Outputable CCallSpec where ForeignValue -> text "__ffi_static_ccall_value" ForeignFunction -> text "__ffi_static_ccall" pprUnit ext = case staticTargetUnit ext of + CLabelTargetUnknown -> empty CLabelTargetInUnit unit -> ppr unit (srcTxt, pPkgId) = (staticTargetLabel ext, pprUnit ext) in pCallType @@ -229,6 +232,58 @@ typeCheckHeader (Header a b) = Header a b renameHeader :: Header GhcPs -> Header GhcRn renameHeader (Header a b) = Header a b +{- +************************************************************************ +* * +\subsubsection{C labels} +* * +************************************************************************ +-} + +-- | A C name (closely related to an assembler label or linker symbol), along +-- with /what/ kind of entity the name refers to and /where/ the the entity +-- lives. +-- +-- The \"what\" is whether it refers to a C function or C data (e.g. a C global +-- variable or constant). We track this because we need to know in the backends +-- how to use the name. +-- +-- The \"where\" is where the entity that the name refers to lives. +-- Specifically, what shared library it lives in. We track this because on some +-- platforms (especially Windows) the the backend has to generate different +-- code to access symbols depending on whether they are in the current shared +-- library or a different one. +-- +-- This is used in Core's representation of 'Literal's, in the 'LitLabel' +-- case, to represent the address of a C entity (function or data) by its name +-- (also called a label or symbol). It gets used in the representation of FFI +-- imports of the address of C names, like: +-- +-- > foreign import ccall "foo.h &foo" foo :: Ptr CInt +-- +data CLabelSpec + = CLabelSpec + !CLabelString -- name + !CLabelIsFunctionOrData -- what + !CLabelTargetLibrary -- where + deriving (Eq, Data) + +type CLabelIsFunctionOrData = ForeignLabelIsFunctionOrData + +instance Binary CLabelSpec where + put_ bh (CLabelSpec lbl fod tgt) = do + put_ bh lbl + put_ bh fod + put_ bh tgt + get bh = do + lbl <- get bh + fod <- get bh + tgt <- get bh + return (CLabelSpec lbl fod tgt) + +instance NFData CLabelSpec where + rnf (CLabelSpec lbl fod tgt) = rnf lbl `seq` rnf fod `seq` rnf tgt + {- ************************************************************************ * * @@ -315,13 +370,26 @@ instance Binary CCallConv where -- as the target, or if the target is in a different library. -- data CLabelTargetLibrary + + -- | The entity (that the name\/label points to) is in an unknown shared + -- library. In particular it could either be in the current library (where + -- the label is used) or an external one. This case is used for all + -- user-written Haskell FFI ccall\/capi imports, because in this case we do + -- not know where the entity the name refers to lives. + = CLabelTargetUnknown + -- | The entity is /known/ to live in a specific Haskell unit (package), -- and thus the shared library corresponding to the unit. Uses of this -- label within the same unit will be intra-library, and inter-library -- otherwise. - = CLabelTargetInUnit !Unit + | CLabelTargetInUnit !UnitId deriving (Data, Eq) +instance Outputable CLabelTargetLibrary where + ppr CLabelTargetUnknown = parens (text "unknown library") + ppr (CLabelTargetInUnit unit) = parens (text "in unit " <> ppr unit) + + data StaticTargetGhc = StaticTargetGhc { staticTargetLabel :: SourceText , staticTargetUnit :: CLabelTargetLibrary @@ -358,13 +426,16 @@ instance NFData (Header (GhcPass p)) where instance NFData CLabelTargetLibrary where rnf = \case + CLabelTargetUnknown -> () CLabelTargetInUnit unit -> rnf unit instance Binary CLabelTargetLibrary where put_ bh = \case + CLabelTargetUnknown -> putByte bh 0 CLabelTargetInUnit unit -> putByte bh 1 *> put_ bh unit get bh = getByte bh >>= \case + 0 -> pure CLabelTargetUnknown _ -> CLabelTargetInUnit <$> get bh instance NFData CTypeGhc where ===================================== compiler/GHC/Types/Literal.hs ===================================== @@ -15,6 +15,7 @@ module GHC.Types.Literal , LitNumType(..) , LitFloating , LitFloatingType(..) + , CLabelSpec(..) -- ** Creating Literals , mkLitInt, mkLitIntWrap, mkLitIntWrapC, mkLitIntUnchecked @@ -144,14 +145,15 @@ data Literal -- ^ @Float#@ or @Double#@. -- Create with 'mkLitFloat' or 'mkLitDouble'. - | LitLabel FastString ForeignLabelIsFunctionOrData - -- ^ A label literal. Parameters: + | LitLabel !CLabelSpec -- ^ A label literal. Parameters: -- -- 1) The name of the symbol mentioned in the -- declaration -- -- 2) Flag indicating whether the symbol -- references a function or a data + -- + -- 3) Where the thing lives: which shared lib. deriving Data -- | Numeric literal type @@ -265,10 +267,9 @@ instance Binary Literal where put_ bh (LitNullAddr) = putByte bh 2 put_ bh (LitFloating LitFloat ah) = do putByte bh 3; put_ bh ah put_ bh (LitFloating LitDouble ai) = do putByte bh 4; put_ bh ai - put_ bh (LitLabel aj fod) + put_ bh (LitLabel lsp) = do putByte bh 5 - put_ bh aj - put_ bh fod + put_ bh lsp put_ bh (LitNumber nt i) = do putByte bh 6 put_ bh nt @@ -293,9 +294,8 @@ instance Binary Literal where ai <- get bh return (LitFloating LitDouble ai) 5 -> do - aj <- get bh - fod <- get bh - return (LitLabel aj fod) + lsp <- get bh + return (LitLabel lsp) 6 -> do nt <- get bh i <- get bh @@ -308,7 +308,7 @@ instance NFData Literal where rnf (LitString s) = rnf s rnf LitNullAddr = () rnf (LitFloating ty f) = rnf ty `seq` rnf f - rnf (LitLabel l1 k2) = rnf l1 `seq` rnf k2 + rnf (LitLabel l) = rnf l rnf (LitRubbish {}) = () -- LitRubbish is not contained within interface files. -- See Note [Rubbish literals]. @@ -844,7 +844,7 @@ literalType (LitChar _) = charPrimTy literalType (LitString _) = addrPrimTy literalType (LitFloating LitFloat _) = floatPrimTy literalType (LitFloating LitDouble _) = doublePrimTy -literalType (LitLabel _ _) = addrPrimTy +literalType (LitLabel _) = addrPrimTy literalType (LitNumber lt _) = case lt of LitNumBigNat -> byteArrayPrimTy LitNumInt -> intPrimTy @@ -875,7 +875,8 @@ cmpLit (LitString a) (LitString b) = a `compare` b cmpLit (LitNullAddr) (LitNullAddr) = EQ cmpLit (LitFloating lft1 a) (LitFloating lft2 b) = (lft1 `compare` lft2) `mappend` (a `compare` b) -cmpLit (LitLabel a _) (LitLabel b _ ) = a `lexicalCompareFS` b +cmpLit (LitLabel (CLabelSpec a _ _)) + (LitLabel (CLabelSpec b _ _)) = a `lexicalCompareFS` b cmpLit (LitNumber nt1 a) (LitNumber nt2 b) = (nt1 `compare` nt2) `mappend` (a `compare` b) cmpLit (LitRubbish tc1 b1) (LitRubbish tc2 b2) = (tc1 `compare` tc2) `mappend` @@ -915,8 +916,8 @@ pprLiteral _ (LitNumber nt i) LitNumWord16 -> pprPrimWord16 i LitNumWord32 -> pprPrimWord32 i LitNumWord64 -> pprPrimWord64 i -pprLiteral add_par (LitLabel l fod) = - add_par (text "__label" <+> pprHsString l <+> ppr fod) +pprLiteral add_par (LitLabel (CLabelSpec l fod tgt)) = + add_par (text "__label" <+> pprHsString l <+> ppr fod <+> ppr tgt) pprLiteral _ (LitRubbish torc rep) = text "RUBBISH" <> pp_tc <> parens (ppr rep) where ===================================== libraries/ghc-internal/src/GHC/Internal/AllocationLimitHandler.hs ===================================== @@ -80,7 +80,7 @@ setGlobalAllocationLimitHandler killBehaviour mHandler = do setAllocLimitKill shouldKill shouldRunHandler -- | Retrieves the allocation counter for the another thread. -foreign import prim "stg_getOtherThreadAllocationCounterzh" getOtherThreadAllocationCounter# +foreign import prim "rts stg_getOtherThreadAllocationCounterzh" getOtherThreadAllocationCounter# :: ThreadId# -> State# RealWorld -> (# State# RealWorld, Int64# #) ===================================== libraries/ghc-internal/src/GHC/Internal/Prim/Ext.hs ===================================== @@ -55,7 +55,7 @@ default () -- Double and Integer aren't available yet #if defined(mingw32_HOST_OS) -- | Asynchronously read bytes from specified file descriptor. -foreign import prim "stg_asyncReadzh" asyncRead# +foreign import prim "rts stg_asyncReadzh" asyncRead# :: Int# -> Int# -> Int# @@ -64,7 +64,7 @@ foreign import prim "stg_asyncReadzh" asyncRead# -> (# State# RealWorld, Int#, Int# #) -- | Asynchronously write bytes from specified file descriptor. -foreign import prim "stg_asyncWritezh" asyncWrite# +foreign import prim "rts stg_asyncWritezh" asyncWrite# :: Int# -> Int# -> Int# @@ -73,7 +73,7 @@ foreign import prim "stg_asyncWritezh" asyncWrite# -> (# State# RealWorld, Int#, Int# #) -- | Asynchronously perform procedure (first arg), passing it 2nd arg. -foreign import prim "stg_asyncDoProczh" asyncDoProc# +foreign import prim "rts stg_asyncDoProczh" asyncDoProc# :: Addr# -> Addr# -> State# RealWorld @@ -86,7 +86,7 @@ foreign import prim "stg_asyncDoProczh" asyncDoProc# ------------------------------------------------------------------------ -- | Retrieves the allocation counter for the current thread. -foreign import prim "stg_getThreadAllocationCounterzh" getThreadAllocationCounter# +foreign import prim "rts stg_getThreadAllocationCounterzh" getThreadAllocationCounter# :: State# RealWorld -> (# State# RealWorld, Int64# #) ===================================== libraries/ghc-internal/src/GHC/Internal/Prim/Panic.hs ===================================== @@ -72,10 +72,12 @@ absentError to me. -- `stg_panic#` never returns but it can't just return `State# RealWorld` so we -- indicate that it returns `(# #)` too to make the compiler happy. -- See Note [Compiler error functions] -foreign import prim "stg_paniczh" panic# :: Addr# -> State# RealWorld -> (# State# RealWorld, (# #) #) +foreign import prim "rts stg_paniczh" + panic# :: Addr# -> State# RealWorld -> (# State# RealWorld, (# #) #) -- See Note [Compiler error functions] -foreign import prim "stg_absentErrorzh" stg_absentError# :: Addr# -> State# RealWorld -> (# State# RealWorld, (# #) #) +foreign import prim "rts stg_absentErrorzh" + stg_absentError# :: Addr# -> State# RealWorld -> (# State# RealWorld, (# #) #) -- | Display the CString whose address is given as an argument and exit. panicError :: Addr# -> a ===================================== testsuite/tests/rename/should_fail/T27206.hs ===================================== @@ -0,0 +1,13 @@ +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE MagicHash #-} +module T27206 where + +import GHC.Exts + +-- Expect ok for known package rts and ghc-internal, and local/this +foreign import prim "rts cmm_good1" cmm_good1 :: Int# -> Int# +foreign import prim "ghc-internal cmm_good2" cmm_good2 :: Int# -> Int# +foreign import prim " cmm_good3" cmm_good3 :: Int# -> Int# + +-- But expect failure for unknown package pkg_foo +foreign import prim "pkg-foo cmm_bad" cmm_bad :: Int# -> Int# ===================================== testsuite/tests/rename/should_fail/T27206.stderr ===================================== @@ -0,0 +1,3 @@ +T27206.hs:13:21: error: [GHC-57392] + Unknown source package ‘pkg-foo’ in foreign import prim. + ===================================== testsuite/tests/rename/should_fail/all.T ===================================== @@ -264,3 +264,4 @@ test('T25901_sub_c', [extra_files(['T25901_sub_c_helper.hs'])], multimod_compile test('T25901_sub_d', [extra_files(['T25901_sub_d_helper.hs'])], multimod_compile_fail, ['T25901_sub_d', '-v0']) test('T25901_sub_w', normal, compile_fail, ['']) test('T26545', normal, compile_fail, ['']) +test('T27206', normal, compile_fail, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5cd47e76f12200d372c5439606df9cc... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5cd47e76f12200d372c5439606df9cc... You're receiving this email because of your account on gitlab.haskell.org.