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