diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/codeGen/CodeGen.lhs | 8 | ||||
| -rw-r--r-- | compiler/deSugar/DsForeign.lhs | 88 | ||||
| -rw-r--r-- | compiler/main/CodeOutput.lhs | 6 | ||||
| -rw-r--r-- | compiler/main/HscMain.lhs | 2 | ||||
| -rw-r--r-- | compiler/main/HscTypes.lhs | 2 |
5 files changed, 50 insertions, 56 deletions
diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs index 64ee9e4c4b..eaaae2c165 100644 --- a/compiler/codeGen/CodeGen.lhs +++ b/compiler/codeGen/CodeGen.lhs @@ -57,14 +57,13 @@ import Panic codeGen :: DynFlags -> Module -> [TyCon] - -> ForeignStubs -> [Module] -- directly-imported modules -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. -> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs -> HpcInfo -> IO [Cmm] -- Output -codeGen dflags this_mod data_tycons foreign_stubs imported_mods +codeGen dflags this_mod data_tycons imported_mods cost_centre_info stg_binds hpc_info = do { showPass dflags "CodeGen" @@ -79,7 +78,7 @@ codeGen dflags this_mod data_tycons foreign_stubs imported_mods ; cmm_tycons <- mapM cgTyCon data_tycons ; cmm_init <- getCmm (mkModuleInit way cost_centre_info this_mod main_mod - foreign_stubs imported_mods hpc_info) + imported_mods hpc_info) ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init]) } -- Put datatype_stuff after code_stuff, because the @@ -141,11 +140,10 @@ mkModuleInit -> CollectedCCs -- cost centre info -> Module -> Module -- name of the Main module - -> ForeignStubs -> [Module] -> HpcInfo -> Code -mkModuleInit way cost_centre_info this_mod main_mod foreign_stubs imported_mods hpc_info +mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info = do { -- Allocate the static boolean that records if this -- module has been registered already emitData Data [CmmDataLabel moduleRegdLabel, diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index 10e072e0d3..ea264abd04 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -40,6 +40,7 @@ import Outputable import FastString import Data.Maybe +import Data.List \end{code} Desugaring of @foreign@ declarations is naturally split up into @@ -64,32 +65,31 @@ dsForeigns :: [LForeignDecl Id] dsForeigns [] = returnDs (NoStubs, []) dsForeigns fos - = foldlDs combine (ForeignStubs empty empty [] [], []) fos - where - combine stubs (L loc decl) = putSrcSpanDs loc (combine1 stubs decl) - - combine1 (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f) - (ForeignImport id _ spec) + = do + fives <- mapM do_ldecl fos + let + (hs, cs, hdrs, idss, bindss) = unzip5 fives + fe_ids = concat idss + fe_init_code = map foreignExportInitialiser fe_ids + -- + return (ForeignStubs + (vcat hs) + (vcat cs $$ vcat fe_init_code) + (nub (concat hdrs)), + (concat bindss)) + where + do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl) + + do_decl (ForeignImport id _ spec) = traceIf (text "fi start" <+> ppr id) `thenDs` \ _ -> dsFImport (unLoc id) spec `thenDs` \ (bs, h, c, mbhd) -> traceIf (text "fi end" <+> ppr id) `thenDs` \ _ -> - returnDs (ForeignStubs (h $$ acc_h) - (c $$ acc_c) - (addH mbhd acc_hdrs) - acc_feb, - bs ++ acc_f) - - combine1 (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f) - (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv))) + returnDs (h, c, maybeToList mbhd, [], bs) + + do_decl (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv))) = dsFExport id (idType id) ext_nm cconv False `thenDs` \(h, c, _, _) -> - returnDs (ForeignStubs (h $$ acc_h) (c $$ acc_c) acc_hdrs (id:acc_feb), - acc_f) - - addH Nothing ls = ls - addH (Just e) ls - | e `elem` ls = ls - | otherwise = e:ls + returnDs (h, c, [], [id], []) \end{code} @@ -505,28 +505,6 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi - -- Initialise foreign exports by registering a stable pointer from an - -- __attribute__((constructor)) function. - -- The alternative is to do this from stginit functions generated in - -- codeGen/CodeGen.lhs; however, stginit functions have a negative impact - -- on binary sizes and link times because the static linker will think that - -- all modules that are imported directly or indirectly are actually used by - -- the program. - -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL) - - initialiser - = case maybe_target of - Nothing -> empty - Just hs_fn -> - vcat - [ text "static void stginit_export_" <> ppr hs_fn - <> text "() __attribute__((constructor));" - , text "static void stginit_export_" <> ppr hs_fn <> text "()" - , braces (text "getStablePtr" - <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure") - <> semi) - ] - -- finally, the whole darn thing c_bits = space $$ @@ -559,8 +537,28 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc , if res_hty_is_unit then empty else text "return cret;" , rbrace - ] $$ - initialiser + ] + + +foreignExportInitialiser :: Id -> SDoc +foreignExportInitialiser hs_fn = + -- Initialise foreign exports by registering a stable pointer from an + -- __attribute__((constructor)) function. + -- The alternative is to do this from stginit functions generated in + -- codeGen/CodeGen.lhs; however, stginit functions have a negative impact + -- on binary sizes and link times because the static linker will think that + -- all modules that are imported directly or indirectly are actually used by + -- the program. + -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL) + vcat + [ text "static void stginit_export_" <> ppr hs_fn + <> text "() __attribute__((constructor));" + , text "static void stginit_export_" <> ppr hs_fn <> text "()" + , braces (text "getStablePtr" + <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure") + <> semi) + ] + -- NB. the calculation here isn't strictly speaking correct. -- We have a primitive Haskell type (eg. Int#, Double#), and diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index b155a35ccf..25a10f6fe5 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -124,8 +124,8 @@ outputC dflags filenm mod location flat_absC ffi_decl_headers = case foreign_stubs of - NoStubs -> [] - ForeignStubs _ _ fdhs _ -> map unpackFS (nub fdhs) + NoStubs -> [] + ForeignStubs _ _ fdhs -> map unpackFS (nub fdhs) -- Remove duplicates, because distinct foreign import decls -- may cite the same #include. Order doesn't matter. @@ -217,7 +217,7 @@ outputForeignStubs dflags mod location stubs stub_h_exists <- doesFileExist stub_h return (stub_h_exists, stub_c_exists) - | ForeignStubs h_code c_code _ _ <- stubs + | ForeignStubs h_code c_code _ <- stubs = do let stub_c_output_d = pprCode CStyle c_code diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 346e8043ea..a9c9a1501d 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -601,7 +601,7 @@ hscCompile cgguts ------------------ Code generation ------------------ abstractC <- {-# SCC "CodeGen" #-} codeGen dflags this_mod data_tycons - foreign_stubs dir_imps cost_centre_info + dir_imps cost_centre_info stg_binds hpc_info ------------------ Convert to CPS -------------------- --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index acb47c5221..cb5022e368 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -608,8 +608,6 @@ data ForeignStubs = NoStubs -- "foreign exported" functions [FastString] -- Headers that need to be included -- into C code generated for this module - [Id] -- Foreign-exported binders - -- we have to generate code to register these \end{code} |