57ef40a3ad9a23ba03ba8977441dceccaac80b30
[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 {-# OPTIONS -w #-}
16 -- The above warning supression flag is a temporary kludge.
17 -- While working on this module you are encouraged to remove it and fix
18 -- any warnings in the module. See
19 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
20 -- for details
21
22 module TcForeign 
23         ( 
24           tcForeignImports
25         , tcForeignExports
26         ) where
27
28 import HsSyn
29
30 import TcRnMonad
31 import TcHsType
32 import TcExpr
33
34 import ForeignCall
35 import ErrUtils
36 import Id
37 #if alpha_TARGET_ARCH
38 import Type
39 import SMRep
40 import MachOp
41 #endif
42 import Name
43 import OccName
44 import TcType
45 import DynFlags
46 import Outputable
47 import SrcLoc
48 import Bag
49 import Unique
50 import FastString
51 \end{code}
52
53 \begin{code}
54 -- Defines a binding
55 isForeignImport :: LForeignDecl name -> Bool
56 isForeignImport (L _ (ForeignImport _ _ _)) = True
57 isForeignImport _                             = False
58
59 -- Exports a binding
60 isForeignExport :: LForeignDecl name -> Bool
61 isForeignExport (L _ (ForeignExport _ _ _)) = True
62 isForeignExport _                             = False
63 \end{code}
64
65 %************************************************************************
66 %*                                                                      *
67 \subsection{Imports}
68 %*                                                                      *
69 %************************************************************************
70
71 \begin{code}
72 tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id])
73 tcForeignImports decls
74   = mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls)
75
76 tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
77 tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
78  = addErrCtxt (foreignDeclCtxt fo)  $ do
79    sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
80    let 
81       -- drop the foralls before inspecting the structure
82       -- of the foreign type.
83         (_, t_ty)         = tcSplitForAllTys sig_ty
84         (arg_tys, res_ty) = tcSplitFunTys t_ty
85         id                = mkLocalId nm sig_ty
86                 -- Use a LocalId to obey the invariant that locally-defined 
87                 -- things are LocalIds.  However, it does not need zonking,
88                 -- (so TcHsSyn.zonkForeignExports ignores it).
89    
90    imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
91    -- can't use sig_ty here because it :: Type and we need HsType Id
92    -- hence the undefined
93    return (id, ForeignImport (L loc id) undefined imp_decl')
94 \end{code}
95
96
97 ------------ Checking types for foreign import ----------------------
98 \begin{code}
99 tcCheckFIType _ arg_tys res_ty (DNImport spec) = do
100     checkCg checkDotnet
101     dflags <- getDOpts
102     checkForeignArgs (isFFIDotnetTy dflags) arg_tys
103     checkForeignRes True{-non IO ok-} (isFFIDotnetTy dflags) res_ty
104     let (DNCallSpec isStatic kind _ _ _ _) = spec
105     case kind of
106        DNMethod | not isStatic ->
107          case arg_tys of
108            [] -> addErrTc illegalDNMethodSig
109            _  
110             | not (isFFIDotnetObjTy (last arg_tys)) -> addErrTc illegalDNMethodSig
111             | otherwise -> return ()
112        _ -> return ()
113     return (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty)))
114
115 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ _ (CLabel _)) = do
116     checkCg checkCOrAsm
117     check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty)
118     return idecl
119
120 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper) = do
121         -- Foreign wrapper (former f.e.d.)
122         -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
123         -- valid foreign type.  For legacy reasons ft -> IO (Ptr ft) as well
124         -- as ft -> IO Addr is accepted, too.  The use of the latter two forms
125         -- is DEPRECATED, though.
126     checkCg checkCOrAsmOrInterp
127     checkCConv cconv
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         other -> 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       case arg_tys of           -- The first arg must be Ptr, FunPtr, or Addr
143         []                -> do
144           check False (illegalForeignTyErr empty sig_ty)
145           return idecl
146         (arg1_ty:arg_tys) -> do
147           dflags <- getDOpts
148           check (isFFIDynArgumentTy arg1_ty)
149                 (illegalForeignTyErr argument arg1_ty)
150           checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
151           checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
152           return idecl
153   | otherwise = do              -- Normal foreign import
154       checkCg (checkCOrAsmOrDotNetOrInterp)
155       checkCConv cconv
156       checkCTarget target
157       dflags <- getDOpts
158       checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
159       checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
160       return idecl
161
162 -- This makes a convenient place to check
163 -- that the C identifier is valid for C
164 checkCTarget (StaticTarget str) = do
165     checkCg checkCOrAsmOrDotNetOrInterp
166     check (isCLabelString str) (badCName str)
167 \end{code}
168
169 On an Alpha, with foreign export dynamic, due to a giant hack when
170 building adjustor thunks, we only allow 4 integer arguments with
171 foreign export dynamic (i.e., 32 bytes of arguments after padding each
172 argument to a quadword, excluding floating-point arguments).
173
174 The check is needed for both via-C and native-code routes
175
176 \begin{code}
177 #include "nativeGen/NCG.h"
178 #if alpha_TARGET_ARCH
179 checkFEDArgs arg_tys
180   = check (integral_args <= 32) err
181   where
182     integral_args = sum [ (machRepByteWidth . argMachRep . primRepToCgRep) prim_rep
183                         | prim_rep <- map typePrimRep arg_tys,
184                           primRepHint prim_rep /= FloatHint ]
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 #endif
189 \end{code}
190
191
192 %************************************************************************
193 %*                                                                      *
194 \subsection{Exports}
195 %*                                                                      *
196 %************************************************************************
197
198 \begin{code}
199 tcForeignExports :: [LForeignDecl Name] 
200                  -> TcM (LHsBinds TcId, [LForeignDecl TcId])
201 tcForeignExports decls
202   = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
203   where
204    combine (binds, fs) fe = do
205        (b, f) <- wrapLocSndM tcFExport fe
206        return (b `consBag` binds, f:fs)
207
208 tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
209 tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
210    addErrCtxt (foreignDeclCtxt fo)      $ do
211
212    sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
213    rhs <- tcPolyExpr (nlHsVar nm) sig_ty
214
215    tcCheckFEType sig_ty spec
216
217           -- we're exporting a function, but at a type possibly more
218           -- constrained than its declared/inferred type. Hence the need
219           -- to create a local binding which will call the exported function
220           -- at a particular type (and, maybe, overloading).
221
222    uniq <- newUnique
223    mod <- getModule
224    let
225           -- We need to give a name to the new top-level binding that
226           -- is *stable* (i.e. the compiler won't change it later),
227           -- because this name will be referred to by the C code stub.
228           -- Furthermore, the name must be unique (see #1533).  If the
229           -- same function is foreign-exported multiple times, the
230           -- top-level bindings generated must not have the same name.
231           -- Hence we create an External name (doesn't change), and we
232           -- append a Unique to the string right here.
233         uniq_str = showSDoc (pprUnique uniq)
234         occ = mkVarOcc (occNameString (getOccName nm) ++ '_' : uniq_str)
235         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 \end{code}
241
242 ------------ Checking argument types for foreign export ----------------------
243
244 \begin{code}
245 tcCheckFEType sig_ty (CExport (CExportStatic str _)) = do
246     check (isCLabelString str) (badCName str)
247     checkForeignArgs isFFIExternalTy arg_tys
248     checkForeignRes nonIOok isFFIExportResultTy res_ty
249   where
250       -- Drop the foralls before inspecting n
251       -- the structure of the foreign type.
252     (_, t_ty) = tcSplitForAllTys sig_ty
253     (arg_tys, res_ty) = tcSplitFunTys t_ty
254 \end{code}
255
256
257
258 %************************************************************************
259 %*                                                                      *
260 \subsection{Miscellaneous}
261 %*                                                                      *
262 %************************************************************************
263
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 ----------------------
273 -- Check that the type has the form 
274 --    (IO t) or (t) , and that t satisfies the given predicate.
275 --
276 checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
277
278 nonIOok  = True
279 mustBeIO = False
280
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   | otherwise
288   = check (non_io_result_ok && pred_res_ty ty) 
289           (illegalForeignTyErr result ty)
290 \end{code}
291
292 \begin{code}
293 #if defined(mingw32_TARGET_OS)
294 checkDotnet HscC   = Nothing
295 checkDotnet _      = Just (text "requires C code generation (-fvia-C)")
296 #else
297 checkDotnet other  = Just (text "requires .NET support (-filx or win32)")
298 #endif
299
300 checkCOrAsm HscC   = Nothing
301 checkCOrAsm HscAsm = Nothing
302 checkCOrAsm other  
303    = Just (text "requires via-C or native code generation (-fvia-C)")
304
305 checkCOrAsmOrInterp HscC           = Nothing
306 checkCOrAsmOrInterp HscAsm         = Nothing
307 checkCOrAsmOrInterp HscInterpreted = Nothing
308 checkCOrAsmOrInterp other  
309    = Just (text "requires interpreted, C or native code generation")
310
311 checkCOrAsmOrDotNetOrInterp HscC           = Nothing
312 checkCOrAsmOrDotNetOrInterp HscAsm         = Nothing
313 checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
314 checkCOrAsmOrDotNetOrInterp other  
315    = Just (text "requires interpreted, C or native code generation")
316
317 checkCg check = do
318    dflags <- getDOpts
319    let target = hscTarget dflags
320    case target of
321      HscNothing -> return ()
322      otherwise  ->
323        case check target of
324          Nothing  -> return ()
325          Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
326 \end{code}
327                            
328 Calling conventions
329
330 \begin{code}
331 checkCConv :: CCallConv -> TcM ()
332 checkCConv CCallConv  = return ()
333 #if i386_TARGET_ARCH
334 checkCConv StdCallConv = return ()
335 #else
336 checkCConv StdCallConv = addErrTc (text "calling convention not supported on this architecture: stdcall")
337 #endif
338 \end{code}
339
340 Warnings
341
342 \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
348   = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res, 
349                 ptext (sLit "type in foreign declaration:")])
350          4 (hsep [ppr ty])
351
352 -- Used for 'arg_or_res' argument to illegalForeignTyErr
353 argument = text "argument"
354 result   = text "result"
355
356 badCName :: CLabelString -> Message
357 badCName target 
358    = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
359
360 foreignDeclCtxt fo
361   = hang (ptext (sLit "When checking declaration:"))
362          4 (ppr fo)
363
364 illegalDNMethodSig 
365   = ptext (sLit "'This pointer' expected as last argument")
366
367 \end{code}
368