TcForeign.lhs 12 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
module TcForeign 
	( 
	  tcForeignImports
        , tcForeignExports
	) where

28
import HsSyn
sof's avatar
sof committed
29

30
import TcRnMonad
31 32
import TcHsType
import TcExpr
sof's avatar
sof committed
33

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

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

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

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

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

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


------------ Checking types for foreign import ----------------------
\begin{code}
99 100 101 102 103 104 105
tcCheckFIType _ arg_tys res_ty (DNImport spec) = do
    checkCg checkDotnet
    dflags <- getDOpts
    checkForeignArgs (isFFIDotnetTy dflags) arg_tys
    checkForeignRes True{-non IO ok-} (isFFIDotnetTy dflags) res_ty
    let (DNCallSpec isStatic kind _ _ _ _) = spec
    case kind of
sof's avatar
sof committed
106 107 108 109 110
       DNMethod | not isStatic ->
         case arg_tys of
	   [] -> addErrTc illegalDNMethodSig
	   _  
	    | not (isFFIDotnetObjTy (last arg_tys)) -> addErrTc illegalDNMethodSig
111 112 113
	    | otherwise -> return ()
       _ -> return ()
    return (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty)))
sof's avatar
sof committed
114

115 116 117
tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ _ (CLabel _)) = do
    checkCg checkCOrAsm
    check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty)
sof's avatar
sof committed
118
    return idecl
119

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

138
tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction target))
139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160
  | isDynamicTarget target = do -- Foreign import dynamic
      checkCg checkCOrAsmOrInterp
      checkCConv cconv
      case arg_tys of           -- The first arg must be Ptr, FunPtr, or Addr
        []                -> do
          check False (illegalForeignTyErr empty sig_ty)
          return idecl
        (arg1_ty:arg_tys) -> do
          dflags <- getDOpts
          check (isFFIDynArgumentTy arg1_ty)
                (illegalForeignTyErr argument arg1_ty)
          checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
          checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
          return idecl
  | otherwise = do              -- Normal foreign import
      checkCg (checkCOrAsmOrDotNetOrInterp)
      checkCConv cconv
      checkCTarget target
      dflags <- getDOpts
      checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
      checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
      return idecl
161 162 163

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

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

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

\begin{code}
#include "nativeGen/NCG.h"
178
#if alpha_TARGET_ARCH
ken's avatar
ken committed
179
checkFEDArgs arg_tys
180
  = check (integral_args <= 32) err
ken's avatar
ken committed
181
  where
182 183 184
    integral_args = sum [ (machRepByteWidth . argMachRep . primRepToCgRep) prim_rep
			| prim_rep <- map typePrimRep arg_tys,
			  primRepHint prim_rep /= FloatHint ]
Ian Lynagh's avatar
Ian Lynagh committed
185
    err = ptext (sLit "On Alpha, I can only handle 32 bytes of non-floating-point arguments to foreign export dynamic")
186
#else
187
checkFEDArgs arg_tys = return ()
188 189
#endif
\end{code}
190 191 192 193 194 195 196 197 198


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

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

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

212 213
   sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
   rhs <- tcPolyExpr (nlHsVar nm) sig_ty
214

215
   tcCheckFEType sig_ty spec
sof's avatar
sof committed
216

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

222 223
   uniq <- newUnique
   mod <- getModule
224
   let
225 226 227 228 229 230 231 232 233 234 235
          -- 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
236
	id   = mkExportedLocalId gnm sig_ty
237
	bind = L loc (VarBind id rhs)
238 239

   return (bind, ForeignExport (L loc id) undefined spec)
240 241 242
\end{code}

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

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


257 258 259 260 261 262 263

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

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

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

nonIOok  = True
mustBeIO = False

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

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

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

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

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

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

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

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

badCName :: CLabelString -> Message
357
badCName target 
Ian Lynagh's avatar
Ian Lynagh committed
358
   = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
359 360

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

illegalDNMethodSig 
Ian Lynagh's avatar
Ian Lynagh committed
365
  = ptext (sLit "'This pointer' expected as last argument")
sof's avatar
sof committed
366

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