From bc3bcc2c6b53b712b5a4e290581ef82dd73cd528 Mon Sep 17 00:00:00 2001
From: sof <unknown>
Date: Tue, 27 Jul 1999 10:53:53 +0000
Subject: [PATCH] [project @ 1999-07-27 10:53:53 by sof] If calling a 'foreign
export'ed Haskell function resulted in an error, localise the error by
supplying the module name as well as the name of the function.
---
ghc/compiler/deSugar/DsForeign.lhs | 12 +++++++-----
1 file changed, 7 insertions(+), 5 deletions(-)
diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs
index f9445814c7dd..f0370b84a331 100644
--- a/ghc/compiler/deSugar/DsForeign.lhs
+++ b/ghc/compiler/deSugar/DsForeign.lhs
@@ -24,7 +24,7 @@ import Const ( Con(..), mkMachInt )
import DataCon ( DataCon, dataConId )
import Id ( Id, idType, idName, mkWildId, mkVanillaId )
import Const ( Literal(..) )
-import Module ( Module )
+import Module ( Module, moduleUserString )
import Name ( mkGlobalName, nameModule, nameOccName, getOccString,
mkForeignExportOcc, isLocalName,
NamedThing(..), Provenance(..), ExportFlag(..)
@@ -293,7 +293,8 @@ dsFExport i ty mod_name ext_name cconv isDyn =
ExtName fs _ -> fs
Dynamic -> panic "dsFExport: Dynamic - shouldn't ever happen."
- (h_stub, c_stub) = fexportEntry c_nm f_helper_glob
+ (h_stub, c_stub) = fexportEntry (moduleUserString mod)
+ c_nm f_helper_glob
wrapper_arg_tys the_result_ty cconv isDyn
in
returnDs (NonRec f_helper_glob the_body, h_stub, c_stub)
@@ -457,14 +458,15 @@ The C stub constructs the application of the exported Haskell function
using the hugs/ghc rts invocation API.
\begin{code}
-fexportEntry :: FAST_STRING
+fexportEntry :: String
+ -> FAST_STRING
-> Id
-> [Type]
-> Maybe Type
-> CallConv
-> Bool
-> (SDoc, SDoc)
-fexportEntry c_nm helper args res cc isDyn = (header_bits, c_bits)
+fexportEntry mod_nm c_nm helper args res cc isDyn = (header_bits, c_bits)
where
-- name of the (Haskell) helper function generated by the desugarer.
h_nm = ppr helper <> text "_closure"
@@ -510,7 +512,7 @@ fexportEntry c_nm helper args res cc isDyn = (header_bits, c_bits)
returnResult =
text "rts_checkSchedStatus" <>
- parens (doubleQuotes (ptext c_nm) <> comma <> text "rc") <> semi $$
+ parens (doubleQuotes (text mod_nm <> char '.' <> ptext c_nm) <> comma <> text "rc") <> semi $$
(case res of
Nothing -> text "return"
Just _ -> text "return" <> parens (res_name)) <> semi
--
GitLab