Commit 14ac360a authored by sof's avatar sof
Browse files

[project @ 1998-08-14 12:08:25 by sof]

Typecheck foreign declarations
parent 123f2400
%
% (c) The AQUA Project, Glasgow University, 1998
%
\section[TcForeign]{Typechecking \tr{foreign} declarations}
A foreign declaration is used to either give an externally
implemented function a Haskell type (and calling interface) or
give a Haskell function an external calling interface. Either way,
the range of argument and result types these functions can accommodate
is restricted to what the outside world understands (read C), and this
module checks to see if a foreign declaration has got a legal type.
\begin{code}
module TcForeign
(
tcForeignImports
, tcForeignExports
) where
#include "HsVersions.h"
import HsSyn ( HsDecl(..), ForeignDecl(..), HsExpr(..),
ExtName(..), isDynamic, MonoBinds(..),
OutPat(..)
)
import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl )
import TcMonad
import TcEnv ( tcLookupClassByKey, newLocalId, tcLookupGlobalValue )
import TcType ( tcInstTcType, tcInstSigType, tcSplitRhoTy, zonkTcTypeToType )
import TcMonoType ( tcHsType )
import TcHsSyn ( TcMonoBinds, maybeBoxedPrimType, TypecheckedForeignDecl, TcIdOcc(..),
TcForeignExportDecl )
import TcExpr ( tcId, tcPolyExpr )
import Inst ( emptyLIE, LIE, plusLIE )
import CoreSyn
import ErrUtils ( Message )
import Id ( Id, idName )
import Name ( nameOccName )
import MkId ( mkUserId )
import Type ( isUnpointedType
, splitFunTys
, splitTyConApp_maybe
, splitForAllTys
, splitRhoTy
, isForAllTy
, mkForAllTys
)
import TyVar ( emptyTyVarEnv )
import TysWiredIn ( isFFIArgumentTy, isFFIResultTy,
isFFIExternalTy, isAddrTy
)
import Type ( Type )
import Unique
import Unify ( unifyTauTy )
import Outputable
import Util
import CmdLineOpts ( opt_GlasgowExts )
import Maybes ( maybeToBool )
\end{code}
\begin{code}
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 decls =
foldlTc combine (emptyLIE, EmptyMonoBinds, [])
[ foreign_decl | ForD foreign_decl <- decls, isForeignExport foreign_decl]
where
combine (lie, binds, fs) fe =
tcFExport fe `thenTc ` \ (a_lie, b, f) ->
returnTc (lie `plusLIE` a_lie, b `AndMonoBinds` binds, f:fs)
-- defines a binding
isForeignImport :: ForeignDecl name -> Bool
isForeignImport (ForeignDecl _ (Just _) _ _ _ _) = True
isForeignImport (ForeignDecl _ Nothing _ Dynamic _ _) = True
isForeignImport _ = False
-- exports a binding
isForeignExport :: ForeignDecl name -> Bool
isForeignExport (ForeignDecl _ Nothing _ ext_nm _ _) = not (isDynamic ext_nm)
isForeignExport _ = False
\end{code}
\begin{code}
tcFImport :: RenamedForeignDecl -> TcM s (Id, TypecheckedForeignDecl)
tcFImport fo@(ForeignDecl nm Nothing hs_ty Dynamic cconv src_loc) =
tcAddSrcLoc src_loc $
tcAddErrCtxt (foreignDeclCtxt fo) $
tcHsType hs_ty `thenTc` \ sig_ty ->
let
-- drop the foralls before inspecting the structure
-- of the foreign type.
(_, t_ty) = splitForAllTys sig_ty
in
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
returnTc (i, (ForeignDecl i Nothing undefined Dynamic cconv src_loc))
tcFImport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
tcAddSrcLoc src_loc $
tcAddErrCtxt (foreignDeclCtxt fo) $
tcHsType hs_ty `thenTc` \ ty ->
-- Check that the type has the right shape
-- and that the argument and result types are acceptable.
let
-- drop the foralls before inspecting the structure
-- of the foreign type.
(_, t_ty) = splitForAllTys ty
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
returnTc (i, (ForeignDecl i imp_exp undefined ext_nm cconv src_loc))
tcFExport :: RenamedForeignDecl -> TcM s (LIE s, TcMonoBinds s, TcForeignExportDecl s)
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 ->
tcInstSigType sig_ty `thenNF_Tc` \ sig_tc_ty ->
tcPolyExpr (HsVar nm) sig_tc_ty `thenTc` \ (rhs, lie, _, _, _) ->
let
-- drop the foralls before inspecting the structure
-- of the foreign type.
(_, t_ty) = splitForAllTys sig_ty
in
case splitFunTys t_ty of
(arg_tys, res_ty) ->
checkForeignExport False t_ty arg_tys res_ty `thenTc_`
-- we're exporting a function, but at a type possibly more constrained
-- 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 ->
let
i2 = TcId i
bind = VarMonoBind i2 rhs
in
returnTc (lie, bind, ForeignDecl i2 imp_exp undefined ext_nm cconv src_loc)
-- ^^^^^^^^^
-- ToDo: fill the type field in with something sensible.
\end{code}
\begin{code}
checkForeignImport :: Bool -> Type -> [Type] -> Type -> TcM s ()
checkForeignImport is_dynamic 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_`
checkForeignRes (isFFIResultTy) res
| otherwise =
mapTc (checkForeignArg isFFIArgumentTy) args `thenTc_`
checkForeignRes (isFFIResultTy) res
checkForeignExport :: Bool -> Type -> [Type] -> Type -> TcM s ()
checkForeignExport is_dynamic ty args res
| is_dynamic =
-- * the first (and only!) arg has got to be a function type
-- * result type is an Addr
case args of
[arg] ->
case splitFunTys arg of
(arg_tys, res_ty) ->
mapTc (checkForeignArg isFFIExternalTy) arg_tys `thenTc_`
checkForeignRes (isFFIResultTy) res_ty `thenTc_`
checkForeignRes (isAddrTy) res
_ -> check False (illegalForeignTyErr True{-Arg-} ty)
| otherwise =
mapTc (checkForeignArg isFFIExternalTy) args `thenTc_`
checkForeignRes (isFFIResultTy) res
check :: Bool -> Message -> TcM s ()
check True _ = returnTc ()
check _ the_err = addErrTc the_err `thenNF_Tc_` returnTc ()
checkForeignArg :: (Type -> Bool) -> Type -> TcM s ()
checkForeignArg pred ty = check (pred ty) (illegalForeignTyErr True{-Arg-} ty)
-- Check that the type has the form
-- (IO t) and that t satisfies the given predicate.
--
checkForeignRes :: (Type -> Bool) -> Type -> TcM s ()
checkForeignRes pred_res_ty ty =
case (splitTyConApp_maybe ty) of
Just (io, [res_ty])
| (uniqueOf io) == ioTyConKey &&
pred_res_ty res_ty
-> returnTc ()
_ -> check False (illegalForeignTyErr False{-Res-} ty)
\end{code}
Warnings
\begin{code}
illegalForeignTyErr isArg ty
= hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, ptext SLIT("type in foreign declaration")])
4 (hsep [ ptext SLIT("type:"), ppr ty])
where
arg_or_res
| isArg = ptext SLIT("argument")
| otherwise = ptext SLIT("result")
foreignDeclCtxt fo =
hang (ptext SLIT("When checking a foreign declaration:"))
4 (ppr fo)
\end{code}
......@@ -12,11 +12,12 @@ module TcHsSyn (
TcExpr, TcGRHSsAndBinds, TcGRHS, TcMatch,
TcStmt, TcArithSeqInfo, TcRecordBinds,
TcHsModule, TcCoreExpr, TcDictBinds,
TcForeignExportDecl,
TypecheckedHsBinds,
TypecheckedMonoBinds, TypecheckedPat,
TypecheckedHsExpr, TypecheckedArithSeqInfo,
TypecheckedStmt,
TypecheckedStmt, TypecheckedForeignDecl,
TypecheckedMatch, TypecheckedHsModule,
TypecheckedGRHSsAndBinds, TypecheckedGRHS,
TypecheckedRecordBinds, TypecheckedDictBinds,
......@@ -29,7 +30,8 @@ module TcHsSyn (
maybeBoxedPrimType,
zonkTopBinds, zonkBinds, zonkMonoBinds, zonkTcId
zonkTopBinds, zonkBinds, zonkMonoBinds, zonkTcId,
zonkForeignExports
) where
#include "HsVersions.h"
......@@ -87,7 +89,8 @@ type TcArithSeqInfo s = ArithSeqInfo (TcBox s) (TcIdOcc s) (TcPat s)
type TcRecordBinds s = HsRecordBinds (TcBox s) (TcIdOcc s) (TcPat s)
type TcHsModule s = HsModule (TcBox s) (TcIdOcc s) (TcPat s)
type TcCoreExpr s = GenCoreExpr (TcIdOcc s) (TcIdOcc s) (TcBox s)
type TcCoreExpr s = GenCoreExpr (TcIdOcc s) (TcIdOcc s) (TcBox s)
type TcForeignExportDecl s = ForeignDecl (TcIdOcc s)
type TypecheckedPat = OutPat Unused Id
type TypecheckedMonoBinds = MonoBinds Unused Id TypecheckedPat
......@@ -101,6 +104,7 @@ type TypecheckedGRHSsAndBinds = GRHSsAndBinds Unused Id TypecheckedPat
type TypecheckedGRHS = GRHS Unused Id TypecheckedPat
type TypecheckedRecordBinds = HsRecordBinds Unused Id TypecheckedPat
type TypecheckedHsModule = HsModule Unused Id TypecheckedPat
type TypecheckedForeignDecl = ForeignDecl Id
\end{code}
\begin{code}
......@@ -652,4 +656,20 @@ zonkPats te (pat:pats)
returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
\end{code}
%************************************************************************
%* *
\subsection[BackSubst-Foreign]{Foreign exports}
%* *
%************************************************************************
\begin{code}
zonkForeignExports :: [TcForeignExportDecl s] -> NF_TcM s [TypecheckedForeignDecl]
zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
zonkForeignExport :: TcForeignExportDecl s -> NF_TcM s (TypecheckedForeignDecl)
zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) =
zonkIdOcc i `thenNF_Tc` \ i' ->
returnNF_Tc (ForeignDecl i' imp_exp undefined ext_nm cconv src_loc)
\end{code}
......@@ -28,6 +28,7 @@ import CoreUnfold
import MagicUFs ( MagicUnfoldingFun )
import WwLib ( mkWrapper )
import PrimOp ( PrimOp(..) )
import CallConv ( cCallConv )
import MkId ( mkImportedId, mkUserId )
import Id ( Id, addInlinePragma, isPrimitiveId_maybe, dataConArgTys )
......@@ -355,7 +356,7 @@ tcCorePrim (UfOtherOp op)
tcCorePrim (UfCCallOp str casm gc arg_tys res_ty)
= mapTc tcHsType arg_tys `thenTc` \ arg_tys' ->
tcHsType res_ty `thenTc` \ res_ty' ->
returnTc (CCallOp str casm gc arg_tys' res_ty')
returnTc (CCallOp (Just str) casm gc cCallConv arg_tys' res_ty')
\end{code}
\begin{code}
......
......@@ -15,7 +15,9 @@ module TcModule (
import CmdLineOpts ( opt_D_dump_tc, opt_D_dump_deriv )
import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..) )
import RnHsSyn ( RenamedHsModule )
import TcHsSyn ( TcMonoBinds, TypecheckedMonoBinds, zonkTopBinds )
import TcHsSyn ( TcMonoBinds, TypecheckedMonoBinds, zonkTopBinds,
TypecheckedForeignDecl, zonkForeignExports
)
import TcMonad
import Inst ( Inst, emptyLIE, plusLIE )
......@@ -24,8 +26,9 @@ import TcClassDcl ( tcClassDecls2 )
import TcDefaults ( tcDefaults )
import TcEnv ( TcIdOcc(..), tcExtendGlobalValEnv, tcExtendTyConEnv,
getEnv_TyCons, getEnv_Classes, tcLookupLocalValue,
tcLookupTyCon, initEnv )
tcLookupTyCon, initEnv, tcSetGlobalValEnv )
import TcExpr ( tcId )
import TcForeign ( tcForeignImports, tcForeignExports )
import TcIfaceSig ( tcInterfaceSigs )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
import TcInstUtil ( buildInstanceEnvs, classDataCon, InstInfo )
......@@ -65,7 +68,8 @@ Outside-world interface:
type TcResults
= (TypecheckedMonoBinds,
[TyCon], [Class],
Bag InstInfo, -- Instance declaration information
Bag InstInfo, -- Instance declaration information
[TypecheckedForeignDecl], -- foreign import & exports.
TcDDumpDeriv)
type TcDDumpDeriv = SDoc
......@@ -87,13 +91,13 @@ typecheckModule us rn_name_supply mod
dumpIfSet opt_D_dump_tc "Typechecked"
(case maybe_result of
Just (binds, _, _, _, _) -> ppr binds
Nothing -> text "Typecheck failed") >>
Just (binds, _, _, _, ds, _) -> ppr binds $$ ppr ds
Nothing -> text "Typecheck failed") >>
dumpIfSet opt_D_dump_deriv "Derived instances"
(case maybe_result of
Just (_, _, _, _, dump_deriv) -> dump_deriv
Nothing -> empty) >>
Just (_, _, _, _, _, dump_deriv) -> dump_deriv
Nothing -> empty) >>
return (if isEmptyBag errs then
maybe_result
......@@ -193,6 +197,9 @@ tcModule rn_name_supply
tcInterfaceSigs unf_env decls `thenTc` \ sig_ids ->
tcExtendGlobalValEnv sig_ids $
-- foreign import declarations next.
tcForeignImports decls `thenTc` \ (fo_ids, foi_decls) ->
tcExtendGlobalValEnv fo_ids $
-- Value declarations next.
-- We also typecheck any extra binds that came out of the "deriving" process
......@@ -205,6 +212,8 @@ tcModule rn_name_supply
) `thenTc` \ ((val_binds, final_env), lie_valdecls) ->
tcSetEnv final_env $
-- foreign export declarations next.
tcForeignExports decls `thenTc` \ (lie_fodecls, foe_binds, foe_decls) ->
-- Second pass over class and instance declarations,
-- to compile the bindings themselves.
......@@ -212,8 +221,6 @@ tcModule rn_name_supply
tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_binds) ->
-- Check that "main" has the right signature
tcCheckMainSig mod_name `thenTc_`
......@@ -225,7 +232,10 @@ tcModule rn_name_supply
-- during the generalisation step.)
-- trace "tc9" $
let
lie_alldecls = lie_valdecls `plusLIE` lie_instdecls `plusLIE` lie_clasdecls
lie_alldecls = lie_valdecls `plusLIE`
lie_instdecls `plusLIE`
lie_clasdecls `plusLIE`
lie_fodecls
in
tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds ->
......@@ -237,12 +247,16 @@ tcModule rn_name_supply
val_binds `AndMonoBinds`
inst_binds `AndMonoBinds`
cls_binds `AndMonoBinds`
const_inst_binds
const_inst_binds `AndMonoBinds`
foe_binds
in
zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', really_final_env) ->
zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', really_final_env) ->
tcSetGlobalValEnv really_final_env $
zonkForeignExports foe_decls `thenNF_Tc` \ foe_decls' ->
returnTc (really_final_env,
(all_binds', local_tycons, local_classes, inst_info, ddump_deriv))
(all_binds',local_tycons, local_classes,
inst_info, foi_decls ++ foe_decls', ddump_deriv))
-- End of outer fix loop
) `thenTc` \ (final_env, stuff) ->
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment