import UniqSupply ( uniqFromSupply, uniqsFromSupply, splitUniqSupply,
UniqSupply )
import CmdLineOpts ( opt_EmitCExternDecls )
-import ForeignCall ( ForeignCall(..), CCallSpec(..), isDynamicTarget )
+import ForeignCall ( ForeignCall(..), CCallSpec(..), isDynamicTarget, isCasmTarget )
import StgSyn ( StgOp(..) )
import Panic ( panic )
import FastTypes
= flatAbsC absC `thenFlt` \ (alt_heres, alt_tops) ->
returnFlt ( (tag, alt_heres), alt_tops )
-flatAbsC stmt@(COpStmt results (StgFCallOp (CCall ccall@(CCallSpec target _ _ is_asm)) uniq) args _)
- | is_dynamic -- Emit a typedef if its a dynamic call
- || (opt_EmitCExternDecls && not is_asm) -- or we want extern decls
+flatAbsC stmt@(COpStmt results (StgFCallOp (CCall ccall@(CCallSpec target _ _)) uniq) args _)
+ | is_dynamic -- Emit a typedef if its a dynamic call
+ || (opt_EmitCExternDecls && not (isCasmTarget target)) -- or we want extern decls
= returnFlt (stmt, CCallTypedef is_dynamic ccall uniq results args)
where
is_dynamic = isDynamicTarget target
import DataCon ( dataConWrapId )
import Maybes ( maybeToBool, catMaybes )
import PrimOp ( primOpNeedsWrapper )
-import ForeignCall ( ForeignCall(..), isDynamicTarget )
+import ForeignCall ( ForeignCall(..) )
import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize )
import SMRep ( pprSMRep )
import Unique ( pprUnique, Unique{-instance NamedThing-} )
pprAbsC (CCallProfCCMacro op as) _
= hcat [ptext op, lparen,
hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
-pprAbsC stmt@(CCallTypedef is_tdef (CCallSpec op_str cconv _ _) uniq results args) _
+pprAbsC stmt@(CCallTypedef is_tdef (CCallSpec op_str cconv _) uniq results args) _
= hsep [ ptext (if is_tdef then SLIT("typedef") else SLIT("extern"))
, ccall_res_ty
, fun_nm
that the runtime check that PerformGC is being used sensibly will work.
\begin{code}
-pprFCall call@(CCall (CCallSpec op_str cconv safety is_asm)) uniq args results vol_regs
+pprFCall call@(CCall (CCallSpec target cconv safety)) uniq args results vol_regs
= vcat [
char '{',
declare_local_vars, -- local var for *result*
vcat local_arg_decls,
pp_save_context,
- process_casm local_vars pp_non_void_args casm_str,
+ process_casm local_vars pp_non_void_args call_str,
pp_restore_context,
assign_results,
char '}'
(declare_local_vars, local_vars, assign_results)
= ppr_casm_results non_void_results
- casm_str = if is_asm then _UNPK_ asm_str else ccall_str
- StaticTarget asm_str = op_str -- Must be static if it's a casm
+ call_str = case target of
+ CasmTarget str -> _UNPK_ str
+ StaticTarget fn -> mk_ccall_str (pprCLabelString fn) ccall_args
+ DynamicTarget -> mk_ccall_str dyn_fun (tail ccall_args)
- -- Remainder only used for ccall
-
- fun_name = case op_str of
- DynamicTarget -> parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr uniq) <> text "%0")
- StaticTarget st -> pprCLabelString st
+ ccall_args = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..]
+ dyn_fun = parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr uniq) <> text "%0")
+
- ccall_str = showSDoc
+ -- Remainder only used for ccall
+ mk_ccall_str fun_name ccall_fun_args = showSDoc
(hcat [
if null non_void_results
then empty
hcat (punctuate comma ccall_fun_args),
text "));"
])
-
- ccall_fun_args | isDynamicTarget op_str = tail ccall_args
- | otherwise = ccall_args
-
- ccall_args = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..]
\end{code}
If the argument is a heap object, we need to reach inside and pull out
import VarSet
import Literal ( isLitLitLit, litSize )
import PrimOp ( primOpIsDupable, primOpOutOfLine )
-import ForeignCall ( ForeignCall(..), ccallIsCasm )
+import ForeignCall ( okToExposeFCall )
import IdInfo ( InlinePragInfo(..), OccInfo(..), GlobalIdDetails(..),
isNeverInlinePrag
)
not (any isLitLitLit [ lit | (LitAlt lit, _, _) <- alts ])
go (Note _ body) = go body
go (Type _) = True
-
- -- ok to unfold a PrimOp as long as it's not a _casm_
- okToExposeFCall (CCall cc) = not (ccallIsCasm cc)
- okToExposeFCall other = True
\end{code}
import DataCon ( splitProductType_maybe, dataConSourceArity, dataConWrapId )
import ForeignCall ( ForeignCall, CCallTarget(..) )
import Type ( isUnLiftedType, splitAlgTyConApp_maybe, mkFunTys,
- splitTyConApp_maybe, tyVarsOfType, mkForAllTys,
+ splitTyConApp_maybe, tyVarsOfType, mkForAllTys, isPrimitiveType,
isNewType, repType, isUnLiftedType, mkFunTy, mkTyConApp,
Type
)
boxResult [] result_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
getUniqueDs `thenDs` \ uniq ->
let
- the_fcall = CCall (CCallSpec (StaticTarget lbl) CCallConv may_gc is_asm)
+ target | is_asm = CasmTarget lbl
+ | otherwise = StaticTarget lbl
+ the_fcall = CCall (CCallSpec target CCallConv may_gc)
the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
in
returnDs (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
-- where W is a CoreExpr that probably mentions x#
unboxArg arg
- -- Unlifted types: nothing to unbox
- | isUnLiftedType arg_ty
+ -- Primtive types: nothing to unbox
+ | isPrimitiveType arg_ty
= returnDs (arg, \body -> body)
-- Newtypes
CoreExpr -> CoreExpr) -- Wrapper for the result
resultWrapper result_ty
-- Base case 1: primitive types
- | isUnLiftedType result_ty
+ | isPrimitiveType result_ty
= (Just result_ty, \e -> e)
-- Base case 1: the unit type ()
import DsCCall ( dsCCall, mkFCall, boxResult, unboxArg, resultWrapper )
import DsMonad
-import HsSyn ( ExtName(..), ForeignDecl(..), isDynamicExtName, ForKind(..) )
-import HsDecls ( extNameStatic )
+import HsSyn ( ForeignDecl(..), FoExport(..), FoImport(..) )
import TcHsSyn ( TypecheckedForeignDecl )
import CoreUtils ( exprType, mkInlineMe )
import Id ( Id, idType, idName, mkVanillaGlobal, mkSysLocal,
)
import ForeignCall ( ForeignCall(..), CCallSpec(..),
Safety(..), playSafe,
- CCallTarget(..), dynamicTarget,
+ CExportSpec(..),
CCallConv(..), ccallConvToInt
)
+import CStrings ( CLabelString )
import TysWiredIn ( unitTy, addrTy, stablePtrTyCon )
import TysPrim ( addrPrimTy )
import PrelNames ( hasKey, ioTyConKey, deRefStablePtrName, newStablePtrName,
, SDoc -- C stubs to use when calling
-- "foreign exported" functions.
)
-dsForeigns mod_name fos = foldlDs combine ([], [], empty, empty) fos
+dsForeigns mod_name fos
+ = foldlDs combine ([], [], empty, empty) fos
where
- combine (acc_feb, acc_f, acc_h, acc_c) fo@(ForeignDecl i imp_exp _ ext_nm cconv _)
- | isForeignImport = -- foreign import (dynamic)?
- dsFImport i (idType i) uns ext_nm cconv `thenDs` \ bs ->
- returnDs (acc_feb, bs ++ acc_f, acc_h, acc_c)
- | isForeignLabel =
- dsFLabel i (idType i) ext_nm `thenDs` \ b ->
- returnDs (acc_feb, b:acc_f, acc_h, acc_c)
- | isDynamicExtName ext_nm =
- dsFExportDynamic i (idType i) mod_name ext_nm cconv `thenDs` \ (feb,bs,h,c) ->
- returnDs (feb:acc_feb, bs ++ acc_f, h $$ acc_h, c $$ acc_c)
-
- | otherwise = -- foreign export
- dsFExport i (idType i) mod_name ext_nm cconv False `thenDs` \ (feb,fe,h,c) ->
- returnDs (feb:acc_feb, fe:acc_f, h $$ acc_h, c $$ acc_c)
- where
- isForeignImport =
- case imp_exp of
- FoImport _ -> True
- _ -> False
-
- isForeignLabel =
- case imp_exp of
- FoLabel -> True
- _ -> False
-
- FoImport uns = imp_exp
+ combine (acc_feb, acc_f, acc_h, acc_c) (ForeignImport id _ spec _)
+ = dsFImport mod_name id spec `thenDs` \ (bs, h, c) ->
+ returnDs (acc_feb, bs ++ acc_f, h $$ acc_h, c $$ acc_c)
+
+ combine (acc_feb, acc_f, acc_h, acc_c) (ForeignExport id _ (CExport (CExportStatic ext_nm cconv)) _)
+ = dsFExport mod_name id (idType id) ext_nm cconv False `thenDs` \ (feb, b, h, c) ->
+ returnDs (feb:acc_feb, b : acc_f, h $$ acc_h, c $$ acc_c)
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Foreign import}
+%* *
+%************************************************************************
+
Desugaring foreign imports is just the matter of creating a binding
that on its RHS unboxes its arguments, performs the external call
(using the @CCallOp@ primop), before boxing the result up and returning it.
\begin{code}
-dsFImport :: Id
- -> Type -- Type of foreign import.
- -> Safety -- Whether can re-enter the Haskell RTS, do GC etc
- -> ExtName
- -> CCallConv
- -> DsM [Binding]
-dsFImport fn_id ty safety ext_name cconv
+dsFImport :: Module
+ -> Id
+ -> FoImport
+ -> DsM ([Binding], SDoc, SDoc)
+dsFImport mod_name lbl_id (LblImport ext_nm)
+ = ASSERT(fromJust res_ty == addrPrimTy) -- typechecker ensures this
+ returnDs ([(lbl_id, rhs)], empty, empty)
+ where
+ (res_ty, fo_rhs) = resultWrapper (idType lbl_id)
+ rhs = fo_rhs (mkLit (MachLabel ext_nm))
+
+dsFImport mod_name fn_id (CImport spec) = dsFCall mod_name fn_id (CCall spec)
+dsFImport mod_name fn_id (DNImport spec) = dsFCall mod_name fn_id (DNCall spec)
+dsFImport mod_name fn_id (CDynImport cconv) = dsFExportDynamic mod_name fn_id cconv
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Foreign calls}
+%* *
+%************************************************************************
+
+\begin{code}
+dsFCall mod_Name fn_id fcall
= let
+ ty = idType fn_id
(tvs, fun_ty) = splitForAllTys ty
(arg_tys, io_res_ty) = splitFunTys fun_ty
in
-- These are the ids we pass to boxResult, which are used to decide
-- whether to touch# an argument after the call (used to keep
-- ForeignObj#s live across a 'safe' foreign import).
- maybe_arg_ids | playSafe safety = work_arg_ids
- | otherwise = []
+ maybe_arg_ids | unsafe_call fcall = work_arg_ids
+ | otherwise = []
in
boxResult maybe_arg_ids io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
getUniqueDs `thenDs` \ ccall_uniq ->
getUniqueDs `thenDs` \ work_uniq ->
let
- lbl = case ext_name of
- Dynamic -> dynamicTarget
- ExtName fs _ -> StaticTarget fs
-
-- Build the worker
worker_ty = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
- the_ccall = CCall (CCallSpec lbl cconv safety False)
- the_ccall_app = mkFCall ccall_uniq the_ccall val_args ccall_result_ty
+ the_ccall_app = mkFCall ccall_uniq fcall val_args ccall_result_ty
work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app)
work_id = mkSysLocal SLIT("$wccall") work_uniq worker_ty
wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
wrap_rhs = mkInlineMe (mkLams (tvs ++ args) wrapper_body)
in
- returnDs [(work_id, work_rhs), (fn_id, wrap_rhs)]
+ returnDs ([(work_id, work_rhs), (fn_id, wrap_rhs)], empty, empty)
+
+unsafe_call (CCall (CCallSpec _ _ safety)) = playSafe safety
+unsafe_call (DNCall _) = False
\end{code}
-Foreign labels
-\begin{code}
-dsFLabel :: Id -> Type -> ExtName -> DsM Binding
-dsFLabel nm ty ext_name =
- ASSERT(fromJust res_ty == addrPrimTy) -- typechecker ensures this
- returnDs (nm, fo_rhs (mkLit (MachLabel enm)))
- where
- (res_ty, fo_rhs) = resultWrapper ty
- enm = extNameStatic ext_name
-\end{code}
+%************************************************************************
+%* *
+\subsection{Foreign export}
+%* *
+%************************************************************************
The function that does most of the work for `@foreign export@' declarations.
(see below for the boilerplate code a `@foreign export@' declaration expands
the user-written Haskell function `@M.foo@'.
\begin{code}
-dsFExport :: Id
- -> Type -- Type of foreign export.
- -> Module
- -> ExtName
+dsFExport :: Module
+ -> Id -- Either the exported Id,
+ -- or the foreign-export-dynamic constructor
+ -> Type -- The type of the thing callable from C
+ -> CLabelString -- The name to export to C land
-> CCallConv
- -> Bool -- True => invoke IO action that's hanging off
- -- the first argument's stable pointer
+ -> Bool -- True => foreign export dynamic
+ -- so invoke IO action that's hanging off
+ -- the first argument's stable pointer
-> DsM ( Id -- The foreign-exported Id
, Binding
, SDoc
, SDoc
)
-dsFExport fn_id ty mod_name ext_name cconv isDyn
+dsFExport mod_name fn_id ty ext_name cconv isDyn
= -- BUILD THE returnIO WRAPPER, if necessary
-- Look at the result type of the exported function, orig_res_ty
-- If it's IO t, return (\x.x, IO t, t)
the_app = getFun_wrapper (return_io_wrapper (mkVarApps (Var i) (tvs ++ fe_args)))
the_body = mkLams (tvs ++ wrapper_args) the_app
- c_nm = extNameStatic ext_name
(h_stub, c_stub) = fexportEntry (moduleUserString mod)
- c_nm f_helper_glob
- wrapper_arg_tys res_ty cconv isDyn
+ ext_name f_helper_glob
+ wrapper_arg_tys res_ty cconv isDyn
in
returnDs (f_helper_glob, (f_helper_glob, the_body), h_stub, c_stub)
where
- (tvs,sans_foralls) = splitForAllTys ty
- (fe_arg_tys', orig_res_ty) = splitFunTys sans_foralls
+ (tvs,sans_foralls) = splitForAllTys ty
+ (fe_arg_tys', orig_res_ty) = splitFunTys sans_foralls
- (_, stbl_ptr_ty') = splitForAllTys stbl_ptr_ty
- (_, stbl_ptr_to_ty) = splitAppTy stbl_ptr_ty'
+ (_, stbl_ptr_ty') = splitForAllTys stbl_ptr_ty
+ (_, stbl_ptr_to_ty) = splitAppTy stbl_ptr_ty'
fe_arg_tys | isDyn = tail fe_arg_tys'
| otherwise = fe_arg_tys'
\end{verbatim}
\begin{code}
-dsFExportDynamic :: Id
- -> Type -- Type of foreign export.
- -> Module
- -> ExtName
+dsFExportDynamic :: Module
+ -> Id
-> CCallConv
- -> DsM (Id, [Binding], SDoc, SDoc)
-dsFExportDynamic i ty mod_name ext_name cconv =
- newSysLocalDs ty `thenDs` \ fe_id ->
+ -> DsM ([Binding], SDoc, SDoc)
+dsFExportDynamic mod_name id cconv
+ = newSysLocalDs ty `thenDs` \ fe_id ->
let
-- hack: need to get at the name of the C stub we're about to generate.
- fe_nm = moduleUserString mod_name ++ "_" ++ toCName fe_id
- fe_ext_name = ExtName (_PK_ fe_nm) Nothing
+ fe_nm = _PK_ (moduleUserString mod_name ++ "_" ++ toCName fe_id)
in
- dsFExport i export_ty mod_name fe_ext_name cconv True
- `thenDs` \ (feb, fe, h_code, c_code) ->
- newSysLocalDs arg_ty `thenDs` \ cback ->
- dsLookupGlobalValue newStablePtrName `thenDs` \ newStablePtrId ->
+ dsFExport mod_name id export_ty fe_nm cconv True `thenDs` \ (feb, fe, h_code, c_code) ->
+ newSysLocalDs arg_ty `thenDs` \ cback ->
+ dsLookupGlobalValue newStablePtrName `thenDs` \ newStablePtrId ->
let
mk_stbl_ptr_app = mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
in
-}
adj_args = [ mkIntLitInt (ccallConvToInt cconv)
, Var stbl_value
- , mkLit (MachLabel (_PK_ fe_nm))
+ , mkLit (MachLabel fe_nm)
]
-- name of external entry point providing these services.
-- (probably in the RTS.)
io_app = mkLams tvs $
mkLams [cback] $
stbl_app ccall_io_adj res_ty
- fed = (i `setInlinePragma` neverInlinePrag, io_app)
+ fed = (id `setInlinePragma` neverInlinePrag, io_app)
-- Never inline the f.e.d. function, because the litlit
-- might not be in scope in other modules.
in
- returnDs (feb, [fed, fe], h_code, c_code)
+ returnDs ([fed, fe], h_code, c_code)
where
+ ty = idType id
(tvs,sans_foralls) = splitForAllTys ty
([arg_ty], io_res_ty) = splitFunTys sans_foralls
Just (ioTyCon, [res_ty]) = splitTyConApp_maybe io_res_ty
\begin{code}
module HsDecls (
HsDecl(..), TyClDecl(..), InstDecl(..), RuleDecl(..), RuleBndr(..),
- DefaultDecl(..), ForeignDecl(..), ForKind(..),
- ExtName(..), isDynamicExtName, extNameStatic,
+ DefaultDecl(..),
+ ForeignDecl(..), FoImport(..), FoExport(..), FoType(..),
ConDecl(..), ConDetails(..),
BangType(..), getBangType, getBangStrictness, unbangedType,
DeprecDecl(..), DeprecTxt,
- hsDeclName, instDeclName, tyClDeclName, tyClDeclNames, tyClDeclSysNames,
+ hsDeclName, instDeclName,
+ tyClDeclName, tyClDeclNames, tyClDeclSysNames, tyClDeclTyVars,
isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, countTyClDecls,
mkClassDeclSysNames, isIfaceRuleDecl, ifaceRuleDeclName,
getClassDeclSysNames, conDetailsTys
import CoreSyn ( CoreRule(..) )
import BasicTypes ( NewOrData(..) )
import Demand ( StrictnessMark(..) )
-import ForeignCall ( CCallConv )
+import ForeignCall ( CExportSpec, CCallSpec, DNCallSpec, CCallConv )
-- others:
-import ForeignCall ( Safety )
import Name ( NamedThing )
import FunDeps ( pprFundeps )
import Class ( FunDep, DefMeth(..) )
-import CStrings ( CLabelString, pprCLabelString )
+import CStrings ( CLabelString )
import Outputable
import SrcLoc ( SrcLoc )
\end{code}
hsDeclName :: (NamedThing name, Outputable name, Outputable pat)
=> HsDecl name pat -> name
#endif
-hsDeclName (TyClD decl) = tyClDeclName decl
-hsDeclName (InstD decl) = instDeclName decl
-hsDeclName (ForD (ForeignDecl name _ _ _ _ _)) = name
-hsDeclName (FixD (FixitySig name _ _)) = name
+hsDeclName (TyClD decl) = tyClDeclName decl
+hsDeclName (InstD decl) = instDeclName decl
+hsDeclName (ForD decl) = forDeclName decl
+hsDeclName (FixD (FixitySig name _ _)) = name
-- Others don't make sense
#ifdef DEBUG
hsDeclName x = pprPanic "HsDecls.hsDeclName" (ppr x)
\begin{code}
+-- TyClDecls are precisely the kind of declarations that can
+-- appear in interface files; or (internally) in GHC's interface
+-- for a module. That's why (despite the misnomer) IfaceSig and ForeignType
+-- are both in TyClDecl
+
data TyClDecl name pat
= IfaceSig { tcdName :: name, -- It may seem odd to classify an interface-file signature
- tcdType :: HsType name, -- as a 'TyClDecl', but it's very convenient. These three
- tcdIdInfo :: [HsIdInfo name], -- are the kind that appear in interface files.
+ tcdType :: HsType name, -- as a 'TyClDecl', but it's very convenient.
+ tcdIdInfo :: [HsIdInfo name],
tcdLoc :: SrcLoc
}
+ | ForeignType { tcdName :: name, -- See remarks about IfaceSig above
+ tcdFoType :: FoType,
+ tcdLoc :: SrcLoc }
+
| TyData { tcdND :: NewOrData,
tcdCtxt :: HsContext name, -- context
tcdName :: name, -- type constructor
-- For record fields, the first one counts as the SrcLoc
-- We use the equality to filter out duplicate field names
-tyClDeclNames (TySynonym {tcdName = name, tcdLoc = loc}) = [(name,loc)]
-tyClDeclNames (IfaceSig {tcdName = name, tcdLoc = loc}) = [(name,loc)]
+tyClDeclNames (TySynonym {tcdName = name, tcdLoc = loc}) = [(name,loc)]
+tyClDeclNames (IfaceSig {tcdName = name, tcdLoc = loc}) = [(name,loc)]
+tyClDeclNames (ForeignType {tcdName = name, tcdLoc = loc}) = [(name,loc)]
tyClDeclNames (ClassDecl {tcdName = cls_name, tcdSigs = sigs, tcdLoc = loc})
= (cls_name,loc) : [(n,loc) | ClassOpSig n _ _ loc <- sigs]
= (tc_name,loc) : conDeclsNames cons
+tyClDeclTyVars (TySynonym {tcdTyVars = tvs}) = tvs
+tyClDeclTyVars (TyData {tcdTyVars = tvs}) = tvs
+tyClDeclTyVars (ClassDecl {tcdTyVars = tvs}) = tvs
+tyClDeclTyVars (ForeignType {}) = []
+tyClDeclTyVars (IfaceSig {}) = []
+
+
--------------------------------
-- The "system names" are extra implicit names *bound* by the decl.
-- They are kept in a list rather than a tuple
tcdType d1 == tcdType d2 &&
tcdIdInfo d1 == tcdIdInfo d2
+ (==) d1@(ForeignType {}) d2@(ForeignType {})
+ = tcdName d1 == tcdName d2 &&
+ tcdFoType d1 == tcdFoType d2
+
(==) d1@(TyData {}) d2@(TyData {})
= tcdName d1 == tcdName d2 &&
tcdND d1 == tcdND d2 &&
ppr (IfaceSig {tcdName = var, tcdType = ty, tcdIdInfo = info})
= hsep [ppr var, dcolon, ppr ty, pprHsIdInfo info]
+ ppr (ForeignType {tcdName = tycon})
+ = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
+
ppr (TySynonym {tcdName = tycon, tcdTyVars = tyvars, tcdSynRhs = mono_ty})
= hang (ptext SLIT("type") <+> pp_decl_head [] tycon tyvars <+> equals)
4 (ppr mono_ty)
%************************************************************************
\begin{code}
-data ForeignDecl name =
- ForeignDecl
- name
- ForKind
- (HsType name)
- ExtName
- CCallConv
- SrcLoc
-
-instance (Outputable name)
- => Outputable (ForeignDecl name) where
-
- ppr (ForeignDecl nm imp_exp ty ext_name cconv src_loc)
- = ptext SLIT("foreign") <+> ppr_imp_exp <+> ppr cconv <+>
- ppr ext_name <+> ppr_unsafe <+> ppr nm <+> dcolon <+> ppr ty
- where
- (ppr_imp_exp, ppr_unsafe) =
- case imp_exp of
- FoLabel -> (ptext SLIT("label"), empty)
- FoExport -> (ptext SLIT("export"), empty)
- FoImport us -> (ptext SLIT("import"), ppr us)
-
-data ForKind
- = FoLabel
- | FoExport
- | FoImport Safety
-
-data ExtName
- = Dynamic
- | ExtName CLabelString -- The external name of the foreign thing,
- (Maybe CLabelString) -- and optionally its DLL or module name
- -- Both of these are completely unencoded;
- -- we just print them as they are
-
-isDynamicExtName :: ExtName -> Bool
-isDynamicExtName Dynamic = True
-isDynamicExtName _ = False
-
-extNameStatic :: ExtName -> CLabelString
-extNameStatic (ExtName f _) = f
-extNameStatic Dynamic = panic "staticExtName: Dynamic - shouldn't ever happen."
-
-instance Outputable ExtName where
- ppr Dynamic = ptext SLIT("dynamic")
- ppr (ExtName nm mb_mod) =
- case mb_mod of { Nothing -> empty; Just m -> doubleQuotes (ptext m) } <+>
- doubleQuotes (pprCLabelString nm)
+data ForeignDecl name
+ = ForeignImport name (HsType name) FoImport SrcLoc
+ | ForeignExport name (HsType name) FoExport SrcLoc
+
+forDeclName (ForeignImport n _ _ _) = n
+forDeclName (ForeignExport n _ _ _) = n
+
+data FoImport
+ = LblImport CLabelString -- foreign label
+ | CImport CCallSpec -- foreign import
+ | CDynImport CCallConv -- foreign export dynamic
+ | DNImport DNCallSpec -- foreign import dotnet
+
+data FoExport = CExport CExportSpec
+
+data FoType = DNType -- In due course we'll add subtype stuff
+ deriving( Eq ) -- Used for equality instance for TyClDecl
+
+instance Outputable name => Outputable (ForeignDecl name) where
+ ppr (ForeignImport nm ty (LblImport lbl) src_loc)
+ = ptext SLIT("foreign label") <+> ppr lbl <+> ppr nm <+> dcolon <+> ppr ty
+ ppr (ForeignImport nm ty decl src_loc)
+ = ptext SLIT("foreign import") <+> ppr decl <+> ppr nm <+> dcolon <+> ppr ty
+ ppr (ForeignExport nm ty decl src_loc)
+ = ptext SLIT("foreign export") <+> ppr decl <+> ppr nm <+> dcolon <+> ppr ty
+
+instance Outputable FoImport where
+ ppr (CImport d) = ppr d
+ ppr (CDynImport conv) = text "dynamic" <+> ppr conv
+ ppr (DNImport d) = ptext SLIT("dotnet") <+> ppr d
+ ppr (LblImport l) = ptext SLIT("label") <+> ppr l
+
+instance Outputable FoExport where
+ ppr (CExport d) = ppr d
+
+instance Outputable FoType where
+ ppr DNType = ptext SLIT("type dotnet")
\end{code}
+
%************************************************************************
%* *
\subsection{Transformation rules}
import NameSet
import OccName ( pprOccName )
import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon, tyConGenIds,
- tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize, isClassTyCon
+ tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize,
+ isClassTyCon, isForeignTyCon
)
import Class ( classExtraBigSig, classTyCon, DefMeth(..) )
import FieldLabel ( fieldLabelType )
tcdSysNames = map getName (tyConGenIds tycon),
tcdLoc = noSrcLoc }
+ | isForeignTyCon tycon
+ = ForeignType { tcdName = getName tycon,
+ tcdFoType = DNType, -- The only case at present
+ tcdLoc = noSrcLoc }
+
| otherwise = pprPanic "ifaceTyCls" (ppr tycon)
tyvars = tyConTyVars tycon
\begin{code}
foreignCallCode lhs (CCall (CCallSpec (StaticTarget fn) cconv safety is_asm)) rhs
- | is_asm = error "ERROR: Native code generator can't handle casm"
| not (playSafe safety) = returnUs (\xs -> ccall : xs)
| otherwise
ccall = case lhs of
[] -> StCall fn cconv VoidRep args
- [lhs] ->
- let lhs' = amodeToStix lhs
- pk = case getAmodeRep lhs of
+ [lhs] -> StAssign pk lhs' (StCall fn cconv pk args)
+ where
+ lhs' = amodeToStix lhs
+ pk = case getAmodeRep lhs of
FloatRep -> FloatRep
DoubleRep -> DoubleRep
other -> IntRep
- in
- StAssign pk lhs' (StCall fn cconv pk args)
foreignCallCode lhs call rhs
= pprPanic "Native code generator can't handle foreign call" (ppr call)
| ITwith
| ITstdcallconv
| ITccallconv
+ | ITdotnet
| ITinterface -- interface keywords
| IT__export
( "with", ITwith ),
( "stdcall", ITstdcallconv),
( "ccall", ITccallconv),
+ ( "dotnet", ITdotnet),
("_ccall_", ITccall (False, False, PlayRisky)),
("_ccall_GC_", ITccall (False, False, PlaySafe)),
("_casm_", ITccall (False, True, PlayRisky)),
, mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp
, groupBindings
- , mkExtName -- Maybe ExtName -> RdrName -> ExtName
+ , mkExtName -- RdrName -> ExtName
, checkPrec -- String -> P String
, checkContext -- HsType -> P HsContext
import ForeignCall ( CCallConv(..) )
import OccName ( dataName, varName, tcClsName,
occNameSpace, setOccNameSpace, occNameUserString )
+import CStrings ( CLabelString )
import FastString ( unpackFS )
import UniqFM ( UniqFM, listToUFM )
import Outputable
-- want z-encoding (e.g. names with z's in them shouldn't be doubled)
-- (This is why we use occNameUserString.)
-mkExtName :: Maybe ExtName -> RdrName -> ExtName
-mkExtName Nothing rdrNm = ExtName (_PK_ (occNameUserString (rdrNameOcc rdrNm)))
- Nothing
-mkExtName (Just x) _ = x
+mkExtName :: RdrName -> CLabelString
+mkExtName rdrNm = _PK_ (occNameUserString (rdrNameOcc rdrNm))
-----------------------------------------------------------------------------
-- group function bindings into equation groups
{-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.65 2001/05/22 13:43:17 simonpj Exp $
+$Id: Parser.y,v 1.66 2001/05/24 13:59:11 simonpj Exp $
Haskell grammar.
import PrelNames ( mAIN_Name, unitTyCon_RDR, funTyCon_RDR, listTyCon_RDR,
tupleTyCon_RDR, unitCon_RDR, nilCon_RDR, tupleCon_RDR
)
-import ForeignCall ( Safety(..), CCallConv(..), defaultCCallConv )
+import ForeignCall ( Safety(..), CExportSpec(..), CCallSpec(..),
+ CCallConv(..), CCallTarget(..), defaultCCallConv,
+ DNCallSpec(..) )
import OccName ( UserFS, varName, tcName, dataName, tcClsName, tvName )
import SrcLoc ( SrcLoc )
import Module
import Panic
import GlaExts
+import CStrings ( CLabelString )
import FastString ( tailFS )
+import Maybes ( orElse )
import Outputable
#include "HsVersions.h"
'with' { ITwith }
'stdcall' { ITstdcallconv }
'ccall' { ITccallconv }
+ 'dotnet' { ITdotnet }
'_ccall_' { ITccall (False, False, PlayRisky) }
'_ccall_GC_' { ITccall (False, False, PlaySafe) }
'_casm_' { ITccall (False, True, PlayRisky) }
(groupBindings $4)
in RdrHsDecl (InstD (InstDecl $3 binds sigs Nothing $1)) }
- | srcloc 'default' '(' types0 ')'
- { RdrHsDecl (DefD (DefaultDecl $4 $1)) }
+ | srcloc 'default' '(' types0 ')' { RdrHsDecl (DefD (DefaultDecl $4 $1)) }
+ | 'foreign' fordecl { RdrHsDecl $2 }
+ | '{-# DEPRECATED' deprecations '#-}' { $2 }
+ | '{-# RULES' rules '#-}' { $2 }
+ | decl { $1 }
- | srcloc 'foreign' 'import' callconv ext_name
- unsafe_flag varid_no_unsafe '::' sigtype
- { RdrHsDecl (ForD (ForeignDecl $7 (FoImport $6) $9 (mkExtName $5 $7) $4 $1)) }
+fordecl :: { RdrNameHsDecl }
+fordecl : srcloc 'label' ext_name varid '::' sigtype
+ { ForD (ForeignImport $4 $6 (LblImport ($3 `orElse` mkExtName $4)) $1) }
- | srcloc 'foreign' 'export' callconv ext_name varid '::' sigtype
- { RdrHsDecl (ForD (ForeignDecl $6 FoExport $8 (mkExtName $5 $6) $4 $1)) }
- | srcloc 'foreign' 'label' ext_name varid '::' sigtype
- { RdrHsDecl (ForD (ForeignDecl $5 FoLabel $7 (mkExtName $4 $5)
- defaultCCallConv $1)) }
+ ----------- ccall/stdcall decls ------------
+ | srcloc 'import' ccallconv ext_name unsafe_flag varid_no_unsafe '::' sigtype
+ { let
+ call_spec = CCallSpec (StaticTarget ($4 `orElse` mkExtName $6)) $3 $5
+ in
+ ForD (ForeignImport $6 $8 (CImport call_spec) $1)
+ }
- | '{-# DEPRECATED' deprecations '#-}' { $2 }
- | '{-# RULES' rules '#-}' { $2 }
- | decl { $1 }
+ | srcloc 'import' ccallconv 'dynamic' unsafe_flag varid_no_unsafe '::' sigtype
+ { let
+ call_spec = CCallSpec DynamicTarget $3 $5
+ in
+ ForD (ForeignImport $6 $8 (CImport call_spec) $1)
+ }
+
+ | srcloc 'export' ccallconv ext_name varid '::' sigtype
+ { ForD (ForeignExport $5 $7 (CExport (CExportStatic ($4 `orElse` mkExtName $5) $3)) $1) }
+
+ | srcloc 'export' ccallconv 'dynamic' varid '::' sigtype
+ { ForD (ForeignImport $5 $7 (CDynImport $3) $1) }
+
+
+ ----------- .NET decls ------------
+ | srcloc 'import' 'dotnet' ext_name varid '::' sigtype
+ { ForD (ForeignImport $5 $7 (DNImport (DNCallSpec ($4 `orElse` mkExtName $5))) $1) }
+
+ | srcloc 'import' 'dotnet' 'type' tycon
+ { TyClD (ForeignType $5 DNType $1) }
decls :: { [RdrBinding] }
: decls ';' decl { $3 : $1 }
-----------------------------------------------------------------------------
-- Foreign import/export
-callconv :: { CCallConv }
+ccallconv :: { CCallConv }
: 'stdcall' { StdCallConv }
| 'ccall' { CCallConv }
| {- empty -} { defaultCCallConv }
: 'unsafe' { PlayRisky }
| {- empty -} { PlaySafe }
-ext_name :: { Maybe ExtName }
- : 'dynamic' { Just Dynamic }
- | STRING { Just (ExtName $1 Nothing) }
- | STRING STRING { Just (ExtName $2 (Just $1)) }
+ext_name :: { Maybe CLabelString }
+ : STRING { Just $1 }
| {- empty -} { Nothing }
ForeignCall(..),
Safety(..), playSafe,
- CCallSpec(..), ccallIsCasm,
- CCallTarget(..), dynamicTarget, isDynamicTarget,
+ CExportSpec(..),
+ CCallSpec(..),
+ CCallTarget(..), isDynamicTarget, isCasmTarget,
CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,
- DotNetCallSpec(..)
+ DNCallSpec(..),
+
+ okToExposeFCall
) where
#include "HsVersions.h"
import CStrings ( CLabelString, pprCLabelString )
+import FastString ( FastString )
import Outputable
\end{code}
\begin{code}
data ForeignCall
= CCall CCallSpec
- | DotNetCall DotNetCallSpec
+ | DNCall DNCallSpec
deriving( Eq ) -- We compare them when seeing if an interface
-- has changed (for versioning purposes)
-- but this simple printer will do for now
instance Outputable ForeignCall where
ppr (CCall cc) = ppr cc
- ppr (DotNetCall dn) = ppr dn
+ ppr (DNCall dn) = ppr dn
\end{code}
%************************************************************************
\begin{code}
+data CExportSpec
+ = CExportStatic -- foreign export ccall foo :: ty
+ CLabelString -- C Name of exported function
+ CCallConv
+
data CCallSpec
= CCallSpec CCallTarget -- What to call
CCallConv -- Calling convention to use.
Safety
- Bool -- True <=> really a "casm"
deriving( Eq )
-
-
-ccallIsCasm :: CCallSpec -> Bool
-ccallIsCasm (CCallSpec _ _ _ c_asm) = c_asm
\end{code}
The call target:
data CCallTarget
= StaticTarget CLabelString -- An "unboxed" ccall# to `fn'.
| DynamicTarget -- First argument (an Addr#) is the function pointer
+ | CasmTarget CLabelString -- Inline C code (now seriously deprecated)
deriving( Eq )
-isDynamicTarget DynamicTarget = True
-isDynamicTarget (StaticTarget _) = False
+isDynamicTarget, isCasmTarget :: CCallTarget -> Bool
+isDynamicTarget DynamicTarget = True
+isDynamicTarget other = False
-dynamicTarget :: CCallTarget
-dynamicTarget = DynamicTarget
+isCasmTarget (CasmTarget _) = True
+isCasmTarget other = False
\end{code}
Printing into C files:
\begin{code}
+instance Outputable CExportSpec where
+ ppr (CExportStatic str _) = pprCLabelString str
+
instance Outputable CCallSpec where
- ppr (CCallSpec fun cconv safety is_casm)
- = hcat [ ifPprDebug callconv
- , text "__", ppr_dyn
- , text before , ppr_fun , after]
+ ppr (CCallSpec fun cconv safety)
+ = hcat [ ifPprDebug callconv, ppr_fun fun ]
where
- callconv = text "{-" <> ppr cconv <> text "-}"
- play_safe = playSafe safety
-
- before
- | is_casm && play_safe = "casm_GC ``"
- | is_casm = "casm ``"
- | play_safe = "ccall_GC "
- | otherwise = "ccall "
-
- after
- | is_casm = text "''"
- | otherwise = empty
-
- ppr_dyn = case fun of
- DynamicTarget -> text "dyn_"
- _ -> empty
-
- ppr_fun = case fun of
- DynamicTarget -> text "\"\""
- StaticTarget fn -> pprCLabelString fn
+ callconv = text "{-" <> ppr cconv <> text "-}"
+
+ gc_suf | playSafe safety = text "_GC"
+ | otherwise = empty
+
+ ppr_fun DynamicTarget = text "__dyn_ccall" <> gc_suf <+> text "\"\""
+ ppr_fun (StaticTarget fn) = text "__ccall" <> gc_suf <+> pprCLabelString fn
+ ppr_fun (CasmTarget fn) = text "__casm" <> gc_suf <+> text "``" <> pprCLabelString fn <> text "''"
\end{code}
%************************************************************************
\begin{code}
-data DotNetCallSpec = DotNetCallSpec
+data DNCallSpec = DNCallSpec FastString
deriving( Eq )
-instance Outputable DotNetCallSpec where
- ppr DotNetCallSpec = text "DotNet!"
+instance Outputable DNCallSpec where
+ ppr (DNCallSpec s) = text "DotNet" <+> ptext s
+\end{code}
+
+
+
+%************************************************************************
+%* *
+\subsubsection{Misc}
+%* *
+%************************************************************************
+
+\begin{code}
+okToExposeFCall :: ForeignCall -> Bool
+-- OK to unfold a Foreign Call in an interface file
+-- Yes, unless it's a _casm_
+okToExposeFCall (CCall (CCallSpec target _ _)) = not (isCasmTarget target)
+okToExposeFCall other = True
\end{code}
int64PrimTyCon, int64PrimTy,
word64PrimTyCon, word64PrimTy,
- primRepTyCon,
-
- pcPrimTyCon
+ primRepTyCon
) where
#include "HsVersions.h"
\begin{code}
-- only used herein
-pcPrimTyCon :: Name -> Int -> ArgVrcs -> PrimRep -> TyCon
-pcPrimTyCon name arity arg_vrcs rep
- = the_tycon
+pcPrimTyCon :: Name -> ArgVrcs -> PrimRep -> TyCon
+pcPrimTyCon name arg_vrcs rep
+ = mkPrimTyCon name kind arity arg_vrcs rep
where
- the_tycon = mkPrimTyCon name kind arity arg_vrcs rep
+ arity = length arg_vrcs
kind = mkArrowKinds (take arity (repeat liftedTypeKind)) result_kind
result_kind = unliftedTypeKind -- all primitive types are unlifted
+pcPrimTyCon0 :: Name -> PrimRep -> TyCon
+pcPrimTyCon0 name rep
+ = mkPrimTyCon name result_kind 0 [] rep
+ where
+ result_kind = unliftedTypeKind -- all primitive types are unlifted
+
charPrimTy = mkTyConTy charPrimTyCon
-charPrimTyCon = pcPrimTyCon charPrimTyConName 0 [] CharRep
+charPrimTyCon = pcPrimTyCon0 charPrimTyConName CharRep
intPrimTy = mkTyConTy intPrimTyCon
-intPrimTyCon = pcPrimTyCon intPrimTyConName 0 [] IntRep
+intPrimTyCon = pcPrimTyCon0 intPrimTyConName IntRep
int64PrimTy = mkTyConTy int64PrimTyCon
-int64PrimTyCon = pcPrimTyCon int64PrimTyConName 0 [] Int64Rep
+int64PrimTyCon = pcPrimTyCon0 int64PrimTyConName Int64Rep
wordPrimTy = mkTyConTy wordPrimTyCon
-wordPrimTyCon = pcPrimTyCon wordPrimTyConName 0 [] WordRep
+wordPrimTyCon = pcPrimTyCon0 wordPrimTyConName WordRep
word64PrimTy = mkTyConTy word64PrimTyCon
-word64PrimTyCon = pcPrimTyCon word64PrimTyConName 0 [] Word64Rep
+word64PrimTyCon = pcPrimTyCon0 word64PrimTyConName Word64Rep
addrPrimTy = mkTyConTy addrPrimTyCon
-addrPrimTyCon = pcPrimTyCon addrPrimTyConName 0 [] AddrRep
+addrPrimTyCon = pcPrimTyCon0 addrPrimTyConName AddrRep
floatPrimTy = mkTyConTy floatPrimTyCon
-floatPrimTyCon = pcPrimTyCon floatPrimTyConName 0 [] FloatRep
+floatPrimTyCon = pcPrimTyCon0 floatPrimTyConName FloatRep
doublePrimTy = mkTyConTy doublePrimTyCon
-doublePrimTyCon = pcPrimTyCon doublePrimTyConName 0 [] DoubleRep
+doublePrimTyCon = pcPrimTyCon0 doublePrimTyConName DoubleRep
\end{code}
\begin{code}
mkStatePrimTy ty = mkTyConApp statePrimTyCon [ty]
-statePrimTyCon = pcPrimTyCon statePrimTyConName 1 vrcsZ VoidRep
+statePrimTyCon = pcPrimTyCon statePrimTyConName vrcsZ VoidRep
\end{code}
RealWorld is deeply magical. It is *primitive*, but it is not
%************************************************************************
\begin{code}
-arrayPrimTyCon = pcPrimTyCon arrayPrimTyConName 1 vrcsP ArrayRep
-byteArrayPrimTyCon = pcPrimTyCon byteArrayPrimTyConName 0 [] ByteArrayRep
-mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConName 2 vrcsZP ArrayRep
-mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConName 1 vrcsZ ByteArrayRep
+arrayPrimTyCon = pcPrimTyCon arrayPrimTyConName vrcsP ArrayRep
+mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConName vrcsZP ArrayRep
+mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConName vrcsZ ByteArrayRep
+byteArrayPrimTyCon = pcPrimTyCon0 byteArrayPrimTyConName ByteArrayRep
mkArrayPrimTy elt = mkTyConApp arrayPrimTyCon [elt]
byteArrayPrimTy = mkTyConTy byteArrayPrimTyCon
%************************************************************************
\begin{code}
-mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName 2 vrcsZP PrimPtrRep
+mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName vrcsZP PrimPtrRep
mkMutVarPrimTy s elt = mkTyConApp mutVarPrimTyCon [s, elt]
\end{code}
%************************************************************************
\begin{code}
-mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName 2 vrcsZP PrimPtrRep
+mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName vrcsZP PrimPtrRep
mkMVarPrimTy s elt = mkTyConApp mVarPrimTyCon [s, elt]
\end{code}
%************************************************************************
\begin{code}
-stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName 1 vrcsP StablePtrRep
+stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName vrcsP StablePtrRep
mkStablePtrPrimTy ty = mkTyConApp stablePtrPrimTyCon [ty]
\end{code}
%************************************************************************
\begin{code}
-stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName 1 vrcsP StableNameRep
+stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName vrcsP StableNameRep
mkStableNamePrimTy ty = mkTyConApp stableNamePrimTyCon [ty]
\end{code}
\begin{code}
foreignObjPrimTy = mkTyConTy foreignObjPrimTyCon
-foreignObjPrimTyCon = pcPrimTyCon foreignObjPrimTyConName 0 [] ForeignObjRep
+foreignObjPrimTyCon = pcPrimTyCon0 foreignObjPrimTyConName ForeignObjRep
\end{code}
%************************************************************************
\begin{code}
bcoPrimTy = mkTyConTy bcoPrimTyCon
-bcoPrimTyCon = pcPrimTyCon bcoPrimTyConName 0 [] BCORep
+bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName BCORep
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-weakPrimTyCon = pcPrimTyCon weakPrimTyConName 1 vrcsP WeakPtrRep
+weakPrimTyCon = pcPrimTyCon weakPrimTyConName vrcsP WeakPtrRep
mkWeakPrimTy v = mkTyConApp weakPrimTyCon [v]
\end{code}
\begin{code}
threadIdPrimTy = mkTyConTy threadIdPrimTyCon
-threadIdPrimTyCon = pcPrimTyCon threadIdPrimTyConName 0 [] ThreadIdRep
+threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName ThreadIdRep
\end{code}
%************************************************************************
{ IfaceSig $2 $4 ($5 $2) $1 }
| src_loc 'type' qtc_name tv_bndrs '=' type
{ TySynonym $3 $4 $6 $1 }
+ | src_loc 'foreign' 'type' qtc_name
+ { ForeignType $4 DNType $1 }
| src_loc 'data' opt_decl_context qtc_name tv_bndrs constrs
{ mkTyData DataType $3 $4 $5 $6 (length $6) Nothing $1 }
| src_loc 'newtype' opt_decl_context qtc_name tv_bndrs newtype_constr
(is_dyn, is_casm, may_gc) = $2
target | is_dyn = DynamicTarget
+ | is_casm = CasmTarget $3
| otherwise = StaticTarget $3
- ccall = CCallSpec target CCallConv may_gc is_casm
+ ccall = CCallSpec target CCallConv may_gc
in
UfFCall (CCall ccall) $4
}
\begin{code}
tyClDeclFVs :: RenamedTyClDecl -> NameSet
+tyClDeclFVs (ForeignType {})
+ = emptyFVs
+
tyClDeclFVs (IfaceSig {tcdType = ty, tcdIdInfo = id_infos})
= extractHsTyNames ty `plusFV`
plusFVs (map hsIdInfoFVs id_infos)
getGates source_fvs decl
= get_gates (\n -> n `elemNameSet` source_fvs) decl
-get_gates is_used (IfaceSig {tcdType = ty}) = extractHsTyNames ty
+get_gates is_used (ForeignType {tcdName = tycon}) = unitNameSet tycon
+get_gates is_used (IfaceSig {tcdType = ty}) = extractHsTyNames ty
get_gates is_used (ClassDecl { tcdCtxt = ctxt, tcdName = cls, tcdTyVars = tvs, tcdSigs = sigs})
= (super_cls_and_sigs `addOneToNameSet` cls) `unionNameSets`
import CmdLineOpts ( DynFlag(..) )
import HsSyn ( HsModule(..), HsDecl(..), IE(..), ieName, ImportDecl(..),
- ForeignDecl(..), ForKind(..), isDynamicExtName,
+ ForeignDecl(..),
collectLocatedHsBinders
)
import RdrHsSyn ( RdrNameIE, RdrNameImportDecl,
new (rdr_name, loc) = newTopBinder mod rdr_name loc `thenRn` \ name ->
returnRn (Avail name)
-getLocalDeclBinders mod (ForD (ForeignDecl nm kind _ ext_nm _ loc))
- | binds_haskell_name kind
+getLocalDeclBinders mod (ForD (ForeignImport nm _ _ loc))
= newTopBinder mod nm loc `thenRn` \ name ->
returnRn [Avail name]
-
- | otherwise -- a foreign export
+getLocalDeclBinders mod (ForD _)
= returnRn []
- where
- binds_haskell_name (FoImport _) = True
- binds_haskell_name FoLabel = True
- binds_haskell_name FoExport = isDynamicExtName ext_nm
getLocalDeclBinders mod (FixD _) = returnRn []
getLocalDeclBinders mod (DeprecD _) = returnRn []
-- Warn of unused for-all'd tyvars
import Unique ( Uniquable(..) )
import Maybes ( maybeToBool )
-import ErrUtils ( Message )
-import CStrings ( isCLabelString )
import ListSetOps ( removeDupsEq )
\end{code}
= rnHsRuleDecl rule `thenRn` \ (new_rule, fvs) ->
returnRn (RuleD new_rule, fvs)
+rnSourceDecl (ForD ford)
+ = rnHsForeignDecl ford `thenRn` \ (new_ford, fvs) ->
+ returnRn (ForD new_ford, fvs)
+
rnSourceDecl (DefD (DefaultDecl tys src_loc))
= pushSrcLocRn src_loc $
mapFvRn (rnHsTypeFVs doc_str) tys `thenRn` \ (tys', fvs) ->
returnRn (DefD (DefaultDecl tys' src_loc), fvs)
where
doc_str = text "a `default' declaration"
+\end{code}
-rnSourceDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
- = pushSrcLocRn src_loc $
- lookupOccRn name `thenRn` \ name' ->
- let
- extra_fvs FoExport
- | isDyn = lookupOrigNames [newStablePtr_RDR, deRefStablePtr_RDR,
- bindIO_RDR, returnIO_RDR]
- | otherwise =
- lookupOrigNames [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs ->
- returnRn (addOneFV fvs name')
- extra_fvs other = returnRn emptyFVs
- in
- checkRn (ok_ext_nm ext_nm) (badExtName ext_nm) `thenRn_`
- extra_fvs imp_exp `thenRn` \ fvs1 ->
+%*********************************************************
+%* *
+\subsection{Foreign declarations}
+%* *
+%*********************************************************
+
+\begin{code}
+rnHsForeignDecl (ForeignImport name ty spec src_loc)
+ = pushSrcLocRn src_loc $
+ lookupOccRn name `thenRn` \ name' ->
+ rnHsTypeFVs (fo_decl_msg name) ty `thenRn` \ (ty', fvs1) ->
+ lookupOrigNames (extras spec) `thenRn` \ fvs2 ->
+ returnRn (ForeignImport name' ty' spec src_loc, fvs1 `plusFV` fvs2)
+ where
+ extras (CDynImport _) = [newStablePtr_RDR, deRefStablePtr_RDR, bindIO_RDR, returnIO_RDR]
+ extras other = []
- rnHsTypeFVs fo_decl_msg ty `thenRn` \ (ty', fvs2) ->
- returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc),
- fvs1 `plusFV` fvs2)
- where
- fo_decl_msg = ptext SLIT("The foreign declaration for") <+> ppr name
- isDyn = isDynamicExtName ext_nm
+rnHsForeignDecl (ForeignExport name ty spec src_loc)
+ = pushSrcLocRn src_loc $
+ lookupOccRn name `thenRn` \ name' ->
+ rnHsTypeFVs (fo_decl_msg name) ty `thenRn` \ (ty', fvs1) ->
+ lookupOrigNames [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs2 ->
+ returnRn (ForeignExport name' ty' spec src_loc, fvs1 `plusFV` fvs2)
- ok_ext_nm Dynamic = True
- ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb
- ok_ext_nm (ExtName nm Nothing) = isCLabelString nm
+fo_decl_msg name = ptext SLIT("The foreign declaration for") <+> ppr name
\end{code}
where
doc_str = text "the interface signature for" <+> quotes (ppr name)
+rnTyClDecl (ForeignType {tcdName = name, tcdFoType = spec, tcdLoc = loc})
+ = pushSrcLocRn loc $
+ lookupTopBndrRn name `thenRn` \ name' ->
+ returnRn (ForeignType {tcdName = name', tcdFoType = spec, tcdLoc = loc})
+
rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = nconstrs,
tcdLoc = src_loc, tcdSysNames = sys_names})
meth_doc = text "the default-methods for class" <+> ppr (tcdName rn_cls_decl)
finishSourceTyClDecl _ tycl_decl = returnRn (tycl_decl, emptyFVs)
- -- Not a class declaration
+ -- Not a class or data type declaration
\end{code}
ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
ptext SLIT("does not appear on left hand side")]
-badExtName :: ExtName -> Message
-badExtName ext_nm
- = sep [quotes (ppr ext_nm) <+> ptext SLIT("is not a valid C identifier")]
-
dupClassAssertWarn ctxt (assertion : dups)
= sep [hsep [ptext SLIT("Duplicate class assertion"),
quotes (ppr assertion),
data TyThingDetails = SynTyDetails Type
| DataTyDetails ThetaType [DataCon] [Id]
| ClassDetails ThetaType [Id] [ClassOpItem] DataCon
+ | ForeignTyDetails -- Nothing yet
\end{code}
#include "HsVersions.h"
import HsSyn ( HsDecl(..), ForeignDecl(..), HsExpr(..),
- ExtName(Dynamic), isDynamicExtName, MonoBinds(..),
- ForKind(..)
+ MonoBinds(..), FoImport(..), FoExport(..)
)
import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl )
isFFILabelTy
)
import Type ( Type )
-import ForeignCall ( Safety )
+import ForeignCall ( CCallSpec(..), CExportSpec(..), CCallTarget(..), isDynamicTarget )
+import CStrings ( CLabelString, isCLabelString )
import PrelNames ( hasKey, ioTyConKey )
import Outputable
\end{code}
\begin{code}
+-- Defines a binding
+isForeignImport :: ForeignDecl name -> Bool
+isForeignImport (ForeignImport _ _ _ _) = True
+isForeignImport _ = False
+
+-- Exports a binding
+isForeignExport :: ForeignDecl name -> Bool
+isForeignExport (ForeignExport _ _ _ _) = True
+isForeignExport _ = False
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Imports}
+%* *
+%************************************************************************
+
+\begin{code}
tcForeignImports :: [RenamedHsDecl] -> TcM ([Id], [TypecheckedForeignDecl])
tcForeignImports decls =
mapAndUnzipTc tcFImport [ foreign_decl | ForD foreign_decl <- decls, isForeignImport foreign_decl]
+tcFImport :: RenamedForeignDecl -> TcM (Id, TypecheckedForeignDecl)
+tcFImport fo@(ForeignImport nm hs_ty imp_decl src_loc)
+ = tcAddSrcLoc src_loc $
+ tcAddErrCtxt (foreignDeclCtxt fo) $
+ tcHsLiftedSigType hs_ty `thenTc` \ sig_ty ->
+ let
+ -- drop the foralls before inspecting the structure
+ -- of the foreign type.
+ (_, t_ty) = splitForAllTys sig_ty
+ (arg_tys, res_ty) = splitFunTys t_ty
+ id = mkLocalId nm sig_ty
+ in
+ tcCheckFIType sig_ty arg_tys res_ty imp_decl `thenNF_Tc_`
+ returnTc (id, ForeignImport id undefined imp_decl src_loc)
+\end{code}
+
+
+------------ Checking types for foreign import ----------------------
+\begin{code}
+tcCheckFIType _ _ _ (DNImport _)
+ = returnNF_Tc () -- No error checking yet
+
+tcCheckFIType sig_ty arg_tys res_ty (LblImport _)
+ = check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty)
+
+tcCheckFIType sig_ty arg_tys res_ty (CDynImport _)
+ = -- Foreign export dynamic
+ -- The first (and only!) arg has got to be a function type
+ -- and it must return IO t; result type is IO Addr
+ case arg_tys of
+ [arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys `thenNF_Tc_`
+ checkForeignRes nonIOok isFFIExportResultTy res1_ty `thenNF_Tc_`
+ checkForeignRes mustBeIO isFFIDynResultTy res_ty
+ where
+ (arg1_tys, res1_ty) = splitFunTys arg1_ty
+ other -> addErrTc (illegalForeignTyErr empty sig_ty)
+
+tcCheckFIType sig_ty arg_tys res_ty (CImport (CCallSpec target _ safety))
+ | isDynamicTarget target -- Foreign import dynamic
+ = case arg_tys of -- The first arg must be Addr
+ [] -> check False (illegalForeignTyErr empty sig_ty)
+ (arg1_ty:arg_tys) -> getDOptsTc `thenNF_Tc` \ dflags ->
+ check (isFFIDynArgumentTy arg1_ty)
+ (illegalForeignTyErr argument arg1_ty) `thenNF_Tc_`
+ checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenNF_Tc_`
+ checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
+
+ | otherwise -- Normal foreign import
+ = getDOptsTc `thenNF_Tc` \ dflags ->
+ checkCTarget target `thenNF_Tc_`
+ checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenNF_Tc_`
+ checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
+
+-- This makes a convenient place to check
+-- that the C identifier is valid for C
+checkCTarget (StaticTarget str) | not (isCLabelString str) = addErrTc (badCName str)
+checkCTarget other = returnNF_Tc ()
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Exports}
+%* *
+%************************************************************************
+
+\begin{code}
tcForeignExports :: [RenamedHsDecl] -> TcM (LIE, TcMonoBinds, [TcForeignExportDecl])
tcForeignExports decls =
foldlTc combine (emptyLIE, EmptyMonoBinds, [])
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 _ k _ dyn _ _) =
- case k of
- FoImport _ -> True
- FoExport -> case dyn of { Dynamic -> True ; _ -> False }
- FoLabel -> True
-
--- exports a binding
-isForeignExport :: ForeignDecl name -> Bool
-isForeignExport (ForeignDecl _ FoExport _ ext_nm _ _) = not (isDynamicExtName ext_nm)
-isForeignExport _ = False
-
-\end{code}
-
-\begin{code}
-tcFImport :: RenamedForeignDecl -> TcM (Id, TypecheckedForeignDecl)
-tcFImport fo@(ForeignDecl nm FoExport hs_ty Dynamic cconv src_loc) =
- tcAddSrcLoc src_loc $
- tcAddErrCtxt (foreignDeclCtxt fo) $
- tcHsLiftedSigType 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 = (mkLocalId 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) $
- tcHsLiftedSigType hs_ty `thenTc` \ sig_ty ->
- let
- -- drop the foralls before inspecting the structure
- -- of the foreign type.
- (_, t_ty) = splitForAllTys sig_ty
- in
- check (isFFILabelTy t_ty)
- (illegalForeignTyErr False{-result-} sig_ty) `thenTc_`
- let i = (mkLocalId nm sig_ty) in
- returnTc (i, (ForeignDecl i FoLabel undefined ext_nm cconv src_loc))
-
-tcFImport fo@(ForeignDecl nm imp_exp@(FoImport safety) hs_ty ext_nm cconv src_loc) =
- tcAddSrcLoc src_loc $
- tcAddErrCtxt (foreignDeclCtxt fo) $
-
- tcHsLiftedSigType 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 (isDynamicExtName ext_nm) safety ty arg_tys res_ty `thenTc_`
- let i = (mkLocalId nm ty) in
- returnTc (i, (ForeignDecl i imp_exp undefined ext_nm cconv src_loc))
-
tcFExport :: RenamedForeignDecl -> TcM (LIE, TcMonoBinds, TcForeignExportDecl)
-tcFExport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
- tcAddSrcLoc src_loc $
- tcAddErrCtxt (foreignDeclCtxt fo) $
+tcFExport fo@(ForeignExport nm hs_ty spec src_loc) =
+ tcAddSrcLoc src_loc $
+ tcAddErrCtxt (foreignDeclCtxt fo) $
tcHsLiftedSigType hs_ty `thenTc` \ sig_ty ->
- tcPolyExpr (HsVar nm) sig_ty `thenTc` \ (rhs, lie, _, _, _) ->
+ tcPolyExpr (HsVar nm) sig_ty `thenTc` \ (rhs, lie, _, _, _) ->
+
+ tcCheckFEType sig_ty spec `thenTc_`
- 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_ty src_loc `thenNF_Tc` \ i ->
- let
- bind = VarMonoBind i rhs
- in
- returnTc (lie, bind, ForeignDecl i imp_exp undefined ext_nm cconv src_loc)
- -- ^^^^^^^^^
- -- ToDo: fill the type field in with something sensible.
+ newLocalId (nameOccName nm) sig_ty src_loc `thenNF_Tc` \ id ->
+ let
+ bind = VarMonoBind id rhs
+ in
+ returnTc (lie, bind, ForeignExport id undefined spec src_loc)
+\end{code}
+
+------------ Checking argument types for foreign export ----------------------
+\begin{code}
+tcCheckFEType sig_ty (CExport (CExportStatic str _))
+ = check (isCLabelString str) (badCName str) `thenNF_Tc_`
+ checkForeignArgs isFFIExternalTy arg_tys `thenNF_Tc_`
+ checkForeignRes nonIOok isFFIExportResultTy res_ty
+ where
+ -- Drop the foralls before inspecting n
+ -- the structure of the foreign type.
+ (_, t_ty) = splitForAllTys sig_ty
+ (arg_tys, res_ty) = splitFunTys t_ty
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Miscellaneous}
+%* *
+%************************************************************************
+
\begin{code}
-checkForeignImport :: Bool -> Safety -> Type -> [Type] -> Type -> TcM ()
-checkForeignImport is_dynamic safety ty args res
- | is_dynamic =
- -- * first arg has got to be an Addr
- case args of
- [] -> check False (illegalForeignTyErr True{-Arg-} ty)
- (x:xs) ->
- getDOptsTc `thenTc` \ dflags ->
- check (isFFIDynArgumentTy x) (illegalForeignTyErr True{-Arg-} ty) `thenTc_`
- mapTc (checkForeignArg (isFFIArgumentTy dflags safety)) xs `thenTc_`
- checkForeignRes True {-NonIO ok-} (isFFIImportResultTy dflags) res
- | otherwise =
- getDOptsTc `thenTc` \ dflags ->
- mapTc (checkForeignArg (isFFIArgumentTy dflags safety)) args `thenTc_`
- checkForeignRes True {-NonIO ok-} (isFFIImportResultTy dflags) res
-
-checkForeignExport :: Bool -> Type -> [Type] -> Type -> TcM ()
-checkForeignExport is_dynamic ty args res
- | is_dynamic =
- -- * the first (and only!) arg has got to be a function type
- -- and it must return IO t
- -- * result type is IO Addr
- case args of
- [arg] ->
- case splitFunTys arg of
- (arg_tys, res_ty) ->
- mapTc (checkForeignArg isFFIExternalTy) arg_tys `thenTc_`
- checkForeignRes True {-NonIO ok-} isFFIExportResultTy res_ty
- `thenTc_`
- checkForeignRes False {-Must be IO-} isFFIDynResultTy res
- _ -> check False (illegalForeignTyErr True{-Arg-} ty)
- | otherwise =
- mapTc (checkForeignArg isFFIExternalTy) args `thenTc_`
- checkForeignRes True {-NonIO ok-} isFFIExportResultTy res
-
-checkForeignArg :: (Type -> Bool) -> Type -> TcM ()
-checkForeignArg pred ty = check (pred ty) (illegalForeignTyErr True{-Arg-} ty)
+------------ Checking argument types for foreign import ----------------------
+checkForeignArgs :: (Type -> Bool) -> [Type] -> NF_TcM ()
+checkForeignArgs pred tys
+ = mapNF_Tc go tys `thenNF_Tc_` returnNF_Tc ()
+ where
+ go ty = check (pred ty) (illegalForeignTyErr argument ty)
+
+------------ Checking result types for foreign calls ----------------------
-- Check that the type has the form
-- (IO t) or (t) , and that t satisfies the given predicate.
--
-checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
+checkForeignRes :: Bool -> (Type -> Bool) -> Type -> NF_TcM ()
+
+nonIOok = True
+mustBeIO = False
+
checkForeignRes non_io_result_ok pred_res_ty ty =
case (splitTyConApp_maybe ty) of
Just (io, [res_ty])
| io `hasKey` ioTyConKey && pred_res_ty res_ty
- -> returnTc ()
+ -> returnNF_Tc ()
_
-> check (non_io_result_ok && pred_res_ty ty)
- (illegalForeignTyErr False{-Res-} ty)
+ (illegalForeignTyErr result ty)
\end{code}
Warnings
\begin{code}
-check :: Bool -> Message -> TcM ()
+check :: Bool -> Message -> NF_TcM ()
check True _ = returnTc ()
-check _ the_err = addErrTc the_err `thenNF_Tc_` returnTc ()
+check _ the_err = addErrTc the_err
-illegalForeignTyErr isArg ty
+illegalForeignTyErr arg_or_res ty
= hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, ptext SLIT("type in foreign declaration:")])
4 (hsep [ppr ty])
- where
- arg_or_res
- | isArg = ptext SLIT("argument")
- | otherwise = ptext SLIT("result")
-foreignDeclCtxt fo =
- hang (ptext SLIT("When checking declaration:"))
- 4 (ppr fo)
+-- Used for 'arg_or_res' argument to illegalForeignTyErr
+argument = text "argument"
+result = text "result"
+
+badCName :: CLabelString -> Message
+badCName target = sep [quotes (ppr target) <+> ptext SLIT("is not a valid C identifier")]
+
+foreignDeclCtxt fo
+ = hang (ptext SLIT("When checking declaration:"))
+ 4 (ppr fo)
\end{code}
zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl)
-zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) =
+zonkForeignExport (ForeignExport i hs_ty spec src_loc) =
zonkIdOcc i `thenNF_Tc` \ i' ->
- returnNF_Tc (ForeignDecl i' imp_exp undefined ext_nm cconv src_loc)
+ returnNF_Tc (ForeignExport i' undefined spec src_loc)
\end{code}
\begin{code}
tcExtendTyVarEnvForMeths,
tcAddImportedIdInfo, tcLookupClass,
InstInfo(..), pprInstInfo, simpleInstInfoTyCon,
- simpleInstInfoTy, newDFunName, tcExtendTyVarEnv,
+ simpleInstInfoTy, newDFunName,
isLocalThing,
)
import InstEnv ( InstEnv, extendInstEnv )
tcModule pcs hst get_fixity this_mod decls
= fixTc (\ ~(unf_env, _, _) ->
- -- Loop back the final environment, including the fully zonkec
+ -- Loop back the final environment, including the fully zonked
-- versions of bindings from this module. In the presence of mutual
-- recursion, interface type signatures may mention variables defined
-- in this module, which is why the knot is so big
import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
import HsSyn ( TyClDecl(..),
ConDecl(..), Sig(..), HsPred(..),
- tyClDeclName, hsTyVarNames,
+ tyClDeclName, hsTyVarNames, tyClDeclTyVars,
isIfaceSigDecl, isClassDecl, isSynDecl, isClassOpSig
)
import RnHsSyn ( RenamedTyClDecl, tyClDeclFVs )
import TcUnify ( unifyKind )
import TcInstDcls ( tcAddDeclCtxt )
-import Type ( Kind, mkArrowKind, zipFunTys )
+import Type ( Kind, mkArrowKind, liftedTypeKind, zipFunTys )
import Variance ( calcTyConArgVrcs )
import Class ( Class, mkClass, classTyCon )
import TyCon ( TyCon, tyConKind, ArgVrcs, AlgTyConFlavour(..),
- mkSynTyCon, mkAlgTyCon, mkClassTyCon )
+ mkSynTyCon, mkAlgTyCon, mkClassTyCon, mkForeignTyCon )
import DataCon ( isNullaryDataCon )
import Var ( varName )
import FiniteMap
\begin{code}
getInitialKind :: RenamedTyClDecl -> NF_TcM (Name, TcKind)
getInitialKind decl
- = kcHsTyVars (tcdTyVars decl) `thenNF_Tc` \ arg_kinds ->
- newKindVar `thenNF_Tc` \ result_kind ->
+ = kcHsTyVars (tyClDeclTyVars decl) `thenNF_Tc` \ arg_kinds ->
+ newKindVar `thenNF_Tc` \ result_kind ->
returnNF_Tc (tcdName decl, mk_kind arg_kinds result_kind)
mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds
kcHsType rhs `thenTc` \ rhs_kind ->
unifyKind result_kind rhs_kind
+kcTyClDecl (ForeignType {}) = returnTc ()
+
kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = context, tcdCons = con_decls})
= kcTyClDeclBody decl $ \ result_kind ->
kcHsContext context `thenTc_`
AThing kind -> kind
-- For some odd reason, a class doesn't include its kind
- (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames (tcdTyVars decl)) kind
+ (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames (tyClDeclTyVars decl)) kind
in
tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind)
\end{code}
| otherwise -> DataTyCon
buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
+ (ForeignType {tcdName = tycon_name})
+ = ATyCon (mkForeignTyCon tycon_name liftedTypeKind 0 [])
+
+buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
(ClassDecl {tcdName = class_name, tcdTyVars = tyvar_names,
tcdFDs = fundeps, tcdSysNames = name_list} )
= AClass clas
mapTc (tcConDecl is_rec new_or_data tycon tyvars ctxt) con_decls `thenTc` \ data_cons ->
tcRecordSelectors is_rec unf_env tycon data_cons `thenTc` \ sel_ids ->
returnTc (tycon_name, DataTyDetails ctxt data_cons sel_ids)
+
+tcTyDecl1 is_rec unf_env (ForeignType {tcdName = tycon_name})
+ = returnTc (tycon_name, ForeignTyDetails)
\end{code}
\begin{code}
|| utc == addrPrimTyConKey) then 'i'
else if utc == floatPrimTyConKey then 'f'
else if utc == doublePrimTyConKey then 'd'
- else if isPrimTyCon tycon {- array, we hope -} then 'A'
+ else if isPrimTyCon tycon {- array, we hope -} then 'A' -- Bogus
else if isEnumerationTyCon tycon then 'E'
else if isTupleTyCon tycon then 'T'
else if maybeToBool (maybeTyConSingleCon tycon) then 'S'
isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,
isRecursiveTyCon, newTyConRep,
+ mkForeignTyCon, isForeignTyCon,
+
mkAlgTyCon, --mkAlgTyCon,
mkClassTyCon,
mkFunTyCon,
algTyConClass :: Maybe Class -- Just cl if this tycon came from a class declaration
}
- | PrimTyCon { -- Primitive types; cannot be defined in Haskell
- -- NB: All of these guys are *unlifted*, but not all are *unboxed*
+ | PrimTyCon { -- Primitive types; cannot be defined in Haskell
+ -- Now includes foreign-imported types
tyConUnique :: Unique,
tyConName :: Name,
tyConKind :: Kind,
tyConArity :: Arity,
tyConArgVrcs :: ArgVrcs,
- primTyConRep :: PrimRep
+ primTyConRep :: PrimRep, -- Many primitive tycons are unboxed, but some are
+ -- boxed (represented by pointers). The PrimRep tells.
+
+ isUnLifted :: Bool -- Most primitive tycons are unlifted,
+ -- but foreign-imported ones may not be
}
| TupleTyCon {
genInfo = gen_info
}
-mkPrimTyCon name kind arity arg_vrcs rep
+-- Foreign-imported (.NET) type constructors are represented
+-- as primitive, but *lifted*, TyCons for now.
+-- They have PtrRep
+mkForeignTyCon name kind arity arg_vrcs
= PrimTyCon {
- tyConName = name,
- tyConUnique = nameUnique name,
- tyConKind = kind,
- tyConArity = arity,
+ tyConName = name,
+ tyConUnique = nameUnique name,
+ tyConKind = kind,
+ tyConArity = arity,
tyConArgVrcs = arg_vrcs,
- primTyConRep = rep
+ primTyConRep = PtrRep,
+ isUnLifted = False
+ }
+
+
+mkPrimTyCon name kind arity arg_vrcs rep
+ = PrimTyCon {
+ tyConName = name,
+ tyConUnique = nameUnique name,
+ tyConKind = kind,
+ tyConArity = arity,
+ tyConArgVrcs = arg_vrcs,
+ primTyConRep = rep,
+ isUnLifted = True
}
mkSynTyCon name kind arity tyvars rhs argvrcs
isPrimTyCon (PrimTyCon {}) = True
isPrimTyCon _ = False
-isUnLiftedTyCon (PrimTyCon {}) = True
-isUnLiftedTyCon (TupleTyCon { tyConBoxed = boxity}) = not (isBoxed boxity)
-isUnLiftedTyCon _ = False
+isUnLiftedTyCon (PrimTyCon {isUnLifted = is_unlifted}) = is_unlifted
+isUnLiftedTyCon (TupleTyCon {tyConBoxed = boxity}) = not (isBoxed boxity)
+isUnLiftedTyCon _ = False
-- isBoxedTyCon should not be applied to SynTyCon, nor KindCon
isBoxedTyCon (AlgTyCon {}) = True
isRecursiveTyCon (AlgTyCon {algTyConRec = Recursive}) = True
isRecursiveTyCon other = False
+
+-- isForeignTyCon identifies foreign-imported type constructors
+-- For the moment, they are primitive but lifted, but that may change
+isForeignTyCon (PrimTyCon {isUnLifted = is_unlifted}) = not is_unlifted
+isForeignTyCon other = False
\end{code}
\begin{code}
getDFunTyKey,
-- Lifting and boxity
- isUnLiftedType, isUnboxedTupleType, isAlgType, isDataType, isNewType,
+ isUnLiftedType, isUnboxedTupleType, isAlgType,
+ isDataType, isNewType, isPrimitiveType,
-- Free variables
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
isFunTyCon, isDataTyCon, isNewTyCon, newTyConRep,
isAlgTyCon, isSynTyCon, tyConArity,
tyConKind, tyConDataCons, getSynTyConDefn,
- tyConPrimRep
+ tyConPrimRep, isPrimTyCon
)
-- others
Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
isNewTyCon tc
other -> False
+
+isPrimitiveType :: Type -> Bool
+-- Returns types that are opaque to Haskell.
+-- Most of these are unlifted, but now that we interact with .NET, we
+-- may have primtive (foreign-imported) types that are lifted
+isPrimitiveType ty = case splitTyConApp_maybe ty of
+ Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
+ isPrimTyCon tc
+ other -> False
\end{code}
projects / ghc-hetmet.git / commitdiff