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@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/be1dab4db2cea22c4a7b8548fbc68df1... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/be1dab4db2cea22c4a7b8548fbc68df1... You're receiving this email because of your account on gitlab.haskell.org.