TcForeign.lhs 12.8 KB
Newer Older
sof's avatar
sof committed
1
%
2
% (c) The University of Glasgow 2006
sof's avatar
sof committed
3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20
% (c) The AQUA Project, Glasgow University, 1998
%
\section[TcForeign]{Typechecking \tr{foreign} declarations}

A foreign declaration is used to either give an externally
implemented function a Haskell type (and calling interface) or
give a Haskell function an external calling interface. Either way,
the range of argument and result types these functions can accommodate
is restricted to what the outside world understands (read C), and this
module checks to see if a foreign declaration has got a legal type.

\begin{code}
module TcForeign 
	( 
	  tcForeignImports
        , tcForeignExports
	) where

21 22
#include "HsVersions.h"

23
import HsSyn
sof's avatar
sof committed
24

25
import TcRnMonad
26 27
import TcHsType
import TcExpr
sof's avatar
sof committed
28

29 30 31
import ForeignCall
import ErrUtils
import Id
32
#if alpha_TARGET_ARCH
33 34 35
import Type
import SMRep
import MachOp
36
#endif
37
import Name
38
import OccName
39 40
import TcType
import DynFlags
sof's avatar
sof committed
41
import Outputable
42 43
import SrcLoc
import Bag
44
import Unique
45
import FastString
sof's avatar
sof committed
46 47
\end{code}

48 49
\begin{code}
-- Defines a binding
50
isForeignImport :: LForeignDecl name -> Bool
Simon Marlow's avatar
Simon Marlow committed
51
isForeignImport (L _ (ForeignImport _ _ _)) = True
52
isForeignImport _			      = False
53 54

-- Exports a binding
55
isForeignExport :: LForeignDecl name -> Bool
Simon Marlow's avatar
Simon Marlow committed
56
isForeignExport (L _ (ForeignExport _ _ _)) = True
57
isForeignExport _	  	              = False
58 59 60 61 62 63 64 65
\end{code}

%************************************************************************
%*									*
\subsection{Imports}
%*									*
%************************************************************************

sof's avatar
sof committed
66
\begin{code}
67
tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id])
68
tcForeignImports decls
69
  = mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls)
sof's avatar
sof committed
70

71
tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
Simon Marlow's avatar
Simon Marlow committed
72
tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
73 74
 = addErrCtxt (foreignDeclCtxt fo)  $ do
   sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
75 76 77
   let 
      -- drop the foralls before inspecting the structure
      -- of the foreign type.
78 79
	(_, t_ty)	  = tcSplitForAllTys sig_ty
	(arg_tys, res_ty) = tcSplitFunTys t_ty
80 81 82 83
	id		  = mkLocalId nm sig_ty
 		-- Use a LocalId to obey the invariant that locally-defined 
		-- things are LocalIds.  However, it does not need zonking,
		-- (so TcHsSyn.zonkForeignExports ignores it).
84 85
   
   imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
86 87
   -- can't use sig_ty here because it :: Type and we need HsType Id
   -- hence the undefined
88
   return (id, ForeignImport (L loc id) undefined imp_decl')
Ian Lynagh's avatar
Ian Lynagh committed
89
tcFImport d = pprPanic "tcFImport" (ppr d)
90 91 92 93 94
\end{code}


------------ Checking types for foreign import ----------------------
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
95
tcCheckFIType :: Type -> [Type] -> Type -> ForeignImport -> TcM ForeignImport
96 97 98 99 100 101 102
tcCheckFIType _ arg_tys res_ty (DNImport spec) = do
    checkCg checkDotnet
    dflags <- getDOpts
    checkForeignArgs (isFFIDotnetTy dflags) arg_tys
    checkForeignRes True{-non IO ok-} (isFFIDotnetTy dflags) res_ty
    let (DNCallSpec isStatic kind _ _ _ _) = spec
    case kind of
sof's avatar
sof committed
103 104 105 106 107
       DNMethod | not isStatic ->
         case arg_tys of
	   [] -> addErrTc illegalDNMethodSig
	   _  
	    | not (isFFIDotnetObjTy (last arg_tys)) -> addErrTc illegalDNMethodSig
108 109 110
	    | otherwise -> return ()
       _ -> return ()
    return (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty)))
sof's avatar
sof committed
111

Ian Lynagh's avatar
Ian Lynagh committed
112
tcCheckFIType sig_ty _ _ idecl@(CImport _ _ _ _ (CLabel _)) = do
113 114
    checkCg checkCOrAsm
    check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty)
sof's avatar
sof committed
115
    return idecl
116

117 118
tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper) = do
   	-- Foreign wrapper (former f.e.d.)
chak's avatar
chak committed
119 120 121 122
   	-- The type must be of the form ft -> IO (FunPtr ft), where ft is a
   	-- valid foreign type.  For legacy reasons ft -> IO (Ptr ft) as well
   	-- as ft -> IO Addr is accepted, too.  The use of the latter two forms
   	-- is DEPRECATED, though.
123 124 125 126 127 128 129 130 131
    checkCg checkCOrAsmOrInterp
    checkCConv cconv
    case arg_tys of
        [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys
                        checkForeignRes nonIOok  isFFIExportResultTy res1_ty
                        checkForeignRes mustBeIO isFFIDynResultTy    res_ty
                        checkFEDArgs arg1_tys
                  where
                     (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
Ian Lynagh's avatar
Ian Lynagh committed
132
        _ -> addErrTc (illegalForeignTyErr empty sig_ty)
sof's avatar
sof committed
133
    return idecl
134

135
tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction target))
136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156
  | isDynamicTarget target = do -- Foreign import dynamic
      checkCg checkCOrAsmOrInterp
      checkCConv cconv
      case arg_tys of           -- The first arg must be Ptr, FunPtr, or Addr
        []                -> do
          check False (illegalForeignTyErr empty sig_ty)
          return idecl
        (arg1_ty:arg_tys) -> do
          dflags <- getDOpts
          check (isFFIDynArgumentTy arg1_ty)
                (illegalForeignTyErr argument arg1_ty)
          checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
          checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
          return idecl
  | otherwise = do              -- Normal foreign import
      checkCg (checkCOrAsmOrDotNetOrInterp)
      checkCConv cconv
      checkCTarget target
      dflags <- getDOpts
      checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
      checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
157
      checkMissingAmpersand dflags arg_tys res_ty
158
      return idecl
159 160 161

-- This makes a convenient place to check
-- that the C identifier is valid for C
Ian Lynagh's avatar
Ian Lynagh committed
162
checkCTarget :: CCallTarget -> TcM ()
163 164
checkCTarget (StaticTarget str) = do
    checkCg checkCOrAsmOrDotNetOrInterp
165
    check (isCLabelString str) (badCName str)
Ian Lynagh's avatar
Ian Lynagh committed
166
checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget"
167 168 169 170 171 172 173 174

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 ()
175
\end{code}
176

177 178
On an Alpha, with foreign export dynamic, due to a giant hack when
building adjustor thunks, we only allow 4 integer arguments with
ken's avatar
ken committed
179 180 181
foreign export dynamic (i.e., 32 bytes of arguments after padding each
argument to a quadword, excluding floating-point arguments).

182 183 184 185
The check is needed for both via-C and native-code routes

\begin{code}
#include "nativeGen/NCG.h"
Ian Lynagh's avatar
Ian Lynagh committed
186 187

checkFEDArgs :: [Type] -> TcM ()
188
#if alpha_TARGET_ARCH
ken's avatar
ken committed
189
checkFEDArgs arg_tys
190
  = check (integral_args <= 32) err
ken's avatar
ken committed
191
  where
192 193 194
    integral_args = sum [ (machRepByteWidth . argMachRep . primRepToCgRep) prim_rep
			| prim_rep <- map typePrimRep arg_tys,
			  primRepHint prim_rep /= FloatHint ]
Ian Lynagh's avatar
Ian Lynagh committed
195
    err = ptext (sLit "On Alpha, I can only handle 32 bytes of non-floating-point arguments to foreign export dynamic")
196
#else
Ian Lynagh's avatar
Ian Lynagh committed
197
checkFEDArgs _ = return ()
198 199
#endif
\end{code}
200 201 202 203 204 205 206 207 208


%************************************************************************
%*									*
\subsection{Exports}
%*									*
%************************************************************************

\begin{code}
209 210
tcForeignExports :: [LForeignDecl Name] 
    		 -> TcM (LHsBinds TcId, [LForeignDecl TcId])
211
tcForeignExports decls
212
  = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
sof's avatar
sof committed
213
  where
214 215 216
   combine (binds, fs) fe = do
       (b, f) <- wrapLocSndM tcFExport fe
       return (b `consBag` binds, f:fs)
sof's avatar
sof committed
217

218
tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
Simon Marlow's avatar
Simon Marlow committed
219
tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
220
   addErrCtxt (foreignDeclCtxt fo)      $ do
sof's avatar
sof committed
221

222 223
   sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
   rhs <- tcPolyExpr (nlHsVar nm) sig_ty
224

225
   tcCheckFEType sig_ty spec
sof's avatar
sof committed
226

chak's avatar
chak committed
227 228
	  -- we're exporting a function, but at a type possibly more
	  -- constrained than its declared/inferred type. Hence the need
sof's avatar
sof committed
229 230
	  -- to create a local binding which will call the exported function
	  -- at a particular type (and, maybe, overloading).
231

232 233
   uniq <- newUnique
   mod <- getModule
234
   let
235 236 237 238 239 240 241 242 243 244 245
          -- 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
246
	id   = mkExportedLocalId gnm sig_ty
247
	bind = L loc (VarBind id rhs)
248 249

   return (bind, ForeignExport (L loc id) undefined spec)
Ian Lynagh's avatar
Ian Lynagh committed
250
tcFExport d = pprPanic "tcFExport" (ppr d)
251 252 253
\end{code}

------------ Checking argument types for foreign export ----------------------
sof's avatar
sof committed
254

255
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
256
tcCheckFEType :: Type -> ForeignExport -> TcM ()
257 258 259
tcCheckFEType sig_ty (CExport (CExportStatic str _)) = do
    check (isCLabelString str) (badCName str)
    checkForeignArgs isFFIExternalTy arg_tys
260 261 262 263
    checkForeignRes nonIOok isFFIExportResultTy res_ty
  where
      -- Drop the foralls before inspecting n
      -- the structure of the foreign type.
264 265
    (_, t_ty) = tcSplitForAllTys sig_ty
    (arg_tys, res_ty) = tcSplitFunTys t_ty
Ian Lynagh's avatar
Ian Lynagh committed
266
tcCheckFEType _ d = pprPanic "tcCheckFEType" (ppr d)
sof's avatar
sof committed
267 268 269
\end{code}


270 271 272 273 274 275 276

%************************************************************************
%*									*
\subsection{Miscellaneous}
%*									*
%************************************************************************

sof's avatar
sof committed
277
\begin{code}
278
------------ Checking argument types for foreign import ----------------------
279
checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM ()
280
checkForeignArgs pred tys
281
  = mapM_ go tys
282
  where
283
    go ty = check (pred ty) (illegalForeignTyErr argument ty)
284 285

------------ Checking result types for foreign calls ----------------------
sof's avatar
sof committed
286
-- Check that the type has the form 
287
--    (IO t) or (t) , and that t satisfies the given predicate.
sof's avatar
sof committed
288
--
289
checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
290

Ian Lynagh's avatar
Ian Lynagh committed
291
nonIOok, mustBeIO :: Bool
292 293 294
nonIOok  = True
mustBeIO = False

295
checkForeignRes non_io_result_ok pred_res_ty ty
296
	-- (IO t) is ok, and so is any newtype wrapping thereof
Ian Lynagh's avatar
Ian Lynagh committed
297
  | Just (_, res_ty, _) <- tcSplitIOType_maybe ty,
298
    pred_res_ty res_ty
299
  = return ()
300 301 302 303
 
  | otherwise
  = check (non_io_result_ok && pred_res_ty ty) 
	  (illegalForeignTyErr result ty)
sof's avatar
sof committed
304 305
\end{code}

306
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
307
checkDotnet :: HscTarget -> Maybe SDoc
sof's avatar
sof committed
308 309 310 311
#if defined(mingw32_TARGET_OS)
checkDotnet HscC   = Nothing
checkDotnet _      = Just (text "requires C code generation (-fvia-C)")
#else
Ian Lynagh's avatar
Ian Lynagh committed
312
checkDotnet _      = Just (text "requires .NET support (-filx or win32)")
sof's avatar
sof committed
313
#endif
314

Ian Lynagh's avatar
Ian Lynagh committed
315
checkCOrAsm :: HscTarget -> Maybe SDoc
316 317
checkCOrAsm HscC   = Nothing
checkCOrAsm HscAsm = Nothing
Ian Lynagh's avatar
Ian Lynagh committed
318
checkCOrAsm _
319 320
   = Just (text "requires via-C or native code generation (-fvia-C)")

Ian Lynagh's avatar
Ian Lynagh committed
321
checkCOrAsmOrInterp :: HscTarget -> Maybe SDoc
322 323 324
checkCOrAsmOrInterp HscC           = Nothing
checkCOrAsmOrInterp HscAsm         = Nothing
checkCOrAsmOrInterp HscInterpreted = Nothing
Ian Lynagh's avatar
Ian Lynagh committed
325
checkCOrAsmOrInterp _
326
   = Just (text "requires interpreted, C or native code generation")
327

Ian Lynagh's avatar
Ian Lynagh committed
328
checkCOrAsmOrDotNetOrInterp :: HscTarget -> Maybe SDoc
329 330 331
checkCOrAsmOrDotNetOrInterp HscC           = Nothing
checkCOrAsmOrDotNetOrInterp HscAsm         = Nothing
checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
Ian Lynagh's avatar
Ian Lynagh committed
332
checkCOrAsmOrDotNetOrInterp _
333
   = Just (text "requires interpreted, C or native code generation")
334

Ian Lynagh's avatar
Ian Lynagh committed
335
checkCg :: (HscTarget -> Maybe SDoc) -> TcM ()
336 337 338
checkCg check = do
   dflags <- getDOpts
   let target = hscTarget dflags
339
   case target of
340
     HscNothing -> return ()
Ian Lynagh's avatar
Ian Lynagh committed
341
     _ ->
342
       case check target of
343
	 Nothing  -> return ()
chak's avatar
chak committed
344
	 Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
SamB's avatar
SamB committed
345
\end{code}
346
			   
347 348 349 350 351 352 353 354 355 356
Calling conventions

\begin{code}
checkCConv :: CCallConv -> TcM ()
checkCConv CCallConv  = return ()
#if i386_TARGET_ARCH
checkCConv StdCallConv = return ()
#else
checkCConv StdCallConv = addErrTc (text "calling convention not supported on this architecture: stdcall")
#endif
Ian Lynagh's avatar
Ian Lynagh committed
357
checkCConv CmmCallConv = panic "checkCConv CmmCallConv"
358 359
\end{code}

sof's avatar
sof committed
360 361 362
Warnings

\begin{code}
363
check :: Bool -> Message -> TcM ()
364
check True _	   = return ()
365
check _    the_err = addErrTc the_err
366

Ian Lynagh's avatar
Ian Lynagh committed
367
illegalForeignTyErr :: SDoc -> Type -> SDoc
368
illegalForeignTyErr arg_or_res ty
Ian Lynagh's avatar
Ian Lynagh committed
369 370
  = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res, 
                ptext (sLit "type in foreign declaration:")])
371
	 4 (hsep [ppr ty])
sof's avatar
sof committed
372

373
-- Used for 'arg_or_res' argument to illegalForeignTyErr
Ian Lynagh's avatar
Ian Lynagh committed
374
argument, result :: SDoc
375 376 377 378
argument = text "argument"
result   = text "result"

badCName :: CLabelString -> Message
379
badCName target 
Ian Lynagh's avatar
Ian Lynagh committed
380
   = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
381

Ian Lynagh's avatar
Ian Lynagh committed
382
foreignDeclCtxt :: ForeignDecl Name -> SDoc
383
foreignDeclCtxt fo
Ian Lynagh's avatar
Ian Lynagh committed
384
  = hang (ptext (sLit "When checking declaration:"))
385
         4 (ppr fo)
sof's avatar
sof committed
386

Ian Lynagh's avatar
Ian Lynagh committed
387 388
illegalDNMethodSig :: SDoc
illegalDNMethodSig
Ian Lynagh's avatar
Ian Lynagh committed
389
  = ptext (sLit "'This pointer' expected as last argument")
sof's avatar
sof committed
390

sof's avatar
sof committed
391
\end{code}
392