TcForeign.lhs 11.3 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 21 22
% (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

#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 38 39 40 41
import OccName
import Name
import TcType
import ForeignCall
import DynFlags
sof's avatar
sof committed
42
import Outputable
43 44
import SrcLoc
import Bag
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)
72
 = addErrCtxt (foreignDeclCtxt fo)	$
73
   tcHsSigType (ForSigCtxt nm) hs_ty	`thenM`	\ sig_ty ->
74 75 76
   let 
      -- drop the foralls before inspecting the structure
      -- of the foreign type.
77 78
	(_, t_ty)	  = tcSplitForAllTys sig_ty
	(arg_tys, res_ty) = tcSplitFunTys t_ty
79 80 81 82
	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).
83
   in
sof's avatar
sof committed
84
   tcCheckFIType sig_ty arg_tys res_ty imp_decl		`thenM` \ imp_decl' -> 
85 86
   -- can't use sig_ty here because it :: Type and we need HsType Id
   -- hence the undefined
Simon Marlow's avatar
Simon Marlow committed
87
   returnM (id, ForeignImport (L loc id) undefined imp_decl')
88 89 90 91 92
\end{code}


------------ Checking types for foreign import ----------------------
\begin{code}
sof's avatar
sof committed
93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109
tcCheckFIType _ arg_tys res_ty (DNImport spec)
  = checkCg checkDotnet  `thenM_`
    getDOpts		 `thenM`  \ dflags ->
    checkForeignArgs (isFFIDotnetTy dflags) arg_tys	`thenM_`
    checkForeignRes True{-non IO ok-} (isFFIDotnetTy dflags) res_ty `thenM_`
    let (DNCallSpec isStatic kind _ _ _ _) = spec in
    (case kind of
       DNMethod | not isStatic ->
         case arg_tys of
	   [] -> addErrTc illegalDNMethodSig
	   _  
	    | not (isFFIDotnetObjTy (last arg_tys)) -> addErrTc illegalDNMethodSig
	    | otherwise -> returnM ()
       _ -> returnM ()) `thenM_`
    returnM (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty)))

tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ _ (CLabel _))
110
  = checkCg checkCOrAsm		`thenM_`
sof's avatar
sof committed
111 112
    check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty) `thenM_`
    return idecl
113

sof's avatar
sof committed
114
tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper)
chak's avatar
chak committed
115 116 117 118 119
  = 	-- Foreign wrapper (former f.e.d.)
   	-- 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.
sof's avatar
sof committed
120
    checkCg checkCOrAsmOrInterp `thenM_`
121
    checkCConv cconv 		`thenM_`
sof's avatar
sof committed
122 123 124 125
    (case arg_tys of
	[arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys		     `thenM_`
		     checkForeignRes nonIOok  isFFIExportResultTy res1_ty    `thenM_`
		     checkForeignRes mustBeIO isFFIDynResultTy	  res_ty     `thenM_`
126
		     checkFEDArgs arg1_tys
127
		  where
128
		     (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
sof's avatar
sof committed
129 130
        other -> addErrTc (illegalForeignTyErr empty sig_ty)	)            `thenM_`
    return idecl
131

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

-- This makes a convenient place to check
-- that the C identifier is valid for C
158
checkCTarget (StaticTarget str) 
159
  = checkCg checkCOrAsmOrDotNetOrInterp	 	`thenM_`
160
    check (isCLabelString str) (badCName str)
161
\end{code}
162

163 164
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
165 166 167
foreign export dynamic (i.e., 32 bytes of arguments after padding each
argument to a quadword, excluding floating-point arguments).

168 169 170 171
The check is needed for both via-C and native-code routes

\begin{code}
#include "nativeGen/NCG.h"
172
#if alpha_TARGET_ARCH
ken's avatar
ken committed
173
checkFEDArgs arg_tys
174
  = check (integral_args <= 32) err
ken's avatar
ken committed
175
  where
176 177 178 179
    integral_args = sum [ (machRepByteWidth . 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")
180
#else
181
checkFEDArgs arg_tys = returnM ()
182 183
#endif
\end{code}
184 185 186 187 188 189 190 191 192


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

\begin{code}
193 194
tcForeignExports :: [LForeignDecl Name] 
    		 -> TcM (LHsBinds TcId, [LForeignDecl TcId])
195
tcForeignExports decls
196
  = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
sof's avatar
sof committed
197
  where
198
   combine (binds, fs) fe = 
199 200
       wrapLocSndM tcFExport fe	`thenM` \ (b, f) ->
       returnM (b `consBag` binds, f:fs)
sof's avatar
sof committed
201

202
tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
Simon Marlow's avatar
Simon Marlow committed
203
tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
204
   addErrCtxt (foreignDeclCtxt fo)	$
sof's avatar
sof committed
205

206
   tcHsSigType (ForSigCtxt nm) hs_ty	`thenM` \ sig_ty ->
207
   tcPolyExpr (nlHsVar nm) sig_ty	`thenM` \ rhs ->
208

209
   tcCheckFEType sig_ty spec		`thenM_`
sof's avatar
sof committed
210

chak's avatar
chak committed
211 212
	  -- 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
213 214
	  -- to create a local binding which will call the exported function
	  -- at a particular type (and, maybe, overloading).
215

216 217
   newUnique			`thenM` \ uniq ->
   getModule			`thenM` \ mod ->
218
   let
219
        gnm  = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm)) 
220
			      (srcSpanStart loc)
221
	id   = mkExportedLocalId gnm sig_ty
222
	bind = L loc (VarBind id rhs)
223
   in
Simon Marlow's avatar
Simon Marlow committed
224
   returnM (bind, ForeignExport (L loc id) undefined spec)
225 226 227
\end{code}

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

229 230
\begin{code}
tcCheckFEType sig_ty (CExport (CExportStatic str _))
231 232
  = check (isCLabelString str) (badCName str)		`thenM_`
    checkForeignArgs isFFIExternalTy arg_tys  	        `thenM_`
233 234 235 236
    checkForeignRes nonIOok isFFIExportResultTy res_ty
  where
      -- Drop the foralls before inspecting n
      -- the structure of the foreign type.
237 238
    (_, t_ty) = tcSplitForAllTys sig_ty
    (arg_tys, res_ty) = tcSplitFunTys t_ty
sof's avatar
sof committed
239 240 241
\end{code}


242 243 244 245 246 247 248

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

sof's avatar
sof committed
249
\begin{code}
250
------------ Checking argument types for foreign import ----------------------
251
checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM ()
252
checkForeignArgs pred tys
253 254
  = mappM go tys		`thenM_` 
    returnM ()
255
  where
256
    go ty = check (pred ty) (illegalForeignTyErr argument ty)
257 258

------------ Checking result types for foreign calls ----------------------
sof's avatar
sof committed
259
-- Check that the type has the form 
260
--    (IO t) or (t) , and that t satisfies the given predicate.
sof's avatar
sof committed
261
--
262
checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
263 264 265 266

nonIOok  = True
mustBeIO = False

267
checkForeignRes non_io_result_ok pred_res_ty ty
268 269 270 271 272 273 274 275
	-- (IO t) is ok, and so is any newtype wrapping thereof
  | Just (io, res_ty) <- tcSplitIOType_maybe ty,
    pred_res_ty res_ty
  = returnM ()
 
  | otherwise
  = check (non_io_result_ok && pred_res_ty ty) 
	  (illegalForeignTyErr result ty)
sof's avatar
sof committed
276 277
\end{code}

278
\begin{code}
sof's avatar
sof committed
279 280 281 282 283 284
#if defined(mingw32_TARGET_OS)
checkDotnet HscC   = Nothing
checkDotnet _      = Just (text "requires C code generation (-fvia-C)")
#else
checkDotnet other  = Just (text "requires .NET support (-filx or win32)")
#endif
285 286 287

checkCOrAsm HscC   = Nothing
checkCOrAsm HscAsm = Nothing
288 289 290 291 292 293 294 295
checkCOrAsm other  
   = Just (text "requires via-C or native code generation (-fvia-C)")

checkCOrAsmOrInterp HscC           = Nothing
checkCOrAsmOrInterp HscAsm         = Nothing
checkCOrAsmOrInterp HscInterpreted = Nothing
checkCOrAsmOrInterp other  
   = Just (text "requires interpreted, C or native code generation")
296

297 298 299 300
checkCOrAsmOrDotNetOrInterp HscC           = Nothing
checkCOrAsmOrDotNetOrInterp HscAsm         = Nothing
checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
checkCOrAsmOrDotNetOrInterp other  
301
   = Just (text "requires interpreted, C or native code generation")
302

303
checkCg check
304
 = getDOpts		`thenM` \ dflags ->
305 306
   let target = hscTarget dflags in
   case target of
307
     HscNothing -> returnM ()
chak's avatar
chak committed
308
     otherwise  ->
309
       case check target of
310
	 Nothing  -> returnM ()
chak's avatar
chak committed
311
	 Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
312 313
\end{code} 
			   
314 315 316 317 318 319 320 321 322 323 324 325
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
\end{code}

sof's avatar
sof committed
326 327 328
Warnings

\begin{code}
329 330
check :: Bool -> Message -> TcM ()
check True _	   = returnM ()
331
check _    the_err = addErrTc the_err
332

333
illegalForeignTyErr arg_or_res ty
334 335
  = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, 
                ptext SLIT("type in foreign declaration:")])
336
	 4 (hsep [ppr ty])
sof's avatar
sof committed
337

338 339 340 341 342
-- Used for 'arg_or_res' argument to illegalForeignTyErr
argument = text "argument"
result   = text "result"

badCName :: CLabelString -> Message
343 344
badCName target 
   = sep [quotes (ppr target) <+> ptext SLIT("is not a valid C identifier")]
345 346 347

foreignDeclCtxt fo
  = hang (ptext SLIT("When checking declaration:"))
348
         4 (ppr fo)
sof's avatar
sof committed
349 350 351 352

illegalDNMethodSig 
  = ptext SLIT("'This pointer' expected as last argument")

sof's avatar
sof committed
353
\end{code}
354