X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsForeign.lhs;h=9dea2ade73665cc9c15b6b852df88f0206e657bf;hp=751c5042ee2135b85a5c477bbf8af7445e274f8c;hb=5b7e2a875b089f31cd8dedb52d47ef9a93f276be;hpb=bca74f3e6bde807d688e39e6de28112ebcb4fa49 diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index 751c504..9dea2ad 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -6,13 +6,6 @@ Desugaring foreign declarations (see also DsCCall). \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module DsForeign ( dsForeigns ) where #include "HsVersions.h" @@ -25,8 +18,6 @@ import DsMonad import HsSyn import DataCon -import MachOp -import SMRep import CoreUtils import Id import Literal @@ -36,7 +27,10 @@ import Type import TyCon import Coercion import TcType +import Var +import CmmExpr +import CmmUtils import HscTypes import ForeignCall import TysWiredIn @@ -97,6 +91,8 @@ dsForeigns fos = do do_decl (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv))) = do (h, c, _, _) <- dsFExport id (idType id) ext_nm cconv False return (h, c, [id], []) + + do_decl d = pprPanic "dsForeigns/do_decl" (ppr d) \end{code} @@ -128,7 +124,7 @@ because it exposes the boxing to the call site. dsFImport :: Id -> ForeignImport -> DsM ([Binding], SDoc, SDoc) -dsFImport id (CImport cconv safety header lib spec) = do +dsFImport id (CImport cconv safety _ _ spec) = do (ids, h, c) <- dsCImport id spec cconv safety return (ids, h, c) @@ -146,14 +142,21 @@ dsCImport :: Id -> DsM ([Binding], SDoc, SDoc) dsCImport id (CLabel cid) cconv _ = do let ty = idType id + fod = case splitTyConApp_maybe (repType ty) of + Just (tycon, _) + | tyConUnique tycon == funPtrTyConKey -> + IsFunction + _ -> IsData (resTy, foRhs) <- resultWrapper ty ASSERT(fromJust resTy `coreEqType` addrPrimTy) -- typechecker ensures this let - rhs = foRhs (mkLit (MachLabel cid stdcall_info)) + rhs = foRhs (Lit (MachLabel cid stdcall_info fod)) stdcall_info = fun_type_arg_stdcall_info cconv ty in return ([(id, rhs)], empty, empty) +dsCImport id (CFunction target) cconv@PrimCallConv safety + = dsPrimCall id (CCall (CCallSpec target cconv safety)) dsCImport id (CFunction target) cconv safety = dsFCall id (CCall (CCallSpec target cconv safety)) dsCImport id CWrapper cconv _ @@ -167,10 +170,9 @@ fun_type_arg_stdcall_info StdCallConv ty | Just (tc,[arg_ty]) <- splitTyConApp_maybe (repType ty), tyConUnique tc == funPtrTyConKey = let - (_tvs,sans_foralls) = tcSplitForAllTys arg_ty - (fe_arg_tys, orig_res_ty) = tcSplitFunTys sans_foralls - in - Just $ sum (map (machRepByteWidth . typeMachRep . getPrimTyOf) fe_arg_tys) + (_tvs,sans_foralls) = tcSplitForAllTys arg_ty + (fe_arg_tys, _orig_res_ty) = tcSplitFunTys sans_foralls + in Just $ sum (map (widthInBytes . typeWidth . typeCmmType . getPrimTyOf) fe_arg_tys) fun_type_arg_stdcall_info _other_conv _ = Nothing \end{code} @@ -183,6 +185,7 @@ fun_type_arg_stdcall_info _other_conv _ %************************************************************************ \begin{code} +dsFCall :: Id -> ForeignCall -> DsM ([(Id, Expr TyVar)], SDoc, SDoc) dsFCall fn_id fcall = do let ty = idType fn_id @@ -208,7 +211,6 @@ dsFCall fn_id fcall = do augmentResultDs | forDotnet = do - err_res <- newSysLocalDs addrPrimTy return (\ (mb_res_ty, resWrap) -> case mb_res_ty of Nothing -> (Just (mkTyConApp (tupleTyCon Unboxed 1) @@ -243,6 +245,39 @@ dsFCall fn_id fcall = do %************************************************************************ %* * +\subsection{Primitive calls} +%* * +%************************************************************************ + +This is for `@foreign import prim@' declarations. + +Currently, at the core level we pretend that these primitive calls are +foreign calls. It may make more sense in future to have them as a distinct +kind of Id, or perhaps to bundle them with PrimOps since semantically and +for calling convention they are really prim ops. + +\begin{code} +dsPrimCall :: Id -> ForeignCall -> DsM ([(Id, Expr TyVar)], SDoc, SDoc) +dsPrimCall fn_id fcall = do + let + ty = idType fn_id + (tvs, fun_ty) = tcSplitForAllTys ty + (arg_tys, io_res_ty) = tcSplitFunTys fun_ty + -- Must use tcSplit* functions because we want to + -- see that (IO t) in the corner + + args <- newSysLocalsDs arg_tys + + ccall_uniq <- newUnique + let + call_app = mkFCall ccall_uniq fcall (map Var args) io_res_ty + rhs = mkLams tvs (mkLams args call_app) + return ([(fn_id, rhs)], empty, empty) + +\end{code} + +%************************************************************************ +%* * \subsection{Foreign export} %* * %************************************************************************ @@ -254,7 +289,7 @@ The function that does most of the work for `@foreign export@' declarations. For each `@foreign export foo@' in a module M we generate: \begin{itemize} \item a C function `@foo@', which calls -\item a Haskell stub `@M.$ffoo@', which calls +\item a Haskell stub `@M.\$ffoo@', which calls \end{itemize} the user-written Haskell function `@M.foo@'. @@ -288,7 +323,7 @@ dsFExport fn_id ty ext_name cconv isDyn= do (res_ty, -- t is_IO_res_ty) <- -- Bool case tcSplitIOType_maybe orig_res_ty of - Just (ioTyCon, res_ty, co) -> return (res_ty, True) + Just (_ioTyCon, res_ty, _co) -> return (res_ty, True) -- The function already returns IO t -- ToDo: what about the coercion? Nothing -> return (orig_res_ty, False) @@ -360,8 +395,8 @@ dsFExportDynamic id cconv = do -} adj_args = [ mkIntLitInt (ccallConvToInt cconv) , Var stbl_value - , mkLit (MachLabel fe_nm mb_sz_args) - , mkLit (mkStringLit typestring) + , Lit (MachLabel fe_nm mb_sz_args IsFunction) + , Lit (mkMachString typestring) ] -- name of external entry point providing these services. -- (probably in the RTS.) @@ -387,7 +422,7 @@ dsFExportDynamic id cconv = do , Lam stbl_value ccall_adj ] - fed = (id `setInlinePragma` NeverActive, io_app) + fed = (id `setInlineActivation` NeverActive, io_app) -- Never inline the f.e.d. function, because the litlit -- might not be in scope in other modules. @@ -429,19 +464,26 @@ mkFExportCBits :: FastString ) mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc = (header_bits, c_bits, type_string, - sum [ machRepByteWidth rep | (_,_,_,rep) <- aug_arg_info] -- all the args + sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args + -- NB. the calculation here isn't strictly speaking correct. + -- We have a primitive Haskell type (eg. Int#, Double#), and + -- we want to know the size, when passed on the C stack, of + -- the associated C type (eg. HsInt, HsDouble). We don't have + -- this information to hand, but we know what GHC's conventions + -- are for passing around the primitive Haskell types, so we + -- use that instead. I hope the two coincide --SDM ) where -- list the arguments to the C function arg_info :: [(SDoc, -- arg name SDoc, -- C type Type, -- Haskell type - MachRep)] -- the MachRep + CmmType)] -- the CmmType arg_info = [ let stg_type = showStgType ty in (arg_cname n stg_type, stg_type, ty, - typeMachRep (getPrimTyOf ty)) + typeCmmType (getPrimTyOf ty)) | (ty,n) <- zip arg_htys [1::Int ..] ] arg_cname n stg_ty @@ -468,7 +510,7 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc stable_ptr_arg = (text "the_stableptr", text "StgStablePtr", undefined, - typeMachRep (mkStablePtrPrimTy alphaTy)) + typeCmmType (mkStablePtrPrimTy alphaTy)) -- stuff to do with the return type of the C function res_hty_is_unit = res_hty `coreEqType` unitTy -- Look through any newtypes @@ -480,6 +522,7 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc pprCconv = case cc of CCallConv -> empty StdCallConv -> text (ccallConvAttribute cc) + _ -> panic ("mkFExportCBits/pprCconv " ++ showPpr cc) header_bits = ptext (sLit "extern") <+> fun_proto <> semi @@ -585,15 +628,6 @@ foreignExportInitialiser hs_fn = ] --- NB. the calculation here isn't strictly speaking correct. --- We have a primitive Haskell type (eg. Int#, Double#), and --- we want to know the size, when passed on the C stack, of --- the associated C type (eg. HsInt, HsDouble). We don't have --- this information to hand, but we know what GHC's conventions --- are for passing around the primitive Haskell types, so we --- use that instead. I hope the two coincide --SDM -typeMachRep ty = argMachRep (typeCgRep ty) - mkHObj :: Type -> SDoc mkHObj t = text "rts_mk" <> text (showFFIType t) @@ -610,6 +644,8 @@ showFFIType t = getOccString (getName tc) Just (tc,_) -> tc Nothing -> pprPanic "showFFIType" (ppr t) +insertRetAddr :: CCallConv -> [(SDoc, SDoc, Type, CmmType)] + -> [(SDoc, SDoc, Type, CmmType)] #if !defined(x86_64_TARGET_ARCH) insertRetAddr CCallConv args = ret_addr_arg : args insertRetAddr _ args = args @@ -619,16 +655,19 @@ insertRetAddr _ args = args -- need to flush a register argument to the stack (See rts/Adjustor.c for -- details). insertRetAddr CCallConv args = go 0 args - where go 6 args = ret_addr_arg : args + where go :: Int -> [(SDoc, SDoc, Type, CmmType)] + -> [(SDoc, SDoc, Type, CmmType)] + go 6 args = ret_addr_arg : args go n (arg@(_,_,_,rep):args) - | I64 <- rep = arg : go (n+1) args + | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args | otherwise = arg : go n args - go n [] = [] + go _ [] = [] insertRetAddr _ args = args #endif +ret_addr_arg :: (SDoc, SDoc, Type, CmmType) ret_addr_arg = (text "original_return_addr", text "void*", undefined, - typeMachRep addrPrimTy) + typeCmmType addrPrimTy) -- This function returns the primitive type associated with the boxed -- type argument to a foreign export (eg. Int ==> Int#).