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
  29 import ForeignCall
  30 import ErrUtils
  31 import Id
  32 #if alpha_TARGET_ARCH
  33 import Type
  34 import SMRep
  35 import MachOp
  36 #endif
  37 import OccName
  38 import Name
  39 import TcType
  40 import ForeignCall
  41 import DynFlags
  42 import Outputable
  43 import SrcLoc
  44 import Bag
  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    tcHsSigType (ForSigCtxt nm) hs_ty    `thenM` \ sig_ty ->
  74    let
  75       -- drop the foralls before inspecting the structure
  76       -- 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    in
  84    tcCheckFIType sig_ty arg_tys res_ty imp_decl         `thenM` \ imp_decl' ->
  85    -- can't use sig_ty here because it :: Type and we need HsType Id
  86    -- hence the undefined
  87    returnM (id, ForeignImport (L loc id) undefined imp_decl')
  88 \end{code}
  89
  90
  91 ------------ Checking types for foreign import ----------------------
  92 \begin{code}
  93 tcCheckFIType _ arg_tys res_ty (DNImport spec)
  94   = checkCg checkDotnet  `thenM_`
  95     getDOpts             `thenM`  \ dflags ->
  96     checkForeignArgs (isFFIDotnetTy dflags) arg_tys     `thenM_`
  97     checkForeignRes True{-non IO ok-} (isFFIDotnetTy dflags) res_ty `thenM_`
  98     let (DNCallSpec isStatic kind _ _ _ _) = spec in
  99     (case kind of
 100        DNMethod | not isStatic ->
 101          case arg_tys of
 102            [] -> addErrTc illegalDNMethodSig
 103            _
 104             | not (isFFIDotnetObjTy (last arg_tys)) -> addErrTc illegalDNMethodSig
 105             | otherwise -> returnM ()
 106        _ -> returnM ()) `thenM_`
 107     returnM (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty)))
 108
 109 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ _ (CLabel _))
 110   = checkCg checkCOrAsm         `thenM_`
 111     check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty) `thenM_`
 112     return idecl
 113
 114 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper)
 115   =     -- Foreign wrapper (former f.e.d.)
 116         -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
 117         -- valid foreign type.  For legacy reasons ft -> IO (Ptr ft) as well
 118         -- as ft -> IO Addr is accepted, too.  The use of the latter two forms
 119         -- is DEPRECATED, though.
 120     checkCg checkCOrAsmOrInterp `thenM_`
 121     checkCConv cconv            `thenM_`
 122     (case arg_tys of
 123         [arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys               `thenM_`
 124                      checkForeignRes nonIOok  isFFIExportResultTy res1_ty    `thenM_`
 125                      checkForeignRes mustBeIO isFFIDynResultTy    res_ty     `thenM_`
 126                      checkFEDArgs arg1_tys
 127                   where
 128                      (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
 129         other -> addErrTc (illegalForeignTyErr empty sig_ty)    )            `thenM_`
 130     return idecl
 131
 132 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction target))
 133   | isDynamicTarget target      -- Foreign import dynamic
 134   = checkCg checkCOrAsmOrInterp         `thenM_`
 135     checkCConv cconv                    `thenM_`
 136     case arg_tys of             -- The first arg must be Ptr, FunPtr, or Addr
 137       []                ->
 138         check False (illegalForeignTyErr empty sig_ty) `thenM_`
 139         return idecl
 140       (arg1_ty:arg_tys) ->
 141         getDOpts                                                     `thenM` \ dflags ->
 142         check (isFFIDynArgumentTy arg1_ty)
 143               (illegalForeignTyErr argument arg1_ty)                 `thenM_`
 144         checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys     `thenM_`
 145         checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty  `thenM_`
 146         return idecl
 147   | otherwise           -- Normal foreign import
 148   = checkCg (checkCOrAsmOrDotNetOrInterp)                       `thenM_`
 149     checkCConv cconv                                            `thenM_`
 150     checkCTarget target                                         `thenM_`
 151     getDOpts                                                    `thenM` \ dflags ->
 152     checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys    `thenM_`
 153     checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty `thenM_`
 154     return idecl
 155
 156 -- This makes a convenient place to check
 157 -- that the C identifier is valid for C
 158 checkCTarget (StaticTarget str)
 159   = checkCg checkCOrAsmOrDotNetOrInterp         `thenM_`
 160     check (isCLabelString str) (badCName str)
 161 \end{code}
 162
 163 On an Alpha, with foreign export dynamic, due to a giant hack when
 164 building adjustor thunks, we only allow 4 integer arguments with
 165 foreign export dynamic (i.e., 32 bytes of arguments after padding each
 166 argument to a quadword, excluding floating-point arguments).
 167
 168 The check is needed for both via-C and native-code routes
 169
 170 \begin{code}
 171 #include "nativeGen/NCG.h"
 172 #if alpha_TARGET_ARCH
 173 checkFEDArgs arg_tys
 174   = check (integral_args <= 32) err
 175   where
 176     integral_args = sum [ (machRepByteWidth . argMachRep . primRepToCgRep) prim_rep
 177                         | prim_rep <- map typePrimRep arg_tys,
 178                           primRepHint prim_rep /= FloatHint ]
 179     err = ptext SLIT("On Alpha, I can only handle 32 bytes of non-floating-point arguments to foreign export dynamic")
 180 #else
 181 checkFEDArgs arg_tys = returnM ()
 182 #endif
 183 \end{code}
 184
 185
 186 %************************************************************************
 187 %*                                                                      *
 188 \subsection{Exports}
 189 %*                                                                      *
 190 %************************************************************************
 191
 192 \begin{code}
 193 tcForeignExports :: [LForeignDecl Name]
 194                  -> TcM (LHsBinds TcId, [LForeignDecl TcId])
 195 tcForeignExports decls
 196   = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
 197   where
 198    combine (binds, fs) fe =
 199        wrapLocSndM tcFExport fe `thenM` \ (b, f) ->
 200        returnM (b `consBag` binds, f:fs)
 201
 202 tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
 203 tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
 204    addErrCtxt (foreignDeclCtxt fo)      $
 205
 206    tcHsSigType (ForSigCtxt nm) hs_ty    `thenM` \ sig_ty ->
 207    tcPolyExpr (nlHsVar nm) sig_ty       `thenM` \ rhs ->
 208
 209    tcCheckFEType sig_ty spec            `thenM_`
 210
 211           -- we're exporting a function, but at a type possibly more
 212           -- constrained than its declared/inferred type. Hence the need
 213           -- to create a local binding which will call the exported function
 214           -- at a particular type (and, maybe, overloading).
 215
 216    newUnique                    `thenM` \ uniq ->
 217    getModule                    `thenM` \ mod ->
 218    let
 219         gnm  = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm))
 220                               (srcSpanStart loc)
 221         id   = mkExportedLocalId gnm sig_ty
 222         bind = L loc (VarBind id rhs)
 223    in
 224    returnM (bind, ForeignExport (L loc id) undefined spec)
 225 \end{code}
 226
 227 ------------ Checking argument types for foreign export ----------------------
 228
 229 \begin{code}
 230 tcCheckFEType sig_ty (CExport (CExportStatic str _))
 231   = check (isCLabelString str) (badCName str)           `thenM_`
 232     checkForeignArgs isFFIExternalTy arg_tys            `thenM_`
 233     checkForeignRes nonIOok isFFIExportResultTy res_ty
 234   where
 235       -- Drop the foralls before inspecting n
 236       -- the structure of the foreign type.
 237     (_, t_ty) = tcSplitForAllTys sig_ty
 238     (arg_tys, res_ty) = tcSplitFunTys t_ty
 239 \end{code}
 240
 241
 242
 243 %************************************************************************
 244 %*                                                                      *
 245 \subsection{Miscellaneous}
 246 %*                                                                      *
 247 %************************************************************************
 248
 249 \begin{code}
 250 ------------ Checking argument types for foreign import ----------------------
 251 checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM ()
 252 checkForeignArgs pred tys
 253   = mappM go tys                `thenM_`
 254     returnM ()
 255   where
 256     go ty = check (pred ty) (illegalForeignTyErr argument ty)
 257
 258 ------------ Checking result types for foreign calls ----------------------
 259 -- Check that the type has the form
 260 --    (IO t) or (t) , and that t satisfies the given predicate.
 261 --
 262 checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
 263
 264 nonIOok  = True
 265 mustBeIO = False
 266
 267 checkForeignRes non_io_result_ok pred_res_ty ty
 268         -- (IO t) is ok, and so is any newtype wrapping thereof
 269   | Just (io, res_ty) <- tcSplitIOType_maybe ty,
 270     pred_res_ty res_ty
 271   = returnM ()
 272
 273   | otherwise
 274   = check (non_io_result_ok && pred_res_ty ty)
 275           (illegalForeignTyErr result ty)
 276 \end{code}
 277
 278 \begin{code}
 279 #if defined(mingw32_TARGET_OS)
 280 checkDotnet HscC   = Nothing
 281 checkDotnet _      = Just (text "requires C code generation (-fvia-C)")
 282 #else
 283 checkDotnet other  = Just (text "requires .NET support (-filx or win32)")
 284 #endif
 285
 286 checkCOrAsm HscC   = Nothing
 287 checkCOrAsm HscAsm = Nothing
 288 checkCOrAsm other
 289    = Just (text "requires via-C or native code generation (-fvia-C)")
 290
 291 checkCOrAsmOrInterp HscC           = Nothing
 292 checkCOrAsmOrInterp HscAsm         = Nothing
 293 checkCOrAsmOrInterp HscInterpreted = Nothing
 294 checkCOrAsmOrInterp other
 295    = Just (text "requires interpreted, C or native code generation")
 296
 297 checkCOrAsmOrDotNetOrInterp HscC           = Nothing
 298 checkCOrAsmOrDotNetOrInterp HscAsm         = Nothing
 299 checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
 300 checkCOrAsmOrDotNetOrInterp other
 301    = Just (text "requires interpreted, C or native code generation")
 302
 303 checkCg check
 304  = getDOpts             `thenM` \ dflags ->
 305    let target = hscTarget dflags in
 306    case target of
 307      HscNothing -> returnM ()
 308      otherwise  ->
 309        case check target of
 310          Nothing  -> returnM ()
 311          Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
 312 \end{code}
 313
 314 Calling conventions
 315
 316 \begin{code}
 317 checkCConv :: CCallConv -> TcM ()
 318 checkCConv CCallConv  = return ()
 319 #if i386_TARGET_ARCH
 320 checkCConv StdCallConv = return ()
 321 #else
 322 checkCConv StdCallConv = addErrTc (text "calling convention not supported on this architecture: stdcall")
 323 #endif
 324 \end{code}
 325
 326 Warnings
 327
 328 \begin{code}
 329 check :: Bool -> Message -> TcM ()
 330 check True _       = returnM ()
 331 check _    the_err = addErrTc the_err
 332
 333 illegalForeignTyErr arg_or_res ty
 334   = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res,
 335                 ptext SLIT("type in foreign declaration:")])
 336          4 (hsep [ppr ty])
 337
 338 -- Used for 'arg_or_res' argument to illegalForeignTyErr
 339 argument = text "argument"
 340 result   = text "result"
 341
 342 badCName :: CLabelString -> Message
 343 badCName target
 344    = sep [quotes (ppr target) <+> ptext SLIT("is not a valid C identifier")]
 345
 346 foreignDeclCtxt fo
 347   = hang (ptext SLIT("When checking declaration:"))
 348          4 (ppr fo)
 349
 350 illegalDNMethodSig
 351   = ptext SLIT("'This pointer' expected as last argument")
 352
 353 \end{code}
 354