TcForeign.lhs 12.3 KB
Newer Older
sof's avatar
sof committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21
%
% (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"

22
import HsSyn
sof's avatar
sof committed
23

24
import TcRnMonad
25
import TcHsType		( tcHsSigType, UserTypeCtxt(..) )
26
import TcExpr		( tcPolyExpr )			
sof's avatar
sof committed
27

28
import ForeignCall	( CCallConv(..) )
sof's avatar
sof committed
29
import ErrUtils		( Message )
30
import Id		( Id, mkLocalId, mkExportedLocalId )
31 32
#if alpha_TARGET_ARCH
import Type		( typePrimRep )
33
import SMRep		( argMachRep, primRepToCgRep, primRepHint )
34
#endif
35
import OccName		( mkForeignExportOcc )
36
import Name		( Name, NamedThing(..), mkExternalName )
chak's avatar
chak committed
37 38
import TcType		( Type, tcSplitFunTys, tcSplitTyConApp_maybe,
			  tcSplitForAllTys, 
39 40
			  isFFIArgumentTy, isFFIImportResultTy, 
			  isFFIExportResultTy, isFFILabelTy,
chak's avatar
chak committed
41
			  isFFIExternalTy, isFFIDynArgumentTy,
sof's avatar
sof committed
42 43
			  isFFIDynResultTy, isFFIDotnetTy, isFFIDotnetObjTy,
			  toDNType
44
			)
45
import ForeignCall	( CExportSpec(..), CCallTarget(..), 
46
			  CLabelString, isCLabelString,
47
			  isDynamicTarget, withDNTypes, DNKind(..), DNCallSpec(..) ) 
48
import PrelNames	( hasKey, ioTyConKey )
49
import DynFlags		( DynFlags(..), HscTarget(..) )
sof's avatar
sof committed
50
import Outputable
51
import SrcLoc		( Located(..), srcSpanStart )
52
import Bag		( consBag )
sof's avatar
sof committed
53

54
#if alpha_TARGET_ARCH
55
import MachOp		( machRepByteWidth, MachHint(FloatHint) )
56
#endif
sof's avatar
sof committed
57 58
\end{code}

59 60
\begin{code}
-- Defines a binding
61 62 63
isForeignImport :: LForeignDecl name -> Bool
isForeignImport (L _ (ForeignImport _ _ _ _)) = True
isForeignImport _			      = False
64 65

-- Exports a binding
66 67 68
isForeignExport :: LForeignDecl name -> Bool
isForeignExport (L _ (ForeignExport _ _ _ _)) = True
isForeignExport _	  	              = False
69 70 71 72 73 74 75 76
\end{code}

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

sof's avatar
sof committed
77
\begin{code}
78
tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id])
79
tcForeignImports decls
80
  = mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls)
sof's avatar
sof committed
81

82 83 84
tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl isDeprec)
 = addErrCtxt (foreignDeclCtxt fo)	$
85
   tcHsSigType (ForSigCtxt nm) hs_ty	`thenM`	\ sig_ty ->
86 87 88
   let 
      -- drop the foralls before inspecting the structure
      -- of the foreign type.
89 90
	(_, t_ty)	  = tcSplitForAllTys sig_ty
	(arg_tys, res_ty) = tcSplitFunTys t_ty
91 92 93 94
	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).
95
   in
sof's avatar
sof committed
96
   tcCheckFIType sig_ty arg_tys res_ty imp_decl		`thenM` \ imp_decl' -> 
97 98
   -- can't use sig_ty here because it :: Type and we need HsType Id
   -- hence the undefined
99
   returnM (id, ForeignImport (L loc id) undefined imp_decl' isDeprec)
100 101 102 103 104
\end{code}


------------ Checking types for foreign import ----------------------
\begin{code}
sof's avatar
sof committed
105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121
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 _))
122
  = checkCg checkCOrAsm		`thenM_`
sof's avatar
sof committed
123 124
    check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty) `thenM_`
    return idecl
125

sof's avatar
sof committed
126
tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper)
chak's avatar
chak committed
127 128 129 130 131
  = 	-- 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
132
    checkCg checkCOrAsmOrInterp `thenM_`
133
    checkCConv cconv 		`thenM_`
sof's avatar
sof committed
134 135 136 137
    (case arg_tys of
	[arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys		     `thenM_`
		     checkForeignRes nonIOok  isFFIExportResultTy res1_ty    `thenM_`
		     checkForeignRes mustBeIO isFFIDynResultTy	  res_ty     `thenM_`
138
		     checkFEDArgs arg1_tys
139
		  where
140
		     (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
sof's avatar
sof committed
141 142
        other -> addErrTc (illegalForeignTyErr empty sig_ty)	)            `thenM_`
    return idecl
143

144
tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction target))
145
  | isDynamicTarget target	-- Foreign import dynamic
146
  = checkCg checkCOrAsmOrInterp		`thenM_`
147
    checkCConv cconv 			`thenM_`
chak's avatar
chak committed
148
    case arg_tys of		-- The first arg must be Ptr, FunPtr, or Addr
sof's avatar
sof committed
149 150 151 152 153 154 155 156 157 158
      []     		-> 
      	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
159
  | otherwise 		-- Normal foreign import
160
  = checkCg (checkCOrAsmOrDotNetOrInterp)			`thenM_`
161
    checkCConv cconv 						`thenM_`
162 163 164
    checkCTarget target						`thenM_`
    getDOpts							`thenM` \ dflags ->
    checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys	`thenM_`
sof's avatar
sof committed
165 166
    checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty `thenM_`
    return idecl
167 168 169

-- This makes a convenient place to check
-- that the C identifier is valid for C
170
checkCTarget (StaticTarget str) 
171
  = checkCg checkCOrAsmOrDotNetOrInterp	 	`thenM_`
172
    check (isCLabelString str) (badCName str)
173
\end{code}
174

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

180 181 182 183
The check is needed for both via-C and native-code routes

\begin{code}
#include "nativeGen/NCG.h"
184
#if alpha_TARGET_ARCH
ken's avatar
ken committed
185
checkFEDArgs arg_tys
186
  = check (integral_args <= 32) err
ken's avatar
ken committed
187
  where
188 189 190 191
    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")
192
#else
193
checkFEDArgs arg_tys = returnM ()
194 195
#endif
\end{code}
196 197 198 199 200 201 202 203 204


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

\begin{code}
205 206
tcForeignExports :: [LForeignDecl Name] 
    		 -> TcM (LHsBinds TcId, [LForeignDecl TcId])
207
tcForeignExports decls
208
  = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
sof's avatar
sof committed
209
  where
210
   combine (binds, fs) fe = 
211 212
       wrapLocSndM tcFExport fe	`thenM` \ (b, f) ->
       returnM (b `consBag` binds, f:fs)
sof's avatar
sof committed
213

214 215
tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
tcFExport fo@(ForeignExport (L loc nm) hs_ty spec isDeprec) =
216
   addErrCtxt (foreignDeclCtxt fo)	$
sof's avatar
sof committed
217

218
   tcHsSigType (ForSigCtxt nm) hs_ty	`thenM` \ sig_ty ->
219
   tcPolyExpr (nlHsVar nm) sig_ty	`thenM` \ rhs ->
220

221
   tcCheckFEType sig_ty spec		`thenM_`
sof's avatar
sof committed
222

chak's avatar
chak committed
223 224
	  -- 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
225 226
	  -- to create a local binding which will call the exported function
	  -- at a particular type (and, maybe, overloading).
227

228 229
   newUnique			`thenM` \ uniq ->
   getModule			`thenM` \ mod ->
230
   let
231
        gnm  = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm)) 
232
			      Nothing (srcSpanStart loc)
233
	id   = mkExportedLocalId gnm sig_ty
234
	bind = L loc (VarBind id rhs)
235
   in
236
   returnM (bind, ForeignExport (L loc id) undefined spec isDeprec)
237 238 239
\end{code}

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

241 242
\begin{code}
tcCheckFEType sig_ty (CExport (CExportStatic str _))
243 244
  = check (isCLabelString str) (badCName str)		`thenM_`
    checkForeignArgs isFFIExternalTy arg_tys  	        `thenM_`
245 246 247 248
    checkForeignRes nonIOok isFFIExportResultTy res_ty
  where
      -- Drop the foralls before inspecting n
      -- the structure of the foreign type.
249 250
    (_, t_ty) = tcSplitForAllTys sig_ty
    (arg_tys, res_ty) = tcSplitFunTys t_ty
sof's avatar
sof committed
251 252 253
\end{code}


254 255 256 257 258 259 260

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

sof's avatar
sof committed
261
\begin{code}
262
------------ Checking argument types for foreign import ----------------------
263
checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM ()
264
checkForeignArgs pred tys
265 266
  = mappM go tys		`thenM_` 
    returnM ()
267
  where
268
    go ty = check (pred ty) (illegalForeignTyErr argument ty)
269 270

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

nonIOok  = True
mustBeIO = False

279 280 281
checkForeignRes non_io_result_ok pred_res_ty ty
 = case tcSplitTyConApp_maybe ty of
      Just (io, [res_ty]) 
282
        | io `hasKey` ioTyConKey && pred_res_ty res_ty 
283
	-> returnM ()
284
      _   
285
        -> check (non_io_result_ok && pred_res_ty ty) 
286
		 (illegalForeignTyErr result ty)
sof's avatar
sof committed
287 288
\end{code}

289
\begin{code}
sof's avatar
sof committed
290 291 292 293 294 295 296
checkDotnet HscILX = Nothing
#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
297 298 299

checkCOrAsm HscC   = Nothing
checkCOrAsm HscAsm = Nothing
300 301 302 303 304 305 306 307
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")
308

309 310 311 312 313 314 315
checkCOrAsmOrDotNetOrInterp HscC           = Nothing
checkCOrAsmOrDotNetOrInterp HscAsm         = Nothing
checkCOrAsmOrDotNetOrInterp HscILX         = Nothing
checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
checkCOrAsmOrDotNetOrInterp other  
   = Just (text "requires interpreted, C, native or .NET ILX code generation")

316
checkCg check
317
 = getDOpts		`thenM` \ dflags ->
318 319
   let target = hscTarget dflags in
   case target of
320
     HscNothing -> returnM ()
chak's avatar
chak committed
321
     otherwise  ->
322
       case check target of
323
	 Nothing  -> returnM ()
chak's avatar
chak committed
324
	 Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
325 326
\end{code} 
			   
327 328 329 330 331 332 333 334 335 336 337 338
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
339 340 341
Warnings

\begin{code}
342 343
check :: Bool -> Message -> TcM ()
check True _	   = returnM ()
344
check _    the_err = addErrTc the_err
345

346
illegalForeignTyErr arg_or_res ty
347 348
  = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, 
                ptext SLIT("type in foreign declaration:")])
349
	 4 (hsep [ppr ty])
sof's avatar
sof committed
350

351 352 353 354 355
-- Used for 'arg_or_res' argument to illegalForeignTyErr
argument = text "argument"
result   = text "result"

badCName :: CLabelString -> Message
356 357
badCName target 
   = sep [quotes (ppr target) <+> ptext SLIT("is not a valid C identifier")]
358 359 360

foreignDeclCtxt fo
  = hang (ptext SLIT("When checking declaration:"))
361
         4 (ppr fo)
sof's avatar
sof committed
362 363 364 365

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

sof's avatar
sof committed
366
\end{code}
367