TcForeign.lhs 12.2 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
% (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}
15
{-# OPTIONS -w #-}
16 17 18
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
Ian Lynagh's avatar
Ian Lynagh committed
19
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
20 21
-- for details

sof's avatar
sof committed
22 23 24 25 26 27 28 29
module TcForeign 
	( 
	  tcForeignImports
        , tcForeignExports
	) where

#include "HsVersions.h"

30
import HsSyn
sof's avatar
sof committed
31

32
import TcRnMonad
33 34
import TcHsType
import TcExpr
sof's avatar
sof committed
35

36 37 38
import ForeignCall
import ErrUtils
import Id
39
#if alpha_TARGET_ARCH
40 41 42
import Type
import SMRep
import MachOp
43
#endif
44
import Name
45
import OccName
46 47
import TcType
import DynFlags
sof's avatar
sof committed
48
import Outputable
49 50
import SrcLoc
import Bag
51
import Unique
sof's avatar
sof committed
52 53
\end{code}

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

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

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

sof's avatar
sof committed
72
\begin{code}
73
tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id])
74
tcForeignImports decls
75
  = mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls)
sof's avatar
sof committed
76

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


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

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

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

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

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

175 176 177 178
The check is needed for both via-C and native-code routes

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


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

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

209
tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
Simon Marlow's avatar
Simon Marlow committed
210
tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
211
   addErrCtxt (foreignDeclCtxt fo)	$
sof's avatar
sof committed
212

213
   tcHsSigType (ForSigCtxt nm) hs_ty	`thenM` \ sig_ty ->
214
   tcPolyExpr (nlHsVar nm) sig_ty	`thenM` \ rhs ->
215

216
   tcCheckFEType sig_ty spec		`thenM_`
sof's avatar
sof committed
217

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

223 224
   newUnique			`thenM` \ uniq ->
   getModule			`thenM` \ mod ->
225
   let
226 227 228 229 230 231 232 233 234 235 236
          -- 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.
          -- Furthermore, the name must be unique (see #1533).  If the
          -- same function is foreign-exported multiple times, the
          -- top-level bindings generated must not have the same name.
          -- Hence we create an External name (doesn't change), and we
          -- append a Unique to the string right here.
        uniq_str = showSDoc (pprUnique uniq)
        occ = mkVarOcc (occNameString (getOccName nm) ++ '_' : uniq_str)
        gnm  = mkExternalName uniq mod (mkForeignExportOcc occ) loc
237
	id   = mkExportedLocalId gnm sig_ty
238
	bind = L loc (VarBind id rhs)
239
   in
Simon Marlow's avatar
Simon Marlow committed
240
   returnM (bind, ForeignExport (L loc id) undefined spec)
241 242 243
\end{code}

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

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


258 259 260 261 262 263 264

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

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

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

nonIOok  = True
mustBeIO = False

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

294
\begin{code}
sof's avatar
sof committed
295 296 297 298 299 300
#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
301 302 303

checkCOrAsm HscC   = Nothing
checkCOrAsm HscAsm = Nothing
304 305 306 307 308 309 310 311
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")
312

313 314 315 316
checkCOrAsmOrDotNetOrInterp HscC           = Nothing
checkCOrAsmOrDotNetOrInterp HscAsm         = Nothing
checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
checkCOrAsmOrDotNetOrInterp other  
317
   = Just (text "requires interpreted, C or native code generation")
318

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

\begin{code}
345 346
check :: Bool -> Message -> TcM ()
check True _	   = returnM ()
347
check _    the_err = addErrTc the_err
348

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

354 355 356 357 358
-- Used for 'arg_or_res' argument to illegalForeignTyErr
argument = text "argument"
result   = text "result"

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

foreignDeclCtxt fo
  = hang (ptext SLIT("When checking declaration:"))
364
         4 (ppr fo)
sof's avatar
sof committed
365 366 367 368

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

sof's avatar
sof committed
369
\end{code}
370