TcForeign.lhs 12.5 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
28
import TcEnv
sof's avatar
sof committed
29

30 31 32
import ForeignCall
import ErrUtils
import Id
33
#if alpha_TARGET_ARCH
34 35
import Type
import SMRep
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 FastString
sof's avatar
sof committed
45 46
\end{code}

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

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

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

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

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


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

111 112 113 114 115 116
tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ _ (CLabel _)) 
  = ASSERT( null arg_tys )
    do { checkCg checkCOrAsm
       ; check (isFFILabelTy res_ty) (illegalForeignTyErr empty sig_ty)
       ; return idecl }	     -- NB check res_ty not sig_ty!
       	 	      	     --    In case sig_ty is (forall a. ForeignPtr a)
117

118 119
tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper) = do
   	-- Foreign wrapper (former f.e.d.)
chak's avatar
chak committed
120 121 122 123
   	-- 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.
124 125 126 127 128 129 130 131 132
    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
133
        _ -> addErrTc (illegalForeignTyErr empty sig_ty)
sof's avatar
sof committed
134
    return idecl
135

136
tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction target))
137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157
  | 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
158
      checkMissingAmpersand dflags arg_tys res_ty
159
      return idecl
160 161 162

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

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

178 179
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
180 181 182
foreign export dynamic (i.e., 32 bytes of arguments after padding each
argument to a quadword, excluding floating-point arguments).

183 184 185 186
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
187 188

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


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

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

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

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

226
   tcCheckFEType sig_ty spec
sof's avatar
sof committed
227

chak's avatar
chak committed
228 229
	  -- 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
230 231
	  -- to create a local binding which will call the exported function
	  -- at a particular type (and, maybe, overloading).
232

233 234 235 236 237

   -- 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
Simon Marlow's avatar
Simon Marlow committed
238
   return (L loc (VarBind id rhs), ForeignExport (L loc id) undefined spec)
Ian Lynagh's avatar
Ian Lynagh committed
239
tcFExport d = pprPanic "tcFExport" (ppr d)
240 241 242
\end{code}

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

244
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
245
tcCheckFEType :: Type -> ForeignExport -> TcM ()
246
tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do
247
    check (isCLabelString str) (badCName str)
248
    checkCConv cconv
249
    checkForeignArgs isFFIExternalTy arg_tys
250 251 252 253
    checkForeignRes nonIOok isFFIExportResultTy res_ty
  where
      -- Drop the foralls before inspecting n
      -- the structure of the foreign type.
254 255
    (_, t_ty) = tcSplitForAllTys sig_ty
    (arg_tys, res_ty) = tcSplitFunTys t_ty
Ian Lynagh's avatar
Ian Lynagh committed
256
tcCheckFEType _ d = pprPanic "tcCheckFEType" (ppr d)
sof's avatar
sof committed
257 258 259
\end{code}


260 261 262 263 264 265 266

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

sof's avatar
sof committed
267
\begin{code}
268
------------ Checking argument types for foreign import ----------------------
269
checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM ()
270
checkForeignArgs pred tys
271
  = mapM_ go tys
272
  where
273
    go ty = check (pred ty) (illegalForeignTyErr argument ty)
274 275

------------ Checking result types for foreign calls ----------------------
sof's avatar
sof committed
276
-- Check that the type has the form 
277
--    (IO t) or (t) , and that t satisfies the given predicate.
sof's avatar
sof committed
278
--
279
checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
280

Ian Lynagh's avatar
Ian Lynagh committed
281
nonIOok, mustBeIO :: Bool
282 283 284
nonIOok  = True
mustBeIO = False

285
checkForeignRes non_io_result_ok pred_res_ty ty
286
	-- (IO t) is ok, and so is any newtype wrapping thereof
Ian Lynagh's avatar
Ian Lynagh committed
287
  | Just (_, res_ty, _) <- tcSplitIOType_maybe ty,
288
    pred_res_ty res_ty
289
  = return ()
290 291 292 293
 
  | otherwise
  = check (non_io_result_ok && pred_res_ty ty) 
	  (illegalForeignTyErr result ty)
sof's avatar
sof committed
294 295
\end{code}

296
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
297
checkDotnet :: HscTarget -> Maybe SDoc
sof's avatar
sof committed
298 299 300 301
#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
302
checkDotnet _      = Just (text "requires .NET support (-filx or win32)")
sof's avatar
sof committed
303
#endif
304

Ian Lynagh's avatar
Ian Lynagh committed
305
checkCOrAsm :: HscTarget -> Maybe SDoc
306 307
checkCOrAsm HscC   = Nothing
checkCOrAsm HscAsm = Nothing
Ian Lynagh's avatar
Ian Lynagh committed
308
checkCOrAsm _
309 310
   = Just (text "requires via-C or native code generation (-fvia-C)")

Ian Lynagh's avatar
Ian Lynagh committed
311
checkCOrAsmOrInterp :: HscTarget -> Maybe SDoc
312 313 314
checkCOrAsmOrInterp HscC           = Nothing
checkCOrAsmOrInterp HscAsm         = Nothing
checkCOrAsmOrInterp HscInterpreted = Nothing
Ian Lynagh's avatar
Ian Lynagh committed
315
checkCOrAsmOrInterp _
316
   = Just (text "requires interpreted, C or native code generation")
317

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

Ian Lynagh's avatar
Ian Lynagh committed
325
checkCg :: (HscTarget -> Maybe SDoc) -> TcM ()
326 327 328
checkCg check = do
   dflags <- getDOpts
   let target = hscTarget dflags
329
   case target of
330
     HscNothing -> return ()
Ian Lynagh's avatar
Ian Lynagh committed
331
     _ ->
332
       case check target of
333
	 Nothing  -> return ()
chak's avatar
chak committed
334
	 Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
SamB's avatar
SamB committed
335
\end{code}
336
			   
337 338 339 340 341 342 343 344
Calling conventions

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

sof's avatar
sof committed
350 351 352
Warnings

\begin{code}
353
check :: Bool -> Message -> TcM ()
354
check True _	   = return ()
355
check _    the_err = addErrTc the_err
356

Ian Lynagh's avatar
Ian Lynagh committed
357
illegalForeignTyErr :: SDoc -> Type -> SDoc
358
illegalForeignTyErr arg_or_res ty
Ian Lynagh's avatar
Ian Lynagh committed
359 360
  = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res, 
                ptext (sLit "type in foreign declaration:")])
361
	 4 (hsep [ppr ty])
sof's avatar
sof committed
362

363
-- Used for 'arg_or_res' argument to illegalForeignTyErr
Ian Lynagh's avatar
Ian Lynagh committed
364
argument, result :: SDoc
365 366 367 368
argument = text "argument"
result   = text "result"

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

Ian Lynagh's avatar
Ian Lynagh committed
372
foreignDeclCtxt :: ForeignDecl Name -> SDoc
373
foreignDeclCtxt fo
Ian Lynagh's avatar
Ian Lynagh committed
374
  = hang (ptext (sLit "When checking declaration:"))
375
         4 (ppr fo)
sof's avatar
sof committed
376

Ian Lynagh's avatar
Ian Lynagh committed
377 378
illegalDNMethodSig :: SDoc
illegalDNMethodSig
Ian Lynagh's avatar
Ian Lynagh committed
379
  = ptext (sLit "'This pointer' expected as last argument")
sof's avatar
sof committed
380

sof's avatar
sof committed
381
\end{code}
382