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
import Name
import TcType
import DynFlags
sof's avatar
sof committed
40
import Outputable
41 42
import SrcLoc
import Bag
sof's avatar
sof committed
43 44
\end{code}

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

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

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

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

68
tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
Simon Marlow's avatar
Simon Marlow committed
69
tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
70
 = addErrCtxt (foreignDeclCtxt fo)	$
71
   tcHsSigType (ForSigCtxt nm) hs_ty	`thenM`	\ sig_ty ->
72 73 74
   let 
      -- drop the foralls before inspecting the structure
      -- of the foreign type.
75 76
	(_, t_ty)	  = tcSplitForAllTys sig_ty
	(arg_tys, res_ty) = tcSplitFunTys t_ty
77 78 79 80
	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).
81
   in
sof's avatar
sof committed
82
   tcCheckFIType sig_ty arg_tys res_ty imp_decl		`thenM` \ imp_decl' -> 
83 84
   -- can't use sig_ty here because it :: Type and we need HsType Id
   -- hence the undefined
Simon Marlow's avatar
Simon Marlow committed
85
   returnM (id, ForeignImport (L loc id) undefined imp_decl')
86 87 88 89 90
\end{code}


------------ Checking types for foreign import ----------------------
\begin{code}
sof's avatar
sof committed
91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107
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 _))
108
  = checkCg checkCOrAsm		`thenM_`
sof's avatar
sof committed
109 110
    check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty) `thenM_`
    return idecl
111

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

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

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

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

166 167 168 169
The check is needed for both via-C and native-code routes

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


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

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

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

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

207
   tcCheckFEType sig_ty spec		`thenM_`
sof's avatar
sof committed
208

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

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

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

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


239 240 241 242 243 244 245

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

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

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

nonIOok  = True
mustBeIO = False

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

275
\begin{code}
sof's avatar
sof committed
276 277 278 279 280 281
#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
282 283 284

checkCOrAsm HscC   = Nothing
checkCOrAsm HscAsm = Nothing
285 286 287 288 289 290 291 292
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")
293

294 295 296 297
checkCOrAsmOrDotNetOrInterp HscC           = Nothing
checkCOrAsmOrDotNetOrInterp HscAsm         = Nothing
checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
checkCOrAsmOrDotNetOrInterp other  
298
   = Just (text "requires interpreted, C or native code generation")
299

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

\begin{code}
326 327
check :: Bool -> Message -> TcM ()
check True _	   = returnM ()
328
check _    the_err = addErrTc the_err
329

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

335 336 337 338 339
-- Used for 'arg_or_res' argument to illegalForeignTyErr
argument = text "argument"
result   = text "result"

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

foreignDeclCtxt fo
  = hang (ptext SLIT("When checking declaration:"))
345
         4 (ppr fo)
sof's avatar
sof committed
346 347 348 349

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

sof's avatar
sof committed
350
\end{code}
351