Refactoring only: remove [Id] field from ForeignStubs

We used to pass the list of top-level foreign exported bindings to the
code generator so that it could create StablePtrs for them in the
stginit code.  Now we don't use stginit unless profiling, and the
StablePtrs are generated by C functions marked with
attribute((constructor)).  This patch removes various bits associated
with the old way of doing things, which were previously left in place
in case we wanted to switch back, I presume.  Also I refactored
dsForeigns to clean it up a bit.

diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs
index 64ee9e4..eaaae2c 100644 (file)
--- a/compiler/codeGen/CodeGen.lhs
+++ b/compiler/codeGen/CodeGen.lhs
@@ -57,14 +57,13 @@ import Panic
 codeGen :: DynFlags
        -> Module
        -> [TyCon]
 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
 
        -> [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"
        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
                ; 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
                ; 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
        -> CollectedCCs         -- cost centre info
        -> Module
        -> Module               -- name of the Main module

-       -> ForeignStubs

        -> [Module]
        -> HpcInfo
        -> Code
        -> [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, 
   = 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 10e072e..ea264ab 100644 (file)
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -40,6 +40,7 @@ import Outputable
 import FastString
 
 import Data.Maybe
 import FastString
 
 import Data.Maybe

+import Data.List

 \end{code}
 
 Desugaring of @foreign@ declarations is naturally split up into
 \end{code}
 
 Desugaring of @foreign@ declarations is naturally split up into

@@ -64,32 +65,31 @@ dsForeigns :: [LForeignDecl Id]
 dsForeigns [] 
   = returnDs (NoStubs, [])
 dsForeigns fos
 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` \ _ ->
     = 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, _, _) ->
     = 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}
 
 
 \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
 
    
           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 $$
   -- 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
      ,   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
 
 -- 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 b155a35..25a10f6 100644 (file)
--- 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
        
           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.
 
                        -- 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)
 
        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
   = do
        let
            stub_c_output_d = pprCode CStyle c_code

diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs
index 346e804..a9c9a15 100644 (file)
--- 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
          ------------------  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
                               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 acb47c5..cb5022e 100644 (file)
--- 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
                                         --     "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}
 
 
 \end{code}