aa40d02cd2b1524a5e0179ed768e5df78e284338
[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 _ _ _ _ (CLabel _)) 
112   = ASSERT( null arg_tys )
113     do { checkCg checkCOrAsm
114        ; check (isFFILabelTy res_ty) (illegalForeignTyErr empty sig_ty)
115        ; return idecl }      -- NB check res_ty not sig_ty!
116                              --    In case sig_ty is (forall a. ForeignPtr a)
117
118 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper) = do
119         -- Foreign wrapper (former f.e.d.)
120         -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
121         -- valid foreign type.  For legacy reasons ft -> IO (Ptr ft) as well
122         -- as ft -> IO Addr is accepted, too.  The use of the latter two forms
123         -- is DEPRECATED, though.
124     checkCg checkCOrAsmOrInterp
125     checkCConv cconv
126     case arg_tys of
127         [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys
128                         checkForeignRes nonIOok  isFFIExportResultTy res1_ty
129                         checkForeignRes mustBeIO isFFIDynResultTy    res_ty
130                         checkFEDArgs arg1_tys
131                   where
132                      (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
133         _ -> addErrTc (illegalForeignTyErr empty sig_ty)
134     return idecl
135
136 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction target))
137   | isDynamicTarget target = do -- Foreign import dynamic
138       checkCg checkCOrAsmOrInterp
139       checkCConv cconv
140       case arg_tys of           -- The first arg must be Ptr, FunPtr, or Addr
141         []                -> do
142           check False (illegalForeignTyErr empty sig_ty)
143           return idecl
144         (arg1_ty:arg_tys) -> do
145           dflags <- getDOpts
146           check (isFFIDynArgumentTy arg1_ty)
147                 (illegalForeignTyErr argument arg1_ty)
148           checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
149           checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
150           return idecl
151   | otherwise = do              -- Normal foreign import
152       checkCg (checkCOrAsmOrDotNetOrInterp)
153       checkCConv cconv
154       checkCTarget target
155       dflags <- getDOpts
156       checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
157       checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
158       checkMissingAmpersand dflags arg_tys res_ty
159       return idecl
160
161 -- This makes a convenient place to check
162 -- that the C identifier is valid for C
163 checkCTarget :: CCallTarget -> TcM ()
164 checkCTarget (StaticTarget str) = do
165     checkCg checkCOrAsmOrDotNetOrInterp
166     check (isCLabelString str) (badCName str)
167 checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget"
168
169 checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM ()
170 checkMissingAmpersand dflags arg_tys res_ty
171   | null arg_tys && isFunPtrTy res_ty &&
172     dopt Opt_WarnDodgyForeignImports dflags
173   = addWarn (ptext (sLit "possible missing & in foreign import of FunPtr"))
174   | otherwise
175   = return ()
176 \end{code}
177
178 On an Alpha, with foreign export dynamic, due to a giant hack when
179 building adjustor thunks, we only allow 4 integer arguments with
180 foreign export dynamic (i.e., 32 bytes of arguments after padding each
181 argument to a quadword, excluding floating-point arguments).
182
183 The check is needed for both via-C and native-code routes
184
185 \begin{code}
186 #include "nativeGen/NCG.h"
187
188 checkFEDArgs :: [Type] -> TcM ()
189 #if alpha_TARGET_ARCH
190 checkFEDArgs arg_tys
191   = check (integral_args <= 32) err
192   where
193     integral_args = sum [ (widthInBytes . argMachRep . primRepToCgRep) prim_rep
194                         | prim_rep <- map typePrimRep arg_tys,
195                           primRepHint prim_rep /= FloatHint ]
196     err = ptext (sLit "On Alpha, I can only handle 32 bytes of non-floating-point arguments to foreign export dynamic")
197 #else
198 checkFEDArgs _ = return ()
199 #endif
200 \end{code}
201
202
203 %************************************************************************
204 %*                                                                      *
205 \subsection{Exports}
206 %*                                                                      *
207 %************************************************************************
208
209 \begin{code}
210 tcForeignExports :: [LForeignDecl Name] 
211                  -> TcM (LHsBinds TcId, [LForeignDecl TcId])
212 tcForeignExports decls
213   = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
214   where
215    combine (binds, fs) fe = do
216        (b, f) <- wrapLocSndM tcFExport fe
217        return (b `consBag` binds, f:fs)
218
219 tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
220 tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
221    addErrCtxt (foreignDeclCtxt fo)      $ do
222
223    sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
224    rhs <- tcPolyExpr (nlHsVar nm) sig_ty
225
226    tcCheckFEType sig_ty spec
227
228           -- we're exporting a function, but at a type possibly more
229           -- constrained than its declared/inferred type. Hence the need
230           -- to create a local binding which will call the exported function
231           -- at a particular type (and, maybe, overloading).
232
233
234    -- We need to give a name to the new top-level binding that
235    -- is *stable* (i.e. the compiler won't change it later),
236    -- because this name will be referred to by the C code stub.
237    id  <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
238    return (L loc (VarBind id rhs), ForeignExport (L loc id) undefined spec)
239 tcFExport d = pprPanic "tcFExport" (ppr d)
240 \end{code}
241
242 ------------ Checking argument types for foreign export ----------------------
243
244 \begin{code}
245 tcCheckFEType :: Type -> ForeignExport -> TcM ()
246 tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do
247     check (isCLabelString str) (badCName str)
248     checkCConv cconv
249     checkForeignArgs isFFIExternalTy arg_tys
250     checkForeignRes nonIOok isFFIExportResultTy res_ty
251   where
252       -- Drop the foralls before inspecting n
253       -- the structure of the foreign type.
254     (_, t_ty) = tcSplitForAllTys sig_ty
255     (arg_tys, res_ty) = tcSplitFunTys t_ty
256 tcCheckFEType _ d = pprPanic "tcCheckFEType" (ppr d)
257 \end{code}
258
259
260
261 %************************************************************************
262 %*                                                                      *
263 \subsection{Miscellaneous}
264 %*                                                                      *
265 %************************************************************************
266
267 \begin{code}
268 ------------ Checking argument types for foreign import ----------------------
269 checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM ()
270 checkForeignArgs pred tys
271   = mapM_ go tys
272   where
273     go ty = check (pred ty) (illegalForeignTyErr argument ty)
274
275 ------------ Checking result types for foreign calls ----------------------
276 -- Check that the type has the form 
277 --    (IO t) or (t) , and that t satisfies the given predicate.
278 --
279 checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
280
281 nonIOok, mustBeIO :: Bool
282 nonIOok  = True
283 mustBeIO = False
284
285 checkForeignRes non_io_result_ok pred_res_ty ty
286         -- (IO t) is ok, and so is any newtype wrapping thereof
287   | Just (_, res_ty, _) <- tcSplitIOType_maybe ty,
288     pred_res_ty res_ty
289   = return ()
290  
291   | otherwise
292   = check (non_io_result_ok && pred_res_ty ty) 
293           (illegalForeignTyErr result ty)
294 \end{code}
295
296 \begin{code}
297 checkDotnet :: HscTarget -> Maybe SDoc
298 #if defined(mingw32_TARGET_OS)
299 checkDotnet HscC   = Nothing
300 checkDotnet _      = Just (text "requires C code generation (-fvia-C)")
301 #else
302 checkDotnet _      = Just (text "requires .NET support (-filx or win32)")
303 #endif
304
305 checkCOrAsm :: HscTarget -> Maybe SDoc
306 checkCOrAsm HscC   = Nothing
307 checkCOrAsm HscAsm = Nothing
308 checkCOrAsm _
309    = Just (text "requires via-C or native code generation (-fvia-C)")
310
311 checkCOrAsmOrInterp :: HscTarget -> Maybe SDoc
312 checkCOrAsmOrInterp HscC           = Nothing
313 checkCOrAsmOrInterp HscAsm         = Nothing
314 checkCOrAsmOrInterp HscInterpreted = Nothing
315 checkCOrAsmOrInterp _
316    = Just (text "requires interpreted, C or native code generation")
317
318 checkCOrAsmOrDotNetOrInterp :: HscTarget -> Maybe SDoc
319 checkCOrAsmOrDotNetOrInterp HscC           = Nothing
320 checkCOrAsmOrDotNetOrInterp HscAsm         = Nothing
321 checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
322 checkCOrAsmOrDotNetOrInterp _
323    = Just (text "requires interpreted, C or native code generation")
324
325 checkCg :: (HscTarget -> Maybe SDoc) -> TcM ()
326 checkCg check = do
327    dflags <- getDOpts
328    let target = hscTarget dflags
329    case target of
330      HscNothing -> return ()
331      _ ->
332        case check target of
333          Nothing  -> return ()
334          Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
335 \end{code}
336                            
337 Calling conventions
338
339 \begin{code}
340 checkCConv :: CCallConv -> TcM ()
341 checkCConv CCallConv  = return ()
342 #if i386_TARGET_ARCH
343 checkCConv StdCallConv = return ()
344 #else
345 checkCConv StdCallConv = addErrTc (text "calling convention not supported on this platform: stdcall")
346 #endif
347 checkCConv CmmCallConv = panic "checkCConv CmmCallConv"
348 \end{code}
349
350 Warnings
351
352 \begin{code}
353 check :: Bool -> Message -> TcM ()
354 check True _       = return ()
355 check _    the_err = addErrTc the_err
356
357 illegalForeignTyErr :: SDoc -> Type -> SDoc
358 illegalForeignTyErr arg_or_res ty
359   = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res, 
360                 ptext (sLit "type in foreign declaration:")])
361          4 (hsep [ppr ty])
362
363 -- Used for 'arg_or_res' argument to illegalForeignTyErr
364 argument, result :: SDoc
365 argument = text "argument"
366 result   = text "result"
367
368 badCName :: CLabelString -> Message
369 badCName target 
370    = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
371
372 foreignDeclCtxt :: ForeignDecl Name -> SDoc
373 foreignDeclCtxt fo
374   = hang (ptext (sLit "When checking declaration:"))
375          4 (ppr fo)
376
377 illegalDNMethodSig :: SDoc
378 illegalDNMethodSig
379   = ptext (sLit "'This pointer' expected as last argument")
380
381 \end{code}
382