From: simonpj Date: Thu, 24 May 2001 13:59:12 +0000 (+0000) Subject: [project @ 2001-05-24 13:59:09 by simonpj] X-Git-Tag: Approximately_9120_patches~1882 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=cbdeae8fc8a1c72d20d89241acae8a313214b51c;hp=f70aaa982380a9d210ca136983eb62e7b35062c7;p=ghc-hetmet.git [project @ 2001-05-24 13:59:09 by simonpj] ------------------------------------------------------ More stuff towards generalising 'foreign' declarations ------------------------------------------------------ This is the second step towards generalising 'foreign' declarations to handle langauges other than C. Now I can handle foreign import dotnet type T foreign import dotnet "void Foo.Baz.f( T )" f :: T -> IO () ** WARNING ** I believe that all the foreign stuff for C should work exactly as before, but I have not tested it thoroughly. Sven, Manuel, Marcin: please give it a whirl and compare old with new output. Lots of fiddling around with data types. The main changes are * HsDecls.lhs The ForeignDecl type and its friends Note also the ForeignType constructor to TyClDecl * ForeignCall.lhs Here's where the stuff that survives right through compilation lives * TcForeign.lhs DsForeign.lhs Substantial changes driven by the new data types * Parser.y ParseIface.y RnSource Just what you'd expect --- diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs index c4b6684..8e83f7d 100644 --- a/ghc/compiler/absCSyn/AbsCUtils.lhs +++ b/ghc/compiler/absCSyn/AbsCUtils.lhs @@ -28,7 +28,7 @@ import Unique ( Unique{-instance Eq-} ) 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 @@ -341,9 +341,9 @@ flatAbsC (CSwitch discrim alts deflt) = 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 diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index cd9064b..82922d4 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -46,7 +46,7 @@ import Name ( NamedThing(..) ) 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-} ) @@ -284,7 +284,7 @@ pprAbsC (CCallProfCtrMacro op as) _ 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 @@ -775,13 +775,13 @@ Amendment to the above: if we can GC, we have to: 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 '}' @@ -814,16 +814,17 @@ pprFCall call@(CCall (CCallSpec op_str cconv safety is_asm)) uniq args results v (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 @@ -832,11 +833,6 @@ pprFCall call@(CCall (CCallSpec op_str cconv safety is_asm)) uniq args results v 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 diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index 9441a2a..6853b96 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -49,7 +49,7 @@ import Id ( Id, idType, isId, import VarSet import Literal ( isLitLitLit, litSize ) import PrimOp ( primOpIsDupable, primOpOutOfLine ) -import ForeignCall ( ForeignCall(..), ccallIsCasm ) +import ForeignCall ( okToExposeFCall ) import IdInfo ( InlinePragInfo(..), OccInfo(..), GlobalIdDetails(..), isNeverInlinePrag ) @@ -490,10 +490,6 @@ okToUnfoldInHiFile e = opt_UnfoldCasms || go e 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} diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index c03df9e..3758d61 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -26,7 +26,7 @@ import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety, CC 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 ) @@ -96,7 +96,9 @@ dsCCall lbl args may_gc is_asm result_ty 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) @@ -134,8 +136,8 @@ unboxArg :: CoreExpr -- The supplied argument -- 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 @@ -293,7 +295,7 @@ resultWrapper :: Type 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 () diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index 06faf73..af2e270 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -15,8 +15,7 @@ import CoreSyn 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, @@ -35,9 +34,10 @@ import Type ( repType, splitTyConApp_maybe, ) 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, @@ -75,36 +75,25 @@ dsForeigns :: Module , 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. @@ -125,14 +114,33 @@ because it exposes the boxing to the call site. \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 @@ -145,22 +153,17 @@ dsFImport fn_id ty safety ext_name cconv -- 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 @@ -169,20 +172,18 @@ dsFImport fn_id ty safety ext_name cconv 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 @@ -196,19 +197,21 @@ For each `@foreign export foo@' in a module M we generate: 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) @@ -282,20 +285,19 @@ dsFExport fn_id ty mod_name ext_name cconv isDyn 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' @@ -327,23 +329,19 @@ foreign export "f_helper" f_helper :: StablePtr (Addr -> Int -> IO Int) -> Addr \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 @@ -367,7 +365,7 @@ dsFExportDynamic i ty mod_name ext_name cconv = -} 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.) @@ -382,13 +380,14 @@ dsFExportDynamic i ty mod_name ext_name cconv = 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 diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 3888db9..fc136d3 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -9,12 +9,13 @@ Definitions for: @TyDecl@ and @oCnDecl@, @ClassDecl@, \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 @@ -33,14 +34,13 @@ import HsCore ( UfExpr, UfBinder, HsIdInfo, pprHsIdInfo, 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} @@ -82,10 +82,10 @@ data HsDecl name pat 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) @@ -249,13 +249,22 @@ Interface file code: \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 @@ -321,8 +330,9 @@ tyClDeclNames :: Eq name => TyClDecl name pat -> [(name, SrcLoc)] -- 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] @@ -331,6 +341,13 @@ tyClDeclNames (TyData {tcdName = tc_name, tcdCons = cons, tcdLoc = loc}) = (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 @@ -373,6 +390,10 @@ instance (NamedThing name, Ord name) => Eq (TyClDecl name pat) where 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 && @@ -433,6 +454,9 @@ instance (NamedThing name, Outputable name, Outputable pat) 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) @@ -670,55 +694,46 @@ instance (Outputable name) %************************************************************************ \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} diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 49c1cb1..992f086 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -46,7 +46,8 @@ import NameEnv 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 ) @@ -187,6 +188,11 @@ ifaceTyCls (ATyCon tycon) so_far 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 diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index 2ccd9ec..a035b83 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -70,7 +70,6 @@ calling. \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 @@ -101,14 +100,13 @@ foreignCallCode lhs (CCall (CCallSpec (StaticTarget fn) cconv safety is_asm)) rh 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) diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs index 353200f..daeabfb 100644 --- a/ghc/compiler/parser/Lex.lhs +++ b/ghc/compiler/parser/Lex.lhs @@ -122,6 +122,7 @@ data Token | ITwith | ITstdcallconv | ITccallconv + | ITdotnet | ITinterface -- interface keywords | IT__export @@ -308,6 +309,7 @@ ghcExtensionKeywordsFM = listToUFM $ ( "with", ITwith ), ( "stdcall", ITstdcallconv), ( "ccall", ITccallconv), + ( "dotnet", ITdotnet), ("_ccall_", ITccall (False, False, PlayRisky)), ("_ccall_GC_", ITccall (False, False, PlaySafe)), ("_casm_", ITccall (False, True, PlayRisky)), diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs index 51bc199..47381dc 100644 --- a/ghc/compiler/parser/ParseUtil.lhs +++ b/ghc/compiler/parser/ParseUtil.lhs @@ -12,7 +12,7 @@ module ParseUtil ( , mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp , groupBindings - , mkExtName -- Maybe ExtName -> RdrName -> ExtName + , mkExtName -- RdrName -> ExtName , checkPrec -- String -> P String , checkContext -- HsType -> P HsContext @@ -41,6 +41,7 @@ import PrelNames ( unitTyCon_RDR ) import ForeignCall ( CCallConv(..) ) import OccName ( dataName, varName, tcClsName, occNameSpace, setOccNameSpace, occNameUserString ) +import CStrings ( CLabelString ) import FastString ( unpackFS ) import UniqFM ( UniqFM, listToUFM ) import Outputable @@ -305,10 +306,8 @@ mkRecConstrOrUpdate _ _ -- 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 diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index c8aa2ce..e747d2c 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$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. @@ -21,7 +21,9 @@ import RdrName 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 @@ -31,7 +33,9 @@ import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), NewOrData(..) ) import Panic import GlaExts +import CStrings ( CLabelString ) import FastString ( tailFS ) +import Maybes ( orElse ) import Outputable #include "HsVersions.h" @@ -102,6 +106,7 @@ Conflicts: 14 shift/reduce 'with' { ITwith } 'stdcall' { ITstdcallconv } 'ccall' { ITccallconv } + 'dotnet' { ITdotnet } '_ccall_' { ITccall (False, False, PlayRisky) } '_ccall_GC_' { ITccall (False, False, PlaySafe) } '_casm_' { ITccall (False, True, PlayRisky) } @@ -360,23 +365,45 @@ topdecl :: { RdrBinding } (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 } @@ -462,7 +489,7 @@ deprecation :: { RdrBinding } ----------------------------------------------------------------------------- -- Foreign import/export -callconv :: { CCallConv } +ccallconv :: { CCallConv } : 'stdcall' { StdCallConv } | 'ccall' { CCallConv } | {- empty -} { defaultCCallConv } @@ -471,10 +498,8 @@ unsafe_flag :: { Safety } : '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 } diff --git a/ghc/compiler/prelude/ForeignCall.lhs b/ghc/compiler/prelude/ForeignCall.lhs index f469fa3..47eafed 100644 --- a/ghc/compiler/prelude/ForeignCall.lhs +++ b/ghc/compiler/prelude/ForeignCall.lhs @@ -8,16 +8,20 @@ module ForeignCall ( 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} @@ -31,7 +35,7 @@ import Outputable \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) @@ -39,7 +43,7 @@ data ForeignCall -- 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} @@ -70,16 +74,16 @@ playSafe PlayRisky = False %************************************************************************ \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: @@ -88,13 +92,15 @@ 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} @@ -132,32 +138,21 @@ ccallConvAttribute CCallConv = "" 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} @@ -168,9 +163,25 @@ instance Outputable CCallSpec where %************************************************************************ \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} diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs index 395da7d..7c16614 100644 --- a/ghc/compiler/prelude/TysPrim.lhs +++ b/ghc/compiler/prelude/TysPrim.lhs @@ -41,9 +41,7 @@ module TysPrim( int64PrimTyCon, int64PrimTy, word64PrimTyCon, word64PrimTy, - primRepTyCon, - - pcPrimTyCon + primRepTyCon ) where #include "HsVersions.h" @@ -145,37 +143,43 @@ vrcsZP = [vrcZero,vrcPos] \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} @@ -196,7 +200,7 @@ keep different state threads separate. It is represented by nothing at all. \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 @@ -220,10 +224,10 @@ defined in \tr{TysWiredIn.lhs}, not here. %************************************************************************ \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 @@ -238,7 +242,7 @@ mkMutableByteArrayPrimTy s = mkTyConApp mutableByteArrayPrimTyCon [s] %************************************************************************ \begin{code} -mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName 2 vrcsZP PrimPtrRep +mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName vrcsZP PrimPtrRep mkMutVarPrimTy s elt = mkTyConApp mutVarPrimTyCon [s, elt] \end{code} @@ -250,7 +254,7 @@ mkMutVarPrimTy s elt = mkTyConApp mutVarPrimTyCon [s, elt] %************************************************************************ \begin{code} -mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName 2 vrcsZP PrimPtrRep +mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName vrcsZP PrimPtrRep mkMVarPrimTy s elt = mkTyConApp mVarPrimTyCon [s, elt] \end{code} @@ -262,7 +266,7 @@ mkMVarPrimTy s elt = mkTyConApp mVarPrimTyCon [s, elt] %************************************************************************ \begin{code} -stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName 1 vrcsP StablePtrRep +stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName vrcsP StablePtrRep mkStablePtrPrimTy ty = mkTyConApp stablePtrPrimTyCon [ty] \end{code} @@ -274,7 +278,7 @@ mkStablePtrPrimTy ty = mkTyConApp stablePtrPrimTyCon [ty] %************************************************************************ \begin{code} -stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName 1 vrcsP StableNameRep +stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName vrcsP StableNameRep mkStableNamePrimTy ty = mkTyConApp stableNamePrimTyCon [ty] \end{code} @@ -297,7 +301,7 @@ dead before it really was. \begin{code} foreignObjPrimTy = mkTyConTy foreignObjPrimTyCon -foreignObjPrimTyCon = pcPrimTyCon foreignObjPrimTyConName 0 [] ForeignObjRep +foreignObjPrimTyCon = pcPrimTyCon0 foreignObjPrimTyConName ForeignObjRep \end{code} %************************************************************************ @@ -308,7 +312,7 @@ foreignObjPrimTyCon = pcPrimTyCon foreignObjPrimTyConName 0 [] ForeignObjRep \begin{code} bcoPrimTy = mkTyConTy bcoPrimTyCon -bcoPrimTyCon = pcPrimTyCon bcoPrimTyConName 0 [] BCORep +bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName BCORep \end{code} %************************************************************************ @@ -318,7 +322,7 @@ bcoPrimTyCon = pcPrimTyCon bcoPrimTyConName 0 [] BCORep %************************************************************************ \begin{code} -weakPrimTyCon = pcPrimTyCon weakPrimTyConName 1 vrcsP WeakPtrRep +weakPrimTyCon = pcPrimTyCon weakPrimTyConName vrcsP WeakPtrRep mkWeakPrimTy v = mkTyConApp weakPrimTyCon [v] \end{code} @@ -340,7 +344,7 @@ to the thread id internally. \begin{code} threadIdPrimTy = mkTyConTy threadIdPrimTyCon -threadIdPrimTyCon = pcPrimTyCon threadIdPrimTyConName 0 [] ThreadIdRep +threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName ThreadIdRep \end{code} %************************************************************************ diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index 78aa477..47fda3a 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -351,6 +351,8 @@ decl : src_loc qvar_name '::' type maybe_idinfo { 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 @@ -808,9 +810,10 @@ core_aexpr : qvar_name { UfVar $1 } (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 } diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 13c14bc..a1fbfeb 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -119,6 +119,9 @@ In all cases this is set up for interface-file declarations: \begin{code} tyClDeclFVs :: RenamedTyClDecl -> NameSet +tyClDeclFVs (ForeignType {}) + = emptyFVs + tyClDeclFVs (IfaceSig {tcdType = ty, tcdIdInfo = id_infos}) = extractHsTyNames ty `plusFV` plusFVs (map hsIdInfoFVs id_infos) diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 7cab59c..f60ae46 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -489,7 +489,8 @@ getGates :: FreeVars -- Things mentioned in the source program 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` diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index a54dbd8..2bfe8a5 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -13,7 +13,7 @@ module RnNames ( import CmdLineOpts ( DynFlag(..) ) import HsSyn ( HsModule(..), HsDecl(..), IE(..), ieName, ImportDecl(..), - ForeignDecl(..), ForKind(..), isDynamicExtName, + ForeignDecl(..), collectLocatedHsBinders ) import RdrHsSyn ( RdrNameIE, RdrNameImportDecl, @@ -244,17 +244,11 @@ getLocalDeclBinders mod (ValD binds) 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 [] diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 781e67c..71fe8ff 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -49,8 +49,6 @@ import CmdLineOpts ( DynFlag(..) ) -- Warn of unused for-all'd tyvars import Unique ( Uniquable(..) ) import Maybes ( maybeToBool ) -import ErrUtils ( Message ) -import CStrings ( isCLabelString ) import ListSetOps ( removeDupsEq ) \end{code} @@ -112,39 +110,44 @@ rnSourceDecl (RuleD rule) = 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} @@ -284,6 +287,11 @@ rnTyClDecl (IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc 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}) @@ -428,7 +436,7 @@ finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc}) -- G 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} @@ -879,10 +887,6 @@ badRuleVar name var 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), diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 1f83155..cbc20ff 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -178,6 +178,7 @@ tcInLocalScope env v = v `elemNameEnv` (tcLEnv env) data TyThingDetails = SynTyDetails Type | DataTyDetails ThetaType [DataCon] [Id] | ClassDetails ThetaType [Id] [ClassOpItem] DataCon + | ForeignTyDetails -- Nothing yet \end{code} diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index 3f133ff..615dea8 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -20,8 +20,7 @@ module TcForeign #include "HsVersions.h" import HsSyn ( HsDecl(..), ForeignDecl(..), HsExpr(..), - ExtName(Dynamic), isDynamicExtName, MonoBinds(..), - ForKind(..) + MonoBinds(..), FoImport(..), FoExport(..) ) import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl ) @@ -46,17 +45,103 @@ import TysWiredIn ( isFFIArgumentTy, isFFIImportResultTy, 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, []) @@ -66,170 +151,96 @@ tcForeignExports decls = 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} diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 755c68b..78a6676 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -650,9 +650,9 @@ zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM [TypecheckedForeignDecl] 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} diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 59d04eb..d2132a5 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -32,7 +32,7 @@ import TcEnv ( TcEnv, tcExtendGlobalValEnv, tcExtendTyVarEnvForMeths, tcAddImportedIdInfo, tcLookupClass, InstInfo(..), pprInstInfo, simpleInstInfoTyCon, - simpleInstInfoTy, newDFunName, tcExtendTyVarEnv, + simpleInstInfoTy, newDFunName, isLocalThing, ) import InstEnv ( InstEnv, extendInstEnv ) diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index a68b51a..8842be5 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -340,7 +340,7 @@ tcModule :: PersistentCompilerState 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 diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index ae8da7e..9fa3806 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -13,7 +13,7 @@ module TcTyClsDecls ( import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) import HsSyn ( TyClDecl(..), ConDecl(..), Sig(..), HsPred(..), - tyClDeclName, hsTyVarNames, + tyClDeclName, hsTyVarNames, tyClDeclTyVars, isIfaceSigDecl, isClassDecl, isSynDecl, isClassOpSig ) import RnHsSyn ( RenamedTyClDecl, tyClDeclFVs ) @@ -30,11 +30,11 @@ import TcType ( TcKind, newKindVar, zonkKindEnv ) 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 @@ -207,8 +207,8 @@ tcTyClDecl1 is_rec unf_env decl \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 @@ -242,6 +242,8 @@ kcTyClDecl decl@(TySynonym {tcdSynRhs = rhs}) 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_` @@ -273,7 +275,7 @@ kcTyClDeclBody decl thing_inside 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} @@ -327,6 +329,10 @@ buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details | 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 diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index afbd15e..ebfa3a8 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -81,6 +81,9 @@ tcTyDecl1 is_rec unf_env (TyData {tcdND = new_or_data, tcdCtxt = context, 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} diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index 273a067..36ebf46 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -312,7 +312,7 @@ showTypeCategory ty || 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' diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 857d0ab..b8a139b 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -13,6 +13,8 @@ module TyCon( isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity, isRecursiveTyCon, newTyConRep, + mkForeignTyCon, isForeignTyCon, + mkAlgTyCon, --mkAlgTyCon, mkClassTyCon, mkFunTyCon, @@ -123,14 +125,18 @@ data TyCon 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 { @@ -290,14 +296,30 @@ mkTupleTyCon name kind arity tyvars con boxed gen_info 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 @@ -322,9 +344,9 @@ isFunTyCon _ = False 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 @@ -383,6 +405,11 @@ tupleTyConBoxity tc = tyConBoxed tc 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} diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 2bf99f5..2b1a149 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -63,7 +63,8 @@ module Type ( getDFunTyKey, -- Lifting and boxity - isUnLiftedType, isUnboxedTupleType, isAlgType, isDataType, isNewType, + isUnLiftedType, isUnboxedTupleType, isAlgType, + isDataType, isNewType, isPrimitiveType, -- Free variables tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, @@ -108,7 +109,7 @@ import TyCon ( TyCon, isFunTyCon, isDataTyCon, isNewTyCon, newTyConRep, isAlgTyCon, isSynTyCon, tyConArity, tyConKind, tyConDataCons, getSynTyConDefn, - tyConPrimRep + tyConPrimRep, isPrimTyCon ) -- others @@ -1126,6 +1127,15 @@ isNewType ty = case splitTyConApp_maybe ty of 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}