Merging in the new codegen branch

[ghc-hetmet.git] / compiler / typecheck / TcForeign.lhs

diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
index 4f05fb7..b1dda2d 100644 (file)
--- a/compiler/typecheck/TcForeign.lhs
+++ b/compiler/typecheck/TcForeign.lhs
@@ -25,6 +25,7 @@ import HsSyn
 import TcRnMonad
 import TcHsType
 import TcExpr
+import TcEnv
 
 import ForeignCall
 import ErrUtils
@@ -32,7 +33,6 @@ import Id
 #if alpha_TARGET_ARCH
 import Type
 import SMRep
-import MachOp
 #endif
 import Name
 import OccName
@@ -41,7 +41,6 @@ import DynFlags
 import Outputable
 import SrcLoc
 import Bag
-import Unique
 import FastString
 \end{code}
 
@@ -154,6 +153,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction t
       dflags <- getDOpts
       checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
       checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
+      checkMissingAmpersand dflags arg_tys res_ty
       return idecl
 
 -- This makes a convenient place to check
@@ -163,6 +163,14 @@ checkCTarget (StaticTarget str) = do
     checkCg checkCOrAsmOrDotNetOrInterp
     check (isCLabelString str) (badCName str)
 checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget"
+
+checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM ()
+checkMissingAmpersand dflags arg_tys res_ty
+  | null arg_tys && isFunPtrTy res_ty &&
+    dopt Opt_WarnDodgyForeignImports dflags
+  = addWarn (ptext (sLit "possible missing & in foreign import of FunPtr"))
+  | otherwise
+  = return ()
 \end{code}
 
 On an Alpha, with foreign export dynamic, due to a giant hack when
@@ -180,7 +188,7 @@ checkFEDArgs :: [Type] -> TcM ()
 checkFEDArgs arg_tys
   = check (integral_args <= 32) err
   where
-    integral_args = sum [ (machRepByteWidth . argMachRep . primRepToCgRep) prim_rep
+    integral_args = sum [ (widthInBytes . argMachRep . primRepToCgRep) prim_rep
                        | prim_rep <- map typePrimRep arg_tys,
                          primRepHint prim_rep /= FloatHint ]
     err = ptext (sLit "On Alpha, I can only handle 32 bytes of non-floating-point arguments to foreign export dynamic")
@@ -220,24 +228,12 @@ tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
          -- to create a local binding which will call the exported function
          -- at a particular type (and, maybe, overloading).
 
-   uniq <- newUnique
-   mod <- getModule
-   let
-          -- We need to give a name to the new top-level binding that
-          -- is *stable* (i.e. the compiler won't change it later),
-          -- because this name will be referred to by the C code stub.
-          -- Furthermore, the name must be unique (see #1533).  If the
-          -- same function is foreign-exported multiple times, the
-          -- top-level bindings generated must not have the same name.
-          -- Hence we create an External name (doesn't change), and we
-          -- append a Unique to the string right here.
-        uniq_str = showSDoc (pprUnique uniq)
-        occ = mkVarOcc (occNameString (getOccName nm) ++ '_' : uniq_str)
-        gnm  = mkExternalName uniq mod (mkForeignExportOcc occ) loc
-       id   = mkExportedLocalId gnm sig_ty
-       bind = L loc (VarBind id rhs)
-
-   return (bind, ForeignExport (L loc id) undefined spec)
+
+   -- We need to give a name to the new top-level binding that
+   -- is *stable* (i.e. the compiler won't change it later),
+   -- because this name will be referred to by the C code stub.
+   id  <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
+   return (L loc (VarBind id rhs), ForeignExport (L loc id) undefined spec)
 tcFExport d = pprPanic "tcFExport" (ppr d)
 \end{code}