Deprecate the threadsafe kind of foreign import
[ghc.git] / compiler / typecheck / TcForeign.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The AQUA Project, Glasgow University, 1998
4 %
5 \section[TcForeign]{Typechecking \tr{foreign} declarations}
6
7 A foreign declaration is used to either give an externally
8 implemented function a Haskell type (and calling interface) or
9 give a Haskell function an external calling interface. Either way,
10 the range of argument and result types these functions can accommodate
11 is restricted to what the outside world understands (read C), and this
12 module checks to see if a foreign declaration has got a legal type.
13
14 \begin{code}
15 module TcForeign 
16         ( 
17           tcForeignImports
18         , tcForeignExports
19         ) where
20
21 #include "HsVersions.h"
22
23 import HsSyn
24
25 import TcRnMonad
26 import TcHsType
27 import TcExpr
28 import TcEnv
29
30 import ForeignCall
31 import ErrUtils
32 import Id
33 #if alpha_TARGET_ARCH
34 import Type
35 import SMRep
36 #endif
37 import Name
38 import OccName
39 import TcType
40 import DynFlags
41 import Outputable
42 import SrcLoc
43 import Bag
44 import FastString
45 \end{code}
46
47 \begin{code}
48 -- Defines a binding
49 isForeignImport :: LForeignDecl name -> Bool
50 isForeignImport (L _ (ForeignImport _ _ _)) = True
51 isForeignImport _                             = False
52
53 -- Exports a binding
54 isForeignExport :: LForeignDecl name -> Bool
55 isForeignExport (L _ (ForeignExport _ _ _)) = True
56 isForeignExport _                             = False
57 \end{code}
58
59 %************************************************************************
60 %*                                                                      *
61 \subsection{Imports}
62 %*                                                                      *
63 %************************************************************************
64
65 \begin{code}
66 tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id])
67 tcForeignImports decls
68   = mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls)
69
70 tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
71 tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
72  = addErrCtxt (foreignDeclCtxt fo)  $ 
73    do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
74       ; let 
75           -- Drop the foralls before inspecting the
76           -- structure of the foreign type.
77             (_, t_ty)         = tcSplitForAllTys sig_ty
78             (arg_tys, res_ty) = tcSplitFunTys t_ty
79             id                = mkLocalId nm sig_ty
80                 -- Use a LocalId to obey the invariant that locally-defined 
81                 -- things are LocalIds.  However, it does not need zonking,
82                 -- (so TcHsSyn.zonkForeignExports ignores it).
83    
84       ; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
85          -- Can't use sig_ty here because sig_ty :: Type and 
86          -- we need HsType Id hence the undefined
87       ; return (id, ForeignImport (L loc id) undefined imp_decl') }
88 tcFImport d = pprPanic "tcFImport" (ppr d)
89 \end{code}
90
91
92 ------------ Checking types for foreign import ----------------------
93 \begin{code}
94 tcCheckFIType :: Type -> [Type] -> Type -> ForeignImport -> TcM ForeignImport
95 tcCheckFIType _ arg_tys res_ty (DNImport spec) = do
96     checkCg checkDotnet
97     dflags <- getDOpts
98     checkForeignArgs (isFFIDotnetTy dflags) arg_tys
99     checkForeignRes nonIOok (isFFIDotnetTy dflags) res_ty
100     let (DNCallSpec isStatic kind _ _ _ _) = spec
101     case kind of
102        DNMethod | not isStatic ->
103          case arg_tys of
104            [] -> addErrTc illegalDNMethodSig
105            _  
106             | not (isFFIDotnetObjTy (last arg_tys)) -> addErrTc illegalDNMethodSig
107             | otherwise -> return ()
108        _ -> return ()
109     return (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty)))
110
111 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ _ (CLabel _))
112   = ASSERT( null arg_tys )
113     do { checkCg checkCOrAsm
114        ; checkSafety safety
115        ; check (isFFILabelTy res_ty) (illegalForeignTyErr empty sig_ty)
116        ; return idecl }      -- NB check res_ty not sig_ty!
117                              --    In case sig_ty is (forall a. ForeignPtr a)
118
119 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ CWrapper) = do
120         -- Foreign wrapper (former f.e.d.)
121         -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
122         -- valid foreign type.  For legacy reasons ft -> IO (Ptr ft) as well
123         -- as ft -> IO Addr is accepted, too.  The use of the latter two forms
124         -- is DEPRECATED, though.
125     checkCg checkCOrAsmOrInterp
126     checkCConv cconv
127     checkSafety safety
128     case arg_tys of
129         [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys
130                         checkForeignRes nonIOok  isFFIExportResultTy res1_ty
131                         checkForeignRes mustBeIO isFFIDynResultTy    res_ty
132                         checkFEDArgs arg1_tys
133                   where
134                      (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
135         _ -> addErrTc (illegalForeignTyErr empty sig_ty)
136     return idecl
137
138 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction target))
139   | isDynamicTarget target = do -- Foreign import dynamic
140       checkCg checkCOrAsmOrInterp
141       checkCConv cconv
142       checkSafety safety
143       case arg_tys of           -- The first arg must be Ptr, FunPtr, or Addr
144         []                -> do
145           check False (illegalForeignTyErr empty sig_ty)
146           return idecl
147         (arg1_ty:arg_tys) -> do
148           dflags <- getDOpts
149           check (isFFIDynArgumentTy arg1_ty)
150                 (illegalForeignTyErr argument arg1_ty)
151           checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
152           checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
153           return idecl
154   | otherwise = do              -- Normal foreign import
155       checkCg (checkCOrAsmOrDotNetOrInterp)
156       checkCConv cconv
157       checkSafety safety
158       checkCTarget target
159       dflags <- getDOpts
160       checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
161       checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
162       checkMissingAmpersand dflags arg_tys res_ty
163       return idecl
164
165 -- This makes a convenient place to check
166 -- that the C identifier is valid for C
167 checkCTarget :: CCallTarget -> TcM ()
168 checkCTarget (StaticTarget str) = do
169     checkCg checkCOrAsmOrDotNetOrInterp
170     check (isCLabelString str) (badCName str)
171 checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget"
172
173 checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM ()
174 checkMissingAmpersand dflags arg_tys res_ty
175   | null arg_tys && isFunPtrTy res_ty &&
176     dopt Opt_WarnDodgyForeignImports dflags
177   = addWarn (ptext (sLit "possible missing & in foreign import of FunPtr"))
178   | otherwise
179   = return ()
180 \end{code}
181
182 On an Alpha, with foreign export dynamic, due to a giant hack when
183 building adjustor thunks, we only allow 4 integer arguments with
184 foreign export dynamic (i.e., 32 bytes of arguments after padding each
185 argument to a quadword, excluding floating-point arguments).
186
187 The check is needed for both via-C and native-code routes
188
189 \begin{code}
190 #include "nativeGen/NCG.h"
191
192 checkFEDArgs :: [Type] -> TcM ()
193 #if alpha_TARGET_ARCH
194 checkFEDArgs arg_tys
195   = check (integral_args <= 32) err
196   where
197     integral_args = sum [ (widthInBytes . argMachRep . primRepToCgRep) prim_rep
198                         | prim_rep <- map typePrimRep arg_tys,
199                           primRepHint prim_rep /= FloatHint ]
200     err = ptext (sLit "On Alpha, I can only handle 32 bytes of non-floating-point arguments to foreign export dynamic")
201 #else
202 checkFEDArgs _ = return ()
203 #endif
204 \end{code}
205
206
207 %************************************************************************
208 %*                                                                      *
209 \subsection{Exports}
210 %*                                                                      *
211 %************************************************************************
212
213 \begin{code}
214 tcForeignExports :: [LForeignDecl Name] 
215                  -> TcM (LHsBinds TcId, [LForeignDecl TcId])
216 tcForeignExports decls
217   = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
218   where
219    combine (binds, fs) fe = do
220        (b, f) <- wrapLocSndM tcFExport fe
221        return (b `consBag` binds, f:fs)
222
223 tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
224 tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
225    addErrCtxt (foreignDeclCtxt fo)      $ do
226
227    sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
228    rhs <- tcPolyExpr (nlHsVar nm) sig_ty
229
230    tcCheckFEType sig_ty spec
231
232           -- we're exporting a function, but at a type possibly more
233           -- constrained than its declared/inferred type. Hence the need
234           -- to create a local binding which will call the exported function
235           -- at a particular type (and, maybe, overloading).
236
237
238    -- We need to give a name to the new top-level binding that
239    -- is *stable* (i.e. the compiler won't change it later),
240    -- because this name will be referred to by the C code stub.
241    id  <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
242    return (L loc (VarBind id rhs), ForeignExport (L loc id) undefined spec)
243 tcFExport d = pprPanic "tcFExport" (ppr d)
244 \end{code}
245
246 ------------ Checking argument types for foreign export ----------------------
247
248 \begin{code}
249 tcCheckFEType :: Type -> ForeignExport -> TcM ()
250 tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do
251     check (isCLabelString str) (badCName str)
252     checkCConv cconv
253     checkForeignArgs isFFIExternalTy arg_tys
254     checkForeignRes nonIOok isFFIExportResultTy res_ty
255   where
256       -- Drop the foralls before inspecting n
257       -- the structure of the foreign type.
258     (_, t_ty) = tcSplitForAllTys sig_ty
259     (arg_tys, res_ty) = tcSplitFunTys t_ty
260 tcCheckFEType _ d = pprPanic "tcCheckFEType" (ppr d)
261 \end{code}
262
263
264
265 %************************************************************************
266 %*                                                                      *
267 \subsection{Miscellaneous}
268 %*                                                                      *
269 %************************************************************************
270
271 \begin{code}
272 ------------ Checking argument types for foreign import ----------------------
273 checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM ()
274 checkForeignArgs pred tys
275   = mapM_ go tys
276   where
277     go ty = check (pred ty) (illegalForeignTyErr argument ty)
278
279 ------------ Checking result types for foreign calls ----------------------
280 -- Check that the type has the form 
281 --    (IO t) or (t) , and that t satisfies the given predicate.
282 --
283 checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
284
285 nonIOok, mustBeIO :: Bool
286 nonIOok  = True
287 mustBeIO = False
288
289 checkForeignRes non_io_result_ok pred_res_ty ty
290         -- (IO t) is ok, and so is any newtype wrapping thereof
291   | Just (_, res_ty, _) <- tcSplitIOType_maybe ty,
292     pred_res_ty res_ty
293   = return ()
294  
295   | otherwise
296   = check (non_io_result_ok && pred_res_ty ty) 
297           (illegalForeignTyErr result ty)
298 \end{code}
299
300 \begin{code}
301 checkDotnet :: HscTarget -> Maybe SDoc
302 #if defined(mingw32_TARGET_OS)
303 checkDotnet HscC   = Nothing
304 checkDotnet _      = Just (text "requires C code generation (-fvia-C)")
305 #else
306 checkDotnet _      = Just (text "requires .NET support (-filx or win32)")
307 #endif
308
309 checkCOrAsm :: HscTarget -> Maybe SDoc
310 checkCOrAsm HscC   = Nothing
311 checkCOrAsm HscAsm = Nothing
312 checkCOrAsm _
313    = Just (text "requires via-C or native code generation (-fvia-C)")
314
315 checkCOrAsmOrInterp :: HscTarget -> Maybe SDoc
316 checkCOrAsmOrInterp HscC           = Nothing
317 checkCOrAsmOrInterp HscAsm         = Nothing
318 checkCOrAsmOrInterp HscInterpreted = Nothing
319 checkCOrAsmOrInterp _
320    = Just (text "requires interpreted, C or native code generation")
321
322 checkCOrAsmOrDotNetOrInterp :: HscTarget -> Maybe SDoc
323 checkCOrAsmOrDotNetOrInterp HscC           = Nothing
324 checkCOrAsmOrDotNetOrInterp HscAsm         = Nothing
325 checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
326 checkCOrAsmOrDotNetOrInterp _
327    = Just (text "requires interpreted, C or native code generation")
328
329 checkCg :: (HscTarget -> Maybe SDoc) -> TcM ()
330 checkCg check = do
331    dflags <- getDOpts
332    let target = hscTarget dflags
333    case target of
334      HscNothing -> return ()
335      _ ->
336        case check target of
337          Nothing  -> return ()
338          Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
339 \end{code}
340                            
341 Calling conventions
342
343 \begin{code}
344 checkCConv :: CCallConv -> TcM ()
345 checkCConv CCallConv  = return ()
346 #if i386_TARGET_ARCH
347 checkCConv StdCallConv = return ()
348 #else
349 checkCConv StdCallConv = addErrTc (text "calling convention not supported on this platform: stdcall")
350 #endif
351 checkCConv CmmCallConv = panic "checkCConv CmmCallConv"
352 \end{code}
353
354 Deprecated "threadsafe" calls
355
356 \begin{code}
357 checkSafety :: Safety -> TcM ()
358 checkSafety (PlaySafe True) = addWarn (text "The `threadsafe' foreign import style is deprecated. Use `safe' instead.")
359 checkSafety _               = return ()
360 \end{code}
361
362 Warnings
363
364 \begin{code}
365 check :: Bool -> Message -> TcM ()
366 check True _       = return ()
367 check _    the_err = addErrTc the_err
368
369 illegalForeignTyErr :: SDoc -> Type -> SDoc
370 illegalForeignTyErr arg_or_res ty
371   = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res, 
372                 ptext (sLit "type in foreign declaration:")])
373          4 (hsep [ppr ty])
374
375 -- Used for 'arg_or_res' argument to illegalForeignTyErr
376 argument, result :: SDoc
377 argument = text "argument"
378 result   = text "result"
379
380 badCName :: CLabelString -> Message
381 badCName target 
382    = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
383
384 foreignDeclCtxt :: ForeignDecl Name -> SDoc
385 foreignDeclCtxt fo
386   = hang (ptext (sLit "When checking declaration:"))
387          4 (ppr fo)
388
389 illegalDNMethodSig :: SDoc
390 illegalDNMethodSig
391   = ptext (sLit "'This pointer' expected as last argument")
392
393 \end{code}
394