ghc/compiler/typecheck/TcForeign.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1998
   3 %
   4 \section[TcForeign]{Typechecking \tr{foreign} declarations}
   5
   6 A foreign declaration is used to either give an externally
   7 implemented function a Haskell type (and calling interface) or
   8 give a Haskell function an external calling interface. Either way,
   9 the range of argument and result types these functions can accommodate
  10 is restricted to what the outside world understands (read C), and this
  11 module checks to see if a foreign declaration has got a legal type.
  12
  13 \begin{code}
  14 module TcForeign
  15         (
  16           tcForeignImports
  17         , tcForeignExports
  18         ) where
  19
  20 #include "config.h"
  21 #include "HsVersions.h"
  22
  23 import HsSyn
  24
  25 import TcRnMonad
  26 import TcHsType         ( tcHsSigType, UserTypeCtxt(..) )
  27 import TcExpr           ( tcCheckSigma )
  28
  29 import ErrUtils         ( Message )
  30 import Id               ( Id, mkLocalId, mkExportedLocalId )
  31 import OccName          ( mkForeignExportOcc )
  32 import Name             ( Name, NamedThing(..), mkExternalName )
  33 import TcType           ( Type, tcSplitFunTys, tcSplitTyConApp_maybe,
  34                           tcSplitForAllTys,
  35                           isFFIArgumentTy, isFFIImportResultTy,
  36                           isFFIExportResultTy, isFFILabelTy,
  37                           isFFIExternalTy, isFFIDynArgumentTy,
  38                           isFFIDynResultTy, isFFIDotnetTy, isFFIDotnetObjTy,
  39                           toDNType
  40                         )
  41 import ForeignCall      ( CExportSpec(..), CCallTarget(..),
  42                           isDynamicTarget, withDNTypes, DNKind(..), DNCallSpec(..) )
  43 import CStrings         ( CLabelString, isCLabelString )
  44 import PrelNames        ( hasKey, ioTyConKey )
  45 import CmdLineOpts      ( dopt_HscLang, HscLang(..) )
  46 import Outputable
  47 import SrcLoc           ( Located(..), srcSpanStart )
  48 import Bag              ( emptyBag, consBag )
  49
  50 \end{code}
  51
  52 \begin{code}
  53 -- Defines a binding
  54 isForeignImport :: LForeignDecl name -> Bool
  55 isForeignImport (L _ (ForeignImport _ _ _ _)) = True
  56 isForeignImport _                             = False
  57
  58 -- Exports a binding
  59 isForeignExport :: LForeignDecl name -> Bool
  60 isForeignExport (L _ (ForeignExport _ _ _ _)) = True
  61 isForeignExport _                             = False
  62 \end{code}
  63
  64 %************************************************************************
  65 %*                                                                      *
  66 \subsection{Imports}
  67 %*                                                                      *
  68 %************************************************************************
  69
  70 \begin{code}
  71 tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id])
  72 tcForeignImports decls
  73   = mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls)
  74
  75 tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
  76 tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl isDeprec)
  77  = addErrCtxt (foreignDeclCtxt fo)      $
  78    tcHsSigType (ForSigCtxt nm) hs_ty    `thenM` \ sig_ty ->
  79    let
  80       -- drop the foralls before inspecting the structure
  81       -- of the foreign type.
  82         (_, t_ty)         = tcSplitForAllTys sig_ty
  83         (arg_tys, res_ty) = tcSplitFunTys t_ty
  84         id                = mkLocalId nm sig_ty
  85                 -- Use a LocalId to obey the invariant that locally-defined
  86                 -- things are LocalIds.  However, it does not need zonking,
  87                 -- (so TcHsSyn.zonkForeignExports ignores it).
  88    in
  89    tcCheckFIType sig_ty arg_tys res_ty imp_decl         `thenM` \ imp_decl' ->
  90    -- can't use sig_ty here because it :: Type and we need HsType Id
  91    -- hence the undefined
  92    returnM (id, ForeignImport (L loc id) undefined imp_decl' isDeprec)
  93 \end{code}
  94
  95
  96 ------------ Checking types for foreign import ----------------------
  97 \begin{code}
  98 tcCheckFIType _ arg_tys res_ty (DNImport spec)
  99   = checkCg checkDotnet  `thenM_`
 100     getDOpts             `thenM`  \ dflags ->
 101     checkForeignArgs (isFFIDotnetTy dflags) arg_tys     `thenM_`
 102     checkForeignRes True{-non IO ok-} (isFFIDotnetTy dflags) res_ty `thenM_`
 103     let (DNCallSpec isStatic kind _ _ _ _) = spec in
 104     (case kind of
 105        DNMethod | not isStatic ->
 106          case arg_tys of
 107            [] -> addErrTc illegalDNMethodSig
 108            _
 109             | not (isFFIDotnetObjTy (last arg_tys)) -> addErrTc illegalDNMethodSig
 110             | otherwise -> returnM ()
 111        _ -> returnM ()) `thenM_`
 112     returnM (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty)))
 113
 114 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ _ (CLabel _))
 115   = checkCg checkCOrAsm         `thenM_`
 116     check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty) `thenM_`
 117     return idecl
 118
 119 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper)
 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 `thenM_`
 126     (case arg_tys of
 127         [arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys               `thenM_`
 128                      checkForeignRes nonIOok  isFFIExportResultTy res1_ty    `thenM_`
 129                      checkForeignRes mustBeIO isFFIDynResultTy    res_ty     `thenM_`
 130                      checkFEDArgs arg1_tys
 131                   where
 132                      (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
 133         other -> addErrTc (illegalForeignTyErr empty sig_ty)    )            `thenM_`
 134     return idecl
 135
 136 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ _ (CFunction target))
 137   | isDynamicTarget target      -- Foreign import dynamic
 138   = checkCg checkCOrAsmOrInterp         `thenM_`
 139     case arg_tys of             -- The first arg must be Ptr, FunPtr, or Addr
 140       []                ->
 141         check False (illegalForeignTyErr empty sig_ty) `thenM_`
 142         return idecl
 143       (arg1_ty:arg_tys) ->
 144         getDOpts                                                     `thenM` \ dflags ->
 145         check (isFFIDynArgumentTy arg1_ty)
 146               (illegalForeignTyErr argument arg1_ty)                 `thenM_`
 147         checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys     `thenM_`
 148         checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty  `thenM_`
 149         return idecl
 150   | otherwise           -- Normal foreign import
 151   = checkCg (checkCOrAsmOrDotNetOrInterp)                       `thenM_`
 152     checkCTarget target                                         `thenM_`
 153     getDOpts                                                    `thenM` \ dflags ->
 154     checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys    `thenM_`
 155     checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty `thenM_`
 156     return idecl
 157
 158 -- This makes a convenient place to check
 159 -- that the C identifier is valid for C
 160 checkCTarget (StaticTarget str)
 161   = checkCg checkCOrAsmOrDotNetOrInterp         `thenM_`
 162     check (isCLabelString str) (badCName str)
 163 \end{code}
 164
 165 On an Alpha, with foreign export dynamic, due to a giant hack when
 166 building adjustor thunks, we only allow 4 integer arguments with
 167 foreign export dynamic (i.e., 32 bytes of arguments after padding each
 168 argument to a quadword, excluding floating-point arguments).
 169
 170 The check is needed for both via-C and native-code routes
 171
 172 \begin{code}
 173 #include "nativeGen/NCG.h"
 174 #if alpha_TARGET_ARCH
 175 checkFEDArgs arg_tys
 176   = check (integral_args <= 4) err
 177   where
 178     integral_args = sum (map getPrimRepSize $
 179                          filter (not . isFloatingRep) $
 180                          map typePrimRep arg_tys)
 181     err = ptext SLIT("On Alpha, I can only handle 4 non-floating-point arguments to foreign export dynamic")
 182 #else
 183 checkFEDArgs arg_tys = returnM ()
 184 #endif
 185 \end{code}
 186
 187
 188 %************************************************************************
 189 %*                                                                      *
 190 \subsection{Exports}
 191 %*                                                                      *
 192 %************************************************************************
 193
 194 \begin{code}
 195 tcForeignExports :: [LForeignDecl Name]
 196                  -> TcM (LHsBinds TcId, [LForeignDecl TcId])
 197 tcForeignExports decls
 198   = foldlM combine (emptyBag, []) (filter isForeignExport decls)
 199   where
 200    combine (binds, fs) fe =
 201        wrapLocSndM tcFExport fe `thenM` \ (b, f) ->
 202        returnM (b `consBag` binds, f:fs)
 203
 204 tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
 205 tcFExport fo@(ForeignExport (L loc nm) hs_ty spec isDeprec) =
 206    addErrCtxt (foreignDeclCtxt fo)      $
 207
 208    tcHsSigType (ForSigCtxt nm) hs_ty    `thenM` \ sig_ty ->
 209    tcCheckSigma (nlHsVar nm) sig_ty     `thenM` \ rhs ->
 210
 211    tcCheckFEType sig_ty spec            `thenM_`
 212
 213           -- we're exporting a function, but at a type possibly more
 214           -- constrained than its declared/inferred type. Hence the need
 215           -- to create a local binding which will call the exported function
 216           -- at a particular type (and, maybe, overloading).
 217
 218    newUnique                    `thenM` \ uniq ->
 219    getModule                    `thenM` \ mod ->
 220    let
 221         gnm  = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm))
 222                               Nothing (srcSpanStart loc)
 223         id   = mkExportedLocalId gnm sig_ty
 224         bind = L loc (VarBind id rhs)
 225    in
 226    returnM (bind, ForeignExport (L loc id) undefined spec isDeprec)
 227 \end{code}
 228
 229 ------------ Checking argument types for foreign export ----------------------
 230
 231 \begin{code}
 232 tcCheckFEType sig_ty (CExport (CExportStatic str _))
 233   = check (isCLabelString str) (badCName str)           `thenM_`
 234     checkForeignArgs isFFIExternalTy arg_tys            `thenM_`
 235     checkForeignRes nonIOok isFFIExportResultTy res_ty
 236   where
 237       -- Drop the foralls before inspecting n
 238       -- the structure of the foreign type.
 239     (_, t_ty) = tcSplitForAllTys sig_ty
 240     (arg_tys, res_ty) = tcSplitFunTys t_ty
 241 \end{code}
 242
 243
 244
 245 %************************************************************************
 246 %*                                                                      *
 247 \subsection{Miscellaneous}
 248 %*                                                                      *
 249 %************************************************************************
 250
 251 \begin{code}
 252 ------------ Checking argument types for foreign import ----------------------
 253 checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM ()
 254 checkForeignArgs pred tys
 255   = mappM go tys                `thenM_`
 256     returnM ()
 257   where
 258     go ty = check (pred ty) (illegalForeignTyErr argument ty)
 259
 260 ------------ Checking result types for foreign calls ----------------------
 261 -- Check that the type has the form
 262 --    (IO t) or (t) , and that t satisfies the given predicate.
 263 --
 264 checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
 265
 266 nonIOok  = True
 267 mustBeIO = False
 268
 269 checkForeignRes non_io_result_ok pred_res_ty ty
 270  = case tcSplitTyConApp_maybe ty of
 271       Just (io, [res_ty])
 272         | io `hasKey` ioTyConKey && pred_res_ty res_ty
 273         -> returnM ()
 274       _
 275         -> check (non_io_result_ok && pred_res_ty ty)
 276                  (illegalForeignTyErr result ty)
 277 \end{code}
 278
 279 \begin{code}
 280 checkDotnet HscILX = Nothing
 281 #if defined(mingw32_TARGET_OS)
 282 checkDotnet HscC   = Nothing
 283 checkDotnet _      = Just (text "requires C code generation (-fvia-C)")
 284 #else
 285 checkDotnet other  = Just (text "requires .NET support (-filx or win32)")
 286 #endif
 287
 288 checkCOrAsm HscC   = Nothing
 289 checkCOrAsm HscAsm = Nothing
 290 checkCOrAsm other
 291    = Just (text "requires via-C or native code generation (-fvia-C)")
 292
 293 checkCOrAsmOrInterp HscC           = Nothing
 294 checkCOrAsmOrInterp HscAsm         = Nothing
 295 checkCOrAsmOrInterp HscInterpreted = Nothing
 296 checkCOrAsmOrInterp other
 297    = Just (text "requires interpreted, C or native code generation")
 298
 299 checkCOrAsmOrDotNetOrInterp HscC           = Nothing
 300 checkCOrAsmOrDotNetOrInterp HscAsm         = Nothing
 301 checkCOrAsmOrDotNetOrInterp HscILX         = Nothing
 302 checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
 303 checkCOrAsmOrDotNetOrInterp other
 304    = Just (text "requires interpreted, C, native or .NET ILX code generation")
 305
 306 checkCg check
 307  = getDOpts             `thenM` \ dflags ->
 308    let hscLang = dopt_HscLang dflags in
 309    case hscLang of
 310      HscNothing -> returnM ()
 311      otherwise  ->
 312        case check hscLang of
 313          Nothing  -> returnM ()
 314          Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
 315 \end{code}
 316
 317 Warnings
 318
 319 \begin{code}
 320 check :: Bool -> Message -> TcM ()
 321 check True _       = returnM ()
 322 check _    the_err = addErrTc the_err
 323
 324 illegalForeignTyErr arg_or_res ty
 325   = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res,
 326                 ptext SLIT("type in foreign declaration:")])
 327          4 (hsep [ppr ty])
 328
 329 -- Used for 'arg_or_res' argument to illegalForeignTyErr
 330 argument = text "argument"
 331 result   = text "result"
 332
 333 badCName :: CLabelString -> Message
 334 badCName target
 335    = sep [quotes (ppr target) <+> ptext SLIT("is not a valid C identifier")]
 336
 337 foreignDeclCtxt fo
 338   = hang (ptext SLIT("When checking declaration:"))
 339          4 (ppr fo)
 340
 341 illegalDNMethodSig
 342   = ptext SLIT("'This pointer' expected as last argument")
 343
 344 \end{code}
 345