[project @ 2000-03-23 17:45:17 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcForeign.lhs

diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs
index 1f94474..58c73ab 100644 (file)
--- a/ghc/compiler/typecheck/TcForeign.lhs
+++ b/ghc/compiler/typecheck/TcForeign.lhs
@@ -20,23 +20,23 @@ module TcForeign
 #include "HsVersions.h"
 
 import HsSyn           ( HsDecl(..), ForeignDecl(..), HsExpr(..),
-                         ExtName(..), isDynamic, MonoBinds(..),
+                         ExtName(Dynamic), isDynamicExtName, MonoBinds(..),
                          OutPat(..), ForKind(..)
                        )
 import RnHsSyn         ( RenamedHsDecl, RenamedForeignDecl )
 
 import TcMonad
-import TcEnv           ( tcLookupClassByKey, newLocalId, tcLookupGlobalValue )
-import TcType          ( tcInstTcType, typeToTcType, tcSplitRhoTy, zonkTcTypeToType )
-import TcMonoType      ( tcHsType )
-import TcHsSyn         ( TcMonoBinds, maybeBoxedPrimType, TypecheckedForeignDecl, TcIdOcc(..),
+import TcEnv           ( newLocalId )
+import TcType          ( typeToTcType, tcSplitRhoTy, zonkTcTypeToType )
+import TcMonoType      ( tcHsTopBoxedType )
+import TcHsSyn         ( TcMonoBinds, TypecheckedForeignDecl,
                          TcForeignExportDecl )
 import TcExpr          ( tcId, tcPolyExpr )                    
 import Inst            ( emptyLIE, LIE, plusLIE )
 import CoreSyn
 
 import ErrUtils                ( Message )
-import Id              ( Id, idName, mkUserId )
+import Id              ( Id, idName, mkVanillaId )
 import Name            ( nameOccName )
 import Type            ( splitFunTys
                        , splitTyConApp_maybe
@@ -63,7 +63,7 @@ tcForeignImports :: [RenamedHsDecl] -> TcM s ([Id], [TypecheckedForeignDecl])
 tcForeignImports decls = 
    mapAndUnzipTc tcFImport [ foreign_decl | ForD foreign_decl <- decls, isForeignImport foreign_decl]
 
-tcForeignExports :: [RenamedHsDecl] -> TcM s (LIE s, TcMonoBinds s, [TcForeignExportDecl s])
+tcForeignExports :: [RenamedHsDecl] -> TcM s (LIE, TcMonoBinds, [TcForeignExportDecl])
 tcForeignExports decls = 
    foldlTc combine (emptyLIE, EmptyMonoBinds, [])
                   [ foreign_decl | ForD foreign_decl <- decls, isForeignExport foreign_decl]
@@ -82,7 +82,7 @@ isForeignImport (ForeignDecl _ k _ dyn _ _) =
 
 -- exports a binding
 isForeignExport :: ForeignDecl name -> Bool
-isForeignExport (ForeignDecl _ FoExport _ ext_nm _ _) = not (isDynamic ext_nm)
+isForeignExport (ForeignDecl _ FoExport _ ext_nm _ _) = not (isDynamicExtName ext_nm)
 isForeignExport _                                    = False
 
 \end{code}
@@ -92,7 +92,7 @@ tcFImport :: RenamedForeignDecl -> TcM s (Id, TypecheckedForeignDecl)
 tcFImport fo@(ForeignDecl nm FoExport hs_ty Dynamic cconv src_loc) =
    tcAddSrcLoc src_loc              $
    tcAddErrCtxt (foreignDeclCtxt fo) $
-   tcHsType hs_ty                  `thenTc`    \ sig_ty ->
+   tcHsTopBoxedType hs_ty           `thenTc`   \ sig_ty ->
    let
       -- drop the foralls before inspecting the structure
       -- of the foreign type.
@@ -101,27 +101,27 @@ tcFImport fo@(ForeignDecl nm FoExport hs_ty Dynamic cconv src_loc) =
    case splitFunTys t_ty of
      (arg_tys, res_ty) -> 
        checkForeignExport True t_ty arg_tys res_ty `thenTc_`
-       let i = (mkUserId nm sig_ty) in
+       let i = (mkVanillaId nm sig_ty) in
        returnTc (i, (ForeignDecl i FoExport undefined Dynamic cconv src_loc))
 
 tcFImport fo@(ForeignDecl nm FoLabel hs_ty ext_nm cconv src_loc) =
    tcAddSrcLoc src_loc              $
    tcAddErrCtxt (foreignDeclCtxt fo) $
-   tcHsType hs_ty                  `thenTc`    \ sig_ty ->
+   tcHsTopBoxedType hs_ty          `thenTc`    \ sig_ty ->
    let
       -- drop the foralls before inspecting the structure
       -- of the foreign type.
     (_, t_ty) = splitForAllTys sig_ty
    in
    check (isAddrTy t_ty) (illegalForeignTyErr False{-result-} sig_ty) `thenTc_`
-   let i = (mkUserId nm sig_ty) in
+   let i = (mkVanillaId nm sig_ty) in
    returnTc (i, (ForeignDecl i FoLabel undefined ext_nm cconv src_loc))
 
-tcFImport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
+tcFImport fo@(ForeignDecl nm imp_exp@(FoImport isUnsafe) hs_ty ext_nm cconv src_loc) =
    tcAddSrcLoc src_loc              $
    tcAddErrCtxt (foreignDeclCtxt fo) $
 
-   tcHsType hs_ty                   `thenTc` \ ty ->
+   tcHsTopBoxedType hs_ty           `thenTc` \ ty ->
     -- Check that the type has the right shape
     -- and that the argument and result types are acceptable.
    let
@@ -131,16 +131,16 @@ tcFImport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
    in
    case splitFunTys t_ty of
      (arg_tys, res_ty) ->
-        checkForeignImport (isDynamic ext_nm) ty arg_tys res_ty `thenTc_`
-       let i = (mkUserId nm ty) in
+        checkForeignImport (isDynamicExtName ext_nm) (not isUnsafe) ty arg_tys res_ty `thenTc_`
+       let i = (mkVanillaId nm ty) in
        returnTc (i, (ForeignDecl i imp_exp undefined ext_nm cconv src_loc))
 
-tcFExport :: RenamedForeignDecl -> TcM s (LIE s, TcMonoBinds s, TcForeignExportDecl s)
+tcFExport :: RenamedForeignDecl -> TcM s (LIE, TcMonoBinds, TcForeignExportDecl)
 tcFExport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
    tcAddSrcLoc src_loc              $
    tcAddErrCtxt (foreignDeclCtxt fo) $
 
-   tcHsType hs_ty                     `thenTc` \ sig_ty ->
+   tcHsTopBoxedType hs_ty             `thenTc` \ sig_ty ->
    let sig_tc_ty = typeToTcType sig_ty in
    tcPolyExpr (HsVar nm) sig_tc_ty     `thenTc`    \ (rhs, lie, _, _, _) ->
 
@@ -156,12 +156,11 @@ tcFExport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
          -- than its declared/inferred type. Hence the need
          -- to create a local binding which will call the exported function
          -- at a particular type (and, maybe, overloading).
-       newLocalId (nameOccName nm) sig_tc_ty   `thenNF_Tc` \ i ->
+       newLocalId (nameOccName nm) sig_tc_ty src_loc   `thenNF_Tc` \ i ->
        let
-           i2    = TcId i
-           bind  = VarMonoBind i2 rhs
+           bind  = VarMonoBind i rhs
        in
-       returnTc (lie, bind, ForeignDecl i2 imp_exp undefined ext_nm cconv src_loc)
+       returnTc (lie, bind, ForeignDecl i imp_exp undefined ext_nm cconv src_loc)
         --                                         ^^^^^^^^^
         -- ToDo: fill the type field in with something sensible.
 
@@ -169,18 +168,18 @@ tcFExport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
 
 
 \begin{code}
-checkForeignImport :: Bool -> Type -> [Type] -> Type -> TcM s ()
-checkForeignImport is_dynamic ty args res
+checkForeignImport :: Bool -> Bool -> Type -> [Type] -> Type -> TcM s ()
+checkForeignImport is_dynamic is_safe ty args res
  | is_dynamic =
     -- * first arg has got to be an Addr
    case args of
      []     -> check False (illegalForeignTyErr True{-Arg-} ty)
      (x:xs) ->
         check (isAddrTy x) (illegalForeignTyErr True{-Arg-} ty) `thenTc_`
-        mapTc (checkForeignArg isFFIArgumentTy) xs             `thenTc_`
+        mapTc (checkForeignArg (isFFIArgumentTy is_safe)) xs   `thenTc_`
        checkForeignRes (isFFIResultTy) res
  | otherwise =
-     mapTc (checkForeignArg isFFIArgumentTy) args              `thenTc_`
+     mapTc (checkForeignArg (isFFIArgumentTy is_safe)) args     `thenTc_`
      checkForeignRes (isFFIResultTy) res
 
 checkForeignExport :: Bool -> Type -> [Type] -> Type -> TcM s ()