recursion-ninja pushed to branch wip/fix-26700 at Glasgow Haskell Compiler / GHC Commits: bf8c77a0 by Recursion Ninja at 2026-02-05T13:07:32-05:00 Creating a descriptive type for the Foreign Call Target - - - - - 24 changed files: - 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/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/Types/ErrCtxt.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/ForeignCall.hs - compiler/Language/Haskell/Syntax/Decls.hs - compiler/Language/Haskell/Syntax/Decls/ForeignCall.hs - libraries/text - libraries/transformers Changes: ===================================== compiler/GHC/CoreToStg.hs ===================================== @@ -554,7 +554,7 @@ 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 True) + FCallId (CCall (CCallSpec (StaticTarget ext lbl ForeignFunction) PrimCallConv _)) -> assert exactly_saturated $ StgOpApp (StgPrimCallOp (PrimCall lbl (staticTargetUnit ext))) stg_args res_ty ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -102,6 +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.Overlap (OverlapMode(..)) import Language.Haskell.Syntax.Extension @@ -1285,7 +1286,7 @@ instance forall p. (IsPass p, OutputableBndrId p) pprCEntity (CLabel lbl) _ = doubleQuotes $ text "static" <+> pp_hdr <+> char '&' <> ppr lbl - pprCEntity (CFunction (StaticTarget stExt _ isFun)) src = + pprCEntity (CFunction (StaticTarget stExt _ targetKind)) src = if dqNeeded then doubleQuotes ce else empty where st = case ghcPass @p of @@ -1294,13 +1295,13 @@ instance forall p. (IsPass p, OutputableBndrId p) GhcTc -> staticTargetLabel stExt dqNeeded = (take 6 src == "static") || isJust mHeader - || not isFun + || targetKind == ForeignValue || st /= NoSourceText ce = -- We may need to drop leading spaces first (if take 6 src == "static" then text "static" else empty) <+> pp_hdr - <+> (if isFun then empty else text "value") + <+> (if targetKind == ForeignFunction then empty else text "value") <+> (pprWithSourceText st empty) pprCEntity (CFunction DynamicTarget{}) _ = doubleQuotes $ text "dynamic" ===================================== compiler/GHC/Hs/Instances.hs ===================================== @@ -33,6 +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.Overlap (OverlapMode(..)) import Language.Haskell.Syntax.Extension (Anno) import Language.Haskell.Syntax.Binds.InlinePragma (ActivationX(..), InlinePragma(..)) ===================================== compiler/GHC/HsToCore/Errors/Types.hs ===================================== @@ -13,6 +13,7 @@ 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,7 +68,8 @@ dsCFExport:: 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 + -> 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 -> DsM ( CHeader -- contents of Module_stub.h @@ -76,29 +77,30 @@ dsCFExport:: Id -- Either the exported Id, , String -- string describing type to pass to createAdj. ) -dsCFExport fn_id co ext_name cconv isDyn = do +dsCFExport fn_id co ext_name cconv target_kind = 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 | isDyn = tail fe_arg_tys' - | otherwise = fe_arg_tys' + fe_arg_tys = case target_kind of + ForeignFunction -> tail fe_arg_tys' + _ -> fe_arg_tys' -- Look at the result type of the exported function, orig_res_ty - -- If it's IO t, return (t, True) - -- If it's plain t, return (t, False) + -- If it's IO t, return (t, ForeignFunction) + -- 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, True) + Just (_ioTyCon, res_ty) -> (res_ty, ForeignFunction) -- The function returns t - Nothing -> (orig_res_ty, False) + Nothing -> (orig_res_ty, ForeignValue) dflags <- getDynFlags return $ mkFExportCBits dflags ext_name - (if isDyn then Nothing else Just fn_id) + (if target_kind == ForeignFunction then Nothing else Just fn_id) fe_arg_tys res_ty is_IO_res_ty cconv dsCImport :: Id @@ -184,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 True + (h_code, c_code, typestring) <- dsCFExport id (mkRepReflCo export_ty) fe_nm cconv ForeignFunction let {- The arguments to the external function which will @@ -258,14 +260,14 @@ dsFCall fn_id co fcall mDeclHeader = do (fcall', cDoc) <- case fcall of - CCall (CCallSpec (StaticTarget stExt cName isFun) + CCall (CCallSpec (StaticTarget stExt 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 - True) + ForeignFunction) CApiConv safety) c = includes $$ fun_proto <+> braces (cRet <> semi) @@ -274,10 +276,10 @@ dsFCall fn_id co fcall mDeclHeader = do | Header _ h <- nub headers ] fun_proto = constQual <+> cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes cRet - | isVoidRes = cCall - | otherwise = text "return" <+> cCall + | isVoidRes = cCall + | otherwise = text "return" <+> cCall cCall - | isFun = ppr cName <> parens argVals + | targetKind == ForeignFunction = 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 @@ -380,13 +382,13 @@ mkFExportCBits :: DynFlags -> Maybe Id -- Just==static, Nothing==dynamic -> [Type] -> Type - -> Bool -- True <=> returns an IO type + -> ForeignKind -- Function <=> returns an IO type -> CCallConv -> (CHeader, CStub, String -- the argument reps ) -mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc +mkFExportCBits dflags c_nm maybe_target arg_htys res_hty io_res_ty cc = ( header_bits , CStub body [] [] @@ -517,7 +519,7 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc char '&' <> cap <> text "rts_apply" <> parens ( cap - <> (if is_IO_res_ty + <> (if io_res_ty == ForeignFunction then text "ghc_hs_iface->runIO_closure" else text "ghc_hs_iface->runNonIO_closure") <> comma ===================================== compiler/GHC/HsToCore/Foreign/Call.hs ===================================== @@ -108,7 +108,7 @@ dsCCall lbl unit args may_gc result_ty { staticTargetLabel = NoSourceText , staticTargetUnit = unit } - target = StaticTarget stExt lbl True + target = StaticTarget stExt lbl ForeignFunction the_fcall = CCall (CCallSpec target CCallConv may_gc) the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty return (foldr ($) (res_wrapper the_prim_app) arg_wrappers) ===================================== compiler/GHC/HsToCore/Foreign/Decl.hs ===================================== @@ -24,6 +24,7 @@ import GHC.HsToCore.Monad import GHC.Hs import GHC.Types.Id +import GHC.Types.ForeignCall import GHC.Types.ForeignStubs import GHC.Unit.Module import GHC.Core.Coercion @@ -92,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 ForeignValue return (h, c, ids, bs) {- @@ -164,7 +165,8 @@ 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 + -> 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 -> DsM ( CHeader -- contents of Module_stub.h @@ -173,16 +175,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 is_dyn = do +dsFExport fn_id co ext_name cconv target_kind = do platform <- getPlatform case (platformArch platform, cconv) of (ArchJavaScript, _) -> do - (h, c, ts) <- dsJsFExport fn_id co ext_name cconv is_dyn + (h, c, ts) <- dsJsFExport fn_id co ext_name cconv target_kind 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 is_dyn + (h, c, ts) <- dsCFExport fn_id co ext_name cconv target_kind pure (h, c, ts, [fn_id], []) ===================================== compiler/GHC/HsToCore/Foreign/JavaScript.hs ===================================== @@ -72,7 +72,8 @@ dsJsFExport -- from C, and its representation type -> CLabelString -- The name to export to C land -> CCallConv - -> Bool -- True => foreign export dynamic + -> 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 -> DsM ( CHeader -- contents of Module_stub.h @@ -80,15 +81,16 @@ dsJsFExport , String -- string describing type to pass to createAdj. ) -dsJsFExport fn_id co ext_name cconv isDyn = do +dsJsFExport fn_id co ext_name cconv target_kind = do let ty = coercionRKind co (_tvs,sans_foralls) = tcSplitForAllTyVars ty (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 | isDyn = tail fe_arg_tys' - | otherwise = fe_arg_tys' + fe_arg_tys = case target_kind of + ForeignFunction -> tail fe_arg_tys' + _ -> fe_arg_tys' -- Look at the result type of the exported function, orig_res_ty -- If it's IO t, return (t, True) @@ -101,7 +103,7 @@ dsJsFExport fn_id co ext_name cconv isDyn = do platform <- targetPlatform <$> getDynFlags return $ mkFExportJSBits platform ext_name - (if isDyn then Nothing else Just fn_id) + (if target_kind == ForeignFunction then Nothing else Just fn_id) (map scaledThing fe_arg_tys) res_ty is_IO_res_ty cconv mkFExportJSBits @@ -282,7 +284,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 ForeignFunction let {- The arguments to the external function which will @@ -652,6 +654,6 @@ mkJsCall u tgt args t = mkFCall u ccall args t , staticTargetUnit = ghcInternalUnit } ccall = CCall $ CCallSpec - (StaticTarget stExt tgt True) + (StaticTarget stExt tgt ForeignFunction) JavaScriptCallConv PlayRisky ===================================== compiler/GHC/HsToCore/Foreign/Wasm.hs ===================================== @@ -460,7 +460,7 @@ importBindingRHS unitId cfun_name tvs arg_tys orig_res_ty res_trans = do let cfun_fcall = CCall ( CCallSpec - (StaticTarget stExt cfun_name True) + (StaticTarget stExt cfun_name ForeignFunction) CCallConv -- Same even for foreign import javascript unsafe, for -- the sake of re-entrancy. ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -70,6 +70,7 @@ import qualified GHC.Data.List.NonEmpty as NE import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Unique import GHC.Types.Var +import GHC.Types.ForeignCall import GHC.Types.Id import GHC.Types.InlinePragma import GHC.Types.SourceText @@ -739,9 +740,9 @@ repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ conv_cimportspec (CLabel cls) = notHandled (ThForeignLabel cls) conv_cimportspec (CFunction (DynamicTarget{})) = return "dynamic" - conv_cimportspec (CFunction (StaticTarget _ fs True)) + conv_cimportspec (CFunction (StaticTarget _ fs ForeignFunction)) = return (unpackFS fs) - conv_cimportspec (CFunction (StaticTarget _ _ False)) + conv_cimportspec (CFunction (StaticTarget _ _ ForeignValue)) = panic "conv_cimportspec: values not supported yet" conv_cimportspec CWrapper = return "wrapper" -- these calling conventions do not support headers and the static keyword ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -142,6 +142,7 @@ import GHC.Types.Name import GHC.Types.Basic import GHC.Types.Error import GHC.Types.Fixity +import GHC.Types.ForeignCall import GHC.Types.Hint import GHC.Types.InlinePragma import GHC.Types.SourceText @@ -3137,7 +3138,7 @@ mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) (timport, td) entity' = if nullFS entity then mkExtName (unLoc v) else entity - funcTarget = CFunction (StaticTarget esrc entity' True) + funcTarget = CFunction (StaticTarget esrc entity' ForeignFunction) importSpec = CImport (L (l2l loc) esrc) (reLoc cconv) (reLoc safety) Nothing funcTarget returnSpec spec = return $ \tforeign -> ForD noExtField $ ForeignImport @@ -3192,15 +3193,15 @@ parseCImport cconv safety nm str sourceText = id_char c = isAlphaNum c || c == '_' cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid) - +++ (do isFun <- case unLoc cconv of + +++ (do targetKind <- case unLoc cconv of CApiConv -> - option True + option ForeignFunction (do token "value" skipSpaces - return False) - _ -> return True + return ForeignValue) + _ -> return ForeignFunction cid' <- cid - return (CFunction (StaticTarget NoSourceText cid' isFun))) + return (CFunction (StaticTarget NoSourceText cid' targetKind))) where cid = return nm +++ (do c <- satisfy id_first_char ===================================== compiler/GHC/Rename/Module.hs ===================================== @@ -50,7 +50,7 @@ import GHC.Builtin.Names( applicativeClassName, pureAName, thenAName import GHC.Types.FieldLabel import GHC.Types.Name.Reader -import GHC.Types.ForeignCall ( StaticTargetGhc(..) ) +import GHC.Types.ForeignCall import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env @@ -434,14 +434,12 @@ patchCImportSpec unit = \case patchCCallTarget :: Unit -> CCallTarget GhcPs -> CCallTarget GhcRn patchCCallTarget unit = \case DynamicTarget x -> DynamicTarget x --- StaticTarget src label Nothing isFun -> --- StaticTarget src label (Just unit) isFun - StaticTarget sTxt label isFun -> + StaticTarget sTxt label targetKind -> let ext = StaticTargetGhc { staticTargetLabel = sTxt , staticTargetUnit = unit } - in StaticTarget ext label isFun + in StaticTarget ext label targetKind {- ********************************************************* ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -2045,9 +2045,9 @@ generateCCall d0 s p (CCallSpec target _ safety) result_ty args maybe_static_target = case target of DynamicTarget{} -> Nothing - StaticTarget _ _ False -> + StaticTarget _ _ ForeignValue -> panic "generateCCall: unexpected FFI value import" - StaticTarget _ target True -> + StaticTarget _ target ForeignFunction -> Just (LitLabel target IsFunction) let ===================================== compiler/GHC/StgToCmm/Foreign.hs ===================================== @@ -78,9 +78,9 @@ cgForeignCall (CCall (CCallSpec target cconv safety)) typ stg_args res_ty ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty ; let ((call_args, arg_hints), cmm_target) = case target of - StaticTarget _ _ False -> + StaticTarget _ _ ForeignValue -> panic "cgForeignCall: unexpected FFI value import" - StaticTarget ext lbl True -> + StaticTarget ext lbl ForeignFunction -> let labelSource = ForeignLabelInPackage . toUnitId $ staticTargetUnit ext in ( unzip cmm_args ===================================== compiler/GHC/StgToJS/FFI.hs ===================================== @@ -181,7 +181,7 @@ genForeignCall :: HasDebugCallStack -> [StgArg] -> G (JStgStat, ExprResult) genForeignCall _ctx - (CCall (CCallSpec (StaticTarget _ tgt True) + (CCall (CCallSpec (StaticTarget _ tgt ForeignFunction) JavaScriptCallConv PlayRisky)) _t ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -197,6 +197,7 @@ 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 ===================================== @@ -355,7 +355,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport src (L lc cconv) (L ls safety) mh checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty checkMissingAmpersand idecl target (map scaledThing arg_tys) res_ty case target of - StaticTarget _ _ False + StaticTarget _ _ ForeignValue | not (null arg_tys) -> addErrTc (TcRnForeignFunctionImportAsValue idecl) _ -> return () @@ -381,7 +381,7 @@ checkCTarget idecl (StaticTarget _ str _) = do checkCTarget _ (DynamicTarget{}) = panic "checkCTarget DynamicTarget" checkMissingAmpersand :: ForeignImport GhcRn -> CCallTarget GhcRn -> [Type] -> Type -> TcM () -checkMissingAmpersand _ (StaticTarget _ _ False) _ _ = return () +checkMissingAmpersand _ (StaticTarget _ _ ForeignValue) _ _ = return () checkMissingAmpersand idecl _ arg_tys res_ty | null arg_tys && isFunPtrTy res_ty ===================================== compiler/GHC/Tc/Types/ErrCtxt.hs ===================================== @@ -37,8 +37,9 @@ import GHC.Unit.State ( UnitState ) import GHC.Data.FastString ( FastString ) import GHC.Utils.Outputable ( Outputable(..) ) -import Language.Haskell.Syntax.Basic ( FieldLabelString(..) ) import Language.Haskell.Syntax +import Language.Haskell.Syntax.Basic ( FieldLabelString(..) ) +import Language.Haskell.Syntax.Decls.ForeignCall ( ForeignDecl(..) ) import GHC.Boot.TH.Syntax qualified as TH import qualified Data.List.NonEmpty as NE ===================================== compiler/GHC/ThToHs.hs ===================================== @@ -40,6 +40,7 @@ import GHC.Builtin.Types import GHC.Builtin.Types.Prim( fUNTyCon ) import GHC.Hs.Decls.Overlap as Hs import GHC.Types.Basic as Hs +import GHC.Types.ForeignCall import GHC.Types.InlinePragma as Hs import GHC.Types.Unique import GHC.Types.SourceText @@ -840,7 +841,7 @@ cvtForD (ImportF callconv safety from nm ty) = (StaticTarget (SourceText fromtxt) fromtxt - True + ForeignFunction ) ) ) ===================================== compiler/GHC/Types/ForeignCall.hs ===================================== @@ -21,13 +21,15 @@ To be resolved at a later time, see TODO at the end of this module. -} module GHC.Types.ForeignCall ( - ForeignCall(..), isSafeForeignCall, + ForeignCall(..), + isSafeForeignCall, Safety(..), playSafe, playInterruptible, CExportSpec(..), CLabelString, isCLabelString, pprCLabelString, CCallSpec(..), CCallTarget(..), isDynamicTarget, CCallConv(..), defaultCCallConv, ccallConvAttribute, + ForeignKind(..), Header(..), CType(..), StaticTargetGhc(..), @@ -45,11 +47,12 @@ import GHC.Unit.Types import Language.Haskell.Syntax.Decls.ForeignCall (CCallConv(..), CCallTarget(..), CExportSpec(..), CLabelString, - CType(..), Header(..), Safety(..)) + CType(..), ForeignKind(..), Header(..), Safety(..)) import Language.Haskell.Syntax.Extension import Data.Char import Data.Data (Data) +import Data.Functor ((<&>)) import Control.DeepSeq (NFData(..)) @@ -140,9 +143,9 @@ 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) -> - let pCallType - | isFun = text "__ffi_static_ccall" - | otherwise = text "__ffi_static_ccall_value" + 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) @@ -320,6 +323,14 @@ instance Binary CType where fs <- get bh return (CType s mh fs) +instance Binary ForeignKind where + put_ bh = putByte bh . \case + ForeignValue -> 0 + ForeignFunction -> 1 + get bh = getByte bh <&> \case + 0 -> ForeignValue + _ -> ForeignFunction + instance Binary Header where put_ bh (Header s h) = put_ bh s >> put_ bh h get bh = do ===================================== compiler/Language/Haskell/Syntax/Decls.hs ===================================== @@ -13,7 +13,7 @@ -- | Abstract syntax of global declarations. -- -- Definitions for: @SynDecl@ and @ConDecl@, @ClassDecl@, --- @InstDecl@, @DefaultDecl@ and @ForeignDecl@. +-- @InstDecl@, @DefaultDecl@. module Language.Haskell.Syntax.Decls ( -- * Toplevel declarations HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep, FunDep(..), @@ -51,10 +51,12 @@ 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, @@ -105,7 +107,7 @@ import Language.Haskell.Syntax.Type import GHC.Data.FastString (FastString) import GHC.Hs.Doc (LHsDoc) -- ROMES:TODO Discuss in #21592 whether this is parsed AST or base AST import GHC.Hs.Doc (WithHsDocIdentifiers) -import GHC.Types.SourceText (SourceText, StringLiteral) +import GHC.Types.SourceText (StringLiteral) import Control.DeepSeq import Control.Monad ===================================== compiler/Language/Haskell/Syntax/Decls/ForeignCall.hs ===================================== @@ -15,8 +15,8 @@ -- Definitions for: @SynDecl@ and @ConDecl@, @ClassDecl@, -- @InstDecl@, @DefaultDecl@ and @ForeignDecl@. module Language.Haskell.Syntax.Decls.ForeignCall ( - -- ** Foreign function interface declarations - ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..), + -- ** Foreign function interface declarationss + ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..), ForeignKind(..), CCallConv(..), CCallTarget(..), CExportSpec(..), CImportSpec(..), CLabelString, CType(..), Header(..), Safety(..), @@ -41,7 +41,6 @@ import Control.DeepSeq import Data.Data hiding (TyCon, Fixity, Infix) import Data.Maybe import Data.Eq -import Data.Bool import Prelude (Enum, Show, seq) {- @@ -144,16 +143,25 @@ data CCallConv | StdCallConv | PrimCallConv | JavaScriptCallConv - deriving (Show, Eq, Data, Enum) + deriving (Enum, Eq, Data, Show) instance NFData CCallConv where - rnf CCallConv = () - rnf StdCallConv = () - rnf PrimCallConv = () - rnf CApiConv = () - rnf JavaScriptCallConv = () - --- TODO TTG: Rename the Bool field + rnf = \case + CCallConv -> () + StdCallConv -> () + PrimCallConv -> () + CApiConv -> () + JavaScriptCallConv -> () + +data ForeignKind + = ForeignValue -- ^ Binds to a value, a zero-arity function. + | ForeignFunction -- ^ Binds to a function with arity /of at least one/. + deriving stock (Enum, Eq, Data, Show) + +instance NFData ForeignKind where + rnf = \case + ForeignValue -> () + ForeignFunction -> () -- | How to call a particular function in C-land. data CCallTarget pass @@ -162,7 +170,7 @@ data CCallTarget pass (XStaticTarget pass) CLabelString -- C-land name of label. -- Used when importing a label as "foreign import ccall "dynamic" ..." - Bool -- True => really a function + ForeignKind -- True => really a function -- False => a value; only -- allowed in CAPI imports ===================================== libraries/text ===================================== @@ -1 +1 @@ -Subproject commit 423fd981e576bd17a8b5fa48d0ad6b9a0c370e77 +Subproject commit 5f343f668f421bfb30cead594e52d0ac6206ff67 ===================================== libraries/transformers ===================================== @@ -1 +1 @@ -Subproject commit 0d615bc2457d5d2c695dcfdb902d88c1225beff3 +Subproject commit cee47cca7705edafe0a5839439e679edbd61890a View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bf8c77a01fbb260be04cfd3438a27626... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bf8c77a01fbb260be04cfd3438a27626... You're receiving this email because of your account on gitlab.haskell.org.