[project @ 2005-10-17 10:01:35 by simonmar]

[ghc-hetmet.git] / ghc / compiler / deSugar / DsForeign.lhs

diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs
index a99b354..d9e6ba4 100644 (file)
--- a/ghc/compiler/deSugar/DsForeign.lhs
+++ b/ghc/compiler/deSugar/DsForeign.lhs
@@ -80,11 +80,13 @@ dsForeigns []
 dsForeigns fos
   = foldlDs combine (ForeignStubs empty empty [] [], []) fos
  where
-  combine (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f) 
-         (L loc (ForeignImport id _ spec depr))
+  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 depr)
     = traceIf (text "fi start" <+> ppr id)     `thenDs` \ _ ->
       dsFImport (unLoc id) spec                        `thenDs` \ (bs, h, c, mbhd) -> 
-      warnDepr depr loc                                `thenDs` \ _                ->
+      warnDepr depr                            `thenDs` \ _                ->
       traceIf (text "fi end" <+> ppr id)       `thenDs` \ _ ->
       returnDs (ForeignStubs (h $$ acc_h)
                             (c $$ acc_c)
@@ -92,11 +94,11 @@ dsForeigns fos
                             acc_feb, 
                bs ++ acc_f)
 
-  combine (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f) 
-         (L loc (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv)) depr))
+  combine1 (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f) 
+          (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv)) depr)
     = dsFExport id (idType id) 
                ext_nm cconv False                 `thenDs` \(h, c, _, _) ->
-      warnDepr depr loc                                   `thenDs` \_              ->
+      warnDepr depr                               `thenDs` \_              ->
       returnDs (ForeignStubs (h $$ acc_h) (c $$ acc_c) acc_hdrs (id:acc_feb), 
                acc_f)
 
@@ -105,8 +107,8 @@ dsForeigns fos
    | e `elem` ls = ls
    | otherwise   = e:ls
 
-  warnDepr False _   = returnDs ()
-  warnDepr True  loc = dsWarn (loc, msg)
+  warnDepr False = returnDs ()
+  warnDepr True  = dsWarn msg
      where
        msg = ptext SLIT("foreign declaration uses deprecated non-standard syntax")
 \end{code}
@@ -208,12 +210,6 @@ dsFCall fn_id fcall no_hdrs
     let
        work_arg_ids  = [v | Var v <- val_args] -- All guaranteed to be vars
 
-       -- These are the ids we pass to boxResult, which are used to decide
-       -- whether to touch# an argument after the call (used to keep
-       -- ForeignObj#s live across a 'safe' foreign import).
-       maybe_arg_ids | unsafe_call fcall = work_arg_ids
-                     | otherwise         = []
-
        forDotnet = 
         case fcall of
           DNCall{} -> True
@@ -240,7 +236,7 @@ dsFCall fn_id fcall no_hdrs
     in
     augmentResultDs                                 `thenDs` \ augment -> 
     topConDs                                        `thenDs` \ topCon -> 
-    boxResult maybe_arg_ids augment topCon io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
+    boxResult augment topCon io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
 
     newUnique                                  `thenDs` \ ccall_uniq ->
     newUnique                                  `thenDs` \ work_uniq ->
@@ -540,21 +536,10 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
    -- the program.
    -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)
 
-   -- the only reason for making the mingw32 (anything targetting PE, really) stick
-   -- out here is that the GHCi linker isn't capable of handling .ctors sections
-  useStaticConstructors 
-#if defined(mingw32_HOST_OS)
-       = False
-#else
-       = True
-#endif  
-
   initialiser
      = case maybe_target of
           Nothing -> empty
-          Just hs_fn 
-          | not useStaticConstructors -> empty
-          | otherwise ->
+          Just hs_fn ->
             vcat
              [ text "static void stginit_export_" <> ppr hs_fn
                   <> text "() __attribute__((constructor));"