Fix Trac #3850

[ghc-hetmet.git] / compiler / rename / RnSource.lhs

diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 9842d45..6984a4b 100644 (file)
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -31,6 +31,8 @@ import HscTypes       ( GenAvailInfo(..), availsToNameSet )
 import RnHsDoc          ( rnHsDoc, rnMbLHsDoc )
 import TcRnMonad
 
+import ForeignCall     ( CCallTarget(..) )
+import Module
 import HscTypes                ( Warnings(..), plusWarns )
 import Class           ( FunDep )
 import Name            ( Name, nameOccName )
@@ -41,10 +43,12 @@ import Bag
 import FastString
 import Util            ( filterOut )
 import SrcLoc
-import DynFlags                ( DynFlag(..) )
+import DynFlags                ( DynFlag(..), DynFlags, thisPackage )
+import HscTypes                ( HscEnv, hsc_dflags )
 import BasicTypes       ( Boxity(..) )
 import ListSetOps       ( findDupsEq )
 
+
 import Control.Monad
 import Data.Maybe
 \end{code}
@@ -368,9 +372,15 @@ rnDefaultDecl (DefaultDecl tys)
 \begin{code}
 rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars)
 rnHsForeignDecl (ForeignImport name ty spec)
-  = lookupLocatedTopBndrRn name                `thenM` \ name' ->
+  = getTopEnv                           `thenM` \ (topEnv :: HscEnv) ->
+    lookupLocatedTopBndrRn name                `thenM` \ name' ->
     rnHsTypeFVs (fo_decl_msg name) ty  `thenM` \ (ty', fvs) ->
-    return (ForeignImport name' ty' spec, fvs)
+
+    -- Mark any PackageTarget style imports as coming from the current package
+    let packageId      = thisPackage $ hsc_dflags topEnv
+       spec'           = patchForeignImport packageId spec
+
+    in return (ForeignImport name' ty' spec', fvs)
 
 rnHsForeignDecl (ForeignExport name ty spec)
   = lookupLocatedOccRn name            `thenM` \ name' ->
@@ -382,6 +392,32 @@ rnHsForeignDecl (ForeignExport name ty spec)
 
 fo_decl_msg :: Located RdrName -> SDoc
 fo_decl_msg name = ptext (sLit "In the foreign declaration for") <+> ppr name
+
+
+-- | For Windows DLLs we need to know what packages imported symbols are from
+--     to generate correct calls. Imported symbols are tagged with the current
+--     package, so if they get inlined across a package boundry we'll still
+--     know where they're from.
+--
+patchForeignImport :: PackageId -> ForeignImport -> ForeignImport
+patchForeignImport packageId (CImport cconv safety fs spec)
+       = CImport cconv safety fs (patchCImportSpec packageId spec) 
+
+patchCImportSpec :: PackageId -> CImportSpec -> CImportSpec
+patchCImportSpec packageId spec
+ = case spec of
+       CFunction callTarget    -> CFunction $ patchCCallTarget packageId callTarget
+       _                       -> spec
+
+patchCCallTarget :: PackageId -> CCallTarget -> CCallTarget
+patchCCallTarget packageId callTarget
+ = case callTarget of
+       StaticTarget label Nothing
+        -> StaticTarget label (Just packageId)
+
+       _                       -> callTarget   
+
+
 \end{code}
 
 
@@ -690,9 +726,10 @@ rnTyClDecl tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
                   else emptyFVs))
         }
   where
-    h98_style = case condecls of
-                    L _ (ConDecl { con_res = ResTyH98 }) : _  -> True
-                    _                                         -> False
+    h98_style = case condecls of        -- Note [Stupid theta]
+                    L _ (ConDecl { con_res = ResTyGADT {} }) : _  -> False
+                    _                                             -> True
+                                                                                 
     data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
 
     rn_derivs Nothing   = return (Nothing, emptyFVs)
@@ -788,6 +825,15 @@ badGadtStupidTheta _
          ptext (sLit "(You can put a context on each contructor, though.)")]
 \end{code}
 
+Note [Stupid theta]
+~~~~~~~~~~~~~~~~~~~
+Trac #3850 complains about a regression wrt 6.10 for 
+     data Show a => T a
+There is no reason not to allow the stupid theta if there are no data
+constructors.  It's still stupid, but does no harm, and I don't want
+to cause programs to break unnecessarily (notably HList).  So if there
+are no data constructors we allow h98_style = True
+
 
 %*********************************************************
 %*                                                     *