TcForeign.lhs 12.1 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 )
37
import TcType		( Type, tcSplitFunTys, 
38
			  tcSplitForAllTys, tcSplitIOType_maybe,
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 DynFlags		( DynFlags(..), HscTarget(..) )
sof's avatar
sof committed
49
import Outputable
50
import SrcLoc		( Located(..), srcSpanStart )
51
import Bag		( consBag )
sof's avatar
sof committed
52

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

58 59
\begin{code}
-- Defines a binding
60
isForeignImport :: LForeignDecl name -> Bool
Simon Marlow's avatar
Simon Marlow committed
61
isForeignImport (L _ (ForeignImport _ _ _)) = True
62
isForeignImport _			      = False
63 64

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

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

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

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


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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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


253 254 255 256 257 258 259

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

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

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

nonIOok  = True
mustBeIO = False

278
checkForeignRes non_io_result_ok pred_res_ty ty
279 280 281 282 283 284 285 286
	-- (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
287 288
\end{code}

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

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

308 309 310 311
checkCOrAsmOrDotNetOrInterp HscC           = Nothing
checkCOrAsmOrDotNetOrInterp HscAsm         = Nothing
checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
checkCOrAsmOrDotNetOrInterp other  
312
   = Just (text "requires interpreted, C or native code generation")
313

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

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

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

349 350 351 352 353
-- Used for 'arg_or_res' argument to illegalForeignTyErr
argument = text "argument"
result   = text "result"

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

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

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

sof's avatar
sof committed
364
\end{code}
365