X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsForeign.lhs;h=52956a09fff45264bc2f6f7b9782e0f339f0e290;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=2a855aff37de4979b22c416b4217acbe7e3dc845;hpb=ce3cab1dc3f3d03d43cf1b8cfc848c1ccaa00a84;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index 2a855af..52956a0 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -8,301 +8,338 @@ Expanding out @foreign import@ and @foreign export@ declarations. \begin{code} module DsForeign ( dsForeigns ) where - #include "HsVersions.h" +import TcRnMonad -- temp import CoreSyn -import DsCCall ( getIoOkDataCon, boxResult, unboxArg, - can'tSeeDataConsPanic - ) +import DsCCall ( dsCCall, mkFCall, boxResult, unboxArg, resultWrapper ) import DsMonad -import DsUtils - -import HsSyn ( ExtName(..), ForeignDecl(..), isDynamic ) -import CallConv -import TcHsSyn ( maybeBoxedPrimType, TypecheckedForeignDecl ) -import CoreUtils ( coreExprType ) -import Id ( Id, dataConArgTys, idType, idName, - mkVanillaId, dataConRawArgTys, - dataConTyCon, mkIdVisible - ) -import IdInfo ( noIdInfo ) -import Literal ( Literal(..), mkMachInt ) -import Maybes ( maybeToBool ) -import Name ( nameString, occNameString, nameOccName, nameUnique ) -import PrelVals ( packStringForCId, eRROR_ID ) -import PrimOp ( PrimOp(..) ) -import Type ( isUnpointedType, splitAlgTyConApp_maybe, - splitTyConApp_maybe, splitFunTys, splitForAllTys, - Type, mkFunTys, applyTy, mkForAllTys, mkTyConApp, - typePrimRep, mkTyVarTy, mkFunTy, splitAppTy - ) -import PrimRep ( showPrimRepToUser, PrimRep(..) ) -import TyVar ( TyVar ) -import TyCon ( tyConDataCons ) -import TysPrim ( byteArrayPrimTy, realWorldStatePrimTy, - byteArrayPrimTyCon, mutableByteArrayPrimTyCon, - realWorldTy, addrPrimTy, mkStablePtrPrimTy, - intPrimTy + +import HsSyn ( ForeignDecl(..), ForeignExport(..), LForeignDecl, + ForeignImport(..), CImportSpec(..) ) +import DataCon ( splitProductType_maybe ) +#ifdef DEBUG +import DataCon ( dataConSourceArity ) +import Type ( isUnLiftedType ) +#endif +import MachOp ( machRepByteWidth, MachRep(..) ) +import SMRep ( argMachRep, typeCgRep ) +import CoreUtils ( exprType, mkInlineMe ) +import Id ( Id, idType, idName, mkSysLocal, setInlinePragma ) +import Literal ( Literal(..), mkStringLit ) +import Module ( moduleFS ) +import Name ( getOccString, NamedThing(..) ) +import Type ( repType, coreEqType ) +import TcType ( Type, mkFunTys, mkForAllTys, mkTyConApp, + mkFunTy, tcSplitTyConApp_maybe, + tcSplitForAllTys, tcSplitFunTys, tcTyConAppArgs, ) -import TysWiredIn ( getStatePairingConInfo, - unitDataCon, stringTy, - realWorldStateTy, stateDataCon, - isFFIArgumentTy, unitTy, - addrTy, stablePtrTyCon, - stateAndPtrPrimDataCon + +import BasicTypes ( Boxity(..) ) +import HscTypes ( ForeignStubs(..) ) +import ForeignCall ( ForeignCall(..), CCallSpec(..), + Safety(..), playSafe, + CExportSpec(..), CLabelString, + CCallConv(..), ccallConvToInt, + ccallConvAttribute ) +import TysWiredIn ( unitTy, tupleTyCon ) +import TysPrim ( addrPrimTy, mkStablePtrPrimTy, alphaTy ) +import PrelNames ( hasKey, ioTyConKey, stablePtrTyConName, newStablePtrName, bindIOName, + checkDotnetResName ) +import BasicTypes ( Activation( NeverActive ) ) +import SrcLoc ( Located(..), unLoc ) import Outputable +import Maybe ( fromJust, isNothing ) +import FastString \end{code} Desugaring of @foreign@ declarations is naturally split up into parts, an @import@ and an @export@ part. A @foreign import@ -declaration - +declaration +\begin{verbatim} foreign import cc nm f :: prim_args -> IO prim_res - +\end{verbatim} is the same as - +\begin{verbatim} f :: prim_args -> IO prim_res f a1 ... an = _ccall_ nm cc a1 ... an - +\end{verbatim} so we reuse the desugaring code in @DsCCall@ to deal with these. \begin{code} -dsForeigns :: [TypecheckedForeignDecl] - -> DsM ( [CoreBinding] -- desugared foreign imports - , [CoreBinding] -- helper functions for foreign exports - , SDoc -- auxilliary code to emit into .hc file - , SDoc -- Header file prototypes for "foreign exported" functions. - , SDoc -- C stubs to use when calling "foreign exported" funs. - ) -dsForeigns fos = foldlDs combine ([],[],empty,empty,empty) fos +type Binding = (Id, CoreExpr) -- No rec/nonrec structure; + -- the occurrence analyser will sort it all out + +dsForeigns :: [LForeignDecl Id] + -> DsM (ForeignStubs, [Binding]) +dsForeigns [] + = returnDs (NoStubs, []) +dsForeigns fos + = foldlDs combine (ForeignStubs empty empty [] [], []) fos where - combine (acc_fi, acc_fe, acc_hc, acc_h, acc_c) fo@(ForeignDecl i imp_exp _ ext_nm cconv _) - | isForeignImport = - dsFImport i (idType i) uns ext_nm cconv `thenDs` \ b -> - returnDs (b:acc_fi, acc_fe, acc_hc, acc_h, acc_c) - | isDynamic ext_nm = - dsFExportDynamic i (idType i) ext_nm cconv `thenDs` \ (fi,fe,hc,h,c) -> - returnDs (fi:acc_fi, fe:acc_fe, hc $$ acc_hc, h $$ acc_h, c $$ acc_c) - | otherwise = - dsFExport i (idType i) ext_nm cconv False `thenDs` \ (fe,hc,h,c) -> - returnDs (acc_fi, fe:acc_fe, hc $$ acc_hc, h $$ acc_h, c $$ acc_c) - - where - isForeignImport = maybeToBool imp_exp - (Just uns) = imp_exp - + combine stubs (L loc decl) = putSrcSpanDs loc (combine1 stubs decl) + + combine1 (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f) + (ForeignImport id _ spec depr) + = traceIf (text "fi start" <+> ppr id) `thenDs` \ _ -> + dsFImport (unLoc id) spec `thenDs` \ (bs, h, c, mbhd) -> + warnDepr depr `thenDs` \ _ -> + traceIf (text "fi end" <+> ppr id) `thenDs` \ _ -> + returnDs (ForeignStubs (h $$ acc_h) + (c $$ acc_c) + (addH mbhd acc_hdrs) + acc_feb, + bs ++ acc_f) + + combine1 (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f) + (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv)) depr) + = dsFExport id (idType id) + ext_nm cconv False `thenDs` \(h, c, _, _) -> + warnDepr depr `thenDs` \_ -> + returnDs (ForeignStubs (h $$ acc_h) (c $$ acc_c) acc_hdrs (id:acc_feb), + acc_f) + + addH Nothing ls = ls + addH (Just e) ls + | e `elem` ls = ls + | otherwise = e:ls + + warnDepr False = returnDs () + warnDepr True = dsWarn msg + where + msg = ptext SLIT("foreign declaration uses deprecated non-standard syntax") \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. +(using the @CCallOp@ primop), before boxing the result up and returning it. + +However, we create a worker/wrapper pair, thus: + + foreign import f :: Int -> IO Int +==> + f x = IO ( \s -> case x of { I# x# -> + case fw s x# of { (# s1, y# #) -> + (# s1, I# y# #)}}) + + fw s x# = ccall f s x# + +The strictness/CPR analyser won't do this automatically because it doesn't look +inside returned tuples; but inlining this wrapper is a Really Good Idea +because it exposes the boxing to the call site. \begin{code} dsFImport :: Id - -> Type -- Type of foreign import. - -> Bool -- True <=> might cause Haskell GC - -> ExtName - -> CallConv - -> DsM CoreBinding -dsFImport nm ty may_not_gc ext_name cconv = - newSysLocalDs realWorldStatePrimTy `thenDs` \ old_s -> - mkArgs ty `thenDs` \ (tvs, args, io_res_ty) -> - mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) -> - let - final_args = Var old_s : unboxed_args - (ioOkDataCon, ioDataCon, result_ty) = getIoOkDataCon io_res_ty - in - boxResult ioOkDataCon result_ty `thenDs` \ (final_result_ty, res_wrapper) -> - let - label = - case ext_name of - Dynamic -> Nothing - ExtName fs _ -> Just fs - - the_ccall_op = CCallOp label False (not may_not_gc) cconv - (map coreExprType final_args) - final_result_ty - in - mkPrimDs the_ccall_op (map VarArg final_args) `thenDs` \ the_prim_app -> - let - the_body = mkValLam [old_s] - (foldr ($) (res_wrapper the_prim_app) arg_wrappers) - in - newSysLocalDs (coreExprType the_body) `thenDs` \ ds -> - let - io_app = mkValApp (mkTyApp (Var ioDataCon) [result_ty]) [VarArg ds] - fo_rhs = mkTyLam tvs $ - mkValLam (map (\ (Var x) -> x) args) - (mkCoLetAny (NonRec ds the_body) io_app) - in - returnDs (NonRec nm fo_rhs) - -mkArgs :: Type -> DsM ([TyVar], [CoreExpr], Type) -mkArgs ty = - case splitFunTys sans_foralls of - (arg_tys, res_ty) -> - newSysLocalsDs arg_tys `thenDs` \ ds_args -> - returnDs (tvs, map Var ds_args, res_ty) + -> ForeignImport + -> DsM ([Binding], SDoc, SDoc, Maybe FastString) +dsFImport id (CImport cconv safety header lib spec) + = dsCImport id spec cconv safety no_hdrs `thenDs` \(ids, h, c) -> + returnDs (ids, h, c, if no_hdrs then Nothing else Just header) where - (tvs, sans_foralls) = splitForAllTys ty - + no_hdrs = nullFS header + + -- FIXME: the `lib' field is needed for .NET ILX generation when invoking + -- routines that are external to the .NET runtime, but GHC doesn't + -- support such calls yet; if `nullFastString lib', the value was not given +dsFImport id (DNImport spec) + = dsFCall id (DNCall spec) True {- No headers -} `thenDs` \(ids, h, c) -> + returnDs (ids, h, c, Nothing) + +dsCImport :: Id + -> CImportSpec + -> CCallConv + -> Safety + -> Bool -- True <=> no headers in the f.i decl + -> DsM ([Binding], SDoc, SDoc) +dsCImport id (CLabel cid) _ _ no_hdrs + = resultWrapper (idType id) `thenDs` \ (resTy, foRhs) -> + ASSERT(fromJust resTy `coreEqType` addrPrimTy) -- typechecker ensures this + let rhs = foRhs (mkLit (MachLabel cid Nothing)) in + returnDs ([(setImpInline no_hdrs id, rhs)], empty, empty) +dsCImport id (CFunction target) cconv safety no_hdrs + = dsFCall id (CCall (CCallSpec target cconv safety)) no_hdrs +dsCImport id CWrapper cconv _ _ + = dsFExportDynamic id cconv + +setImpInline :: Bool -- True <=> No #include headers + -- in the foreign import declaration + -> Id -> Id +-- If there is a #include header in the foreign import +-- we make the worker non-inlinable, because we currently +-- don't keep the #include stuff in the CCallId, and hence +-- it won't be visible in the importing module, which can be +-- fatal. +-- (The #include stuff is just collected from the foreign import +-- decls in a module.) +-- If you want to do cross-module inlining of the c-calls themselves, +-- put the #include stuff in the package spec, not the foreign +-- import decl. +setImpInline True id = id +setImpInline False id = id `setInlinePragma` NeverActive \end{code} + +%************************************************************************ +%* * +\subsection{Foreign calls} +%* * +%************************************************************************ + \begin{code} -dsFExport :: Id - -> Type -- Type of foreign export. - -> ExtName - -> CallConv - -> Bool -- True => invoke IO action that's hanging off - -- the first argument's stable pointer - -> DsM (CoreBinding, SDoc, SDoc, SDoc) -dsFExport i ty ext_name cconv isDyn = - newSysLocalDs realWorldStatePrimTy `thenDs` \ s1 -> - newSysLocalDs realWorldStatePrimTy `thenDs` \ s3 -> - newSysLocalDs helper_ty `thenDs` \ f_helper -> - newSysLocalsDs helper_arg_tys `thenDs` \ helper_args -> - newSysLocalDs res_ty `thenDs` \ v1 -> - unboxResult the_prim_result_ty res_ty s3 v1 `thenDs` \ (state_and_prim_ty, unpack_result) -> - zipWithDs boxArg fe_arg_tys helper_args `thenDs` \ stuff -> - (if isDyn then - newSysLocalDs realWorldStatePrimTy `thenDs` \ s11 -> - newSysLocalDs stbl_ptr_ty `thenDs` \ stbl_ptr -> - newSysLocalDs stbl_ptr_to_ty `thenDs` \ f -> - mkPrimDs DeRefStablePtrOp - [TyArg stbl_ptr_to_ty, - VarArg (Var stbl_ptr), - VarArg (Var s1)] `thenDs` \ the_deref_app -> - let - stbl_app = \ cont -> - Case the_deref_app - (AlgAlts [(stateAndPtrPrimDataCon, [s11, f], cont)] - NoDefault) - in - returnDs (f, stbl_app, s11, stbl_ptr) - else - returnDs (i, - \ body -> body, - s1, - panic "stbl_ptr" -- should never be touched. - )) `thenDs` \ (i, getFun_wrapper, s2, stbl_ptr) -> - let - (boxed_args, arg_wrappers) = unzip stuff +dsFCall fn_id fcall no_hdrs + = 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 + in + newSysLocalsDs arg_tys `thenDs` \ args -> + mapAndUnzipDs unboxArg (map Var args) `thenDs` \ (val_args, arg_wrappers) -> - wrapper_args - | isDyn = stbl_ptr:helper_args - | otherwise = helper_args + let + work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars + + forDotnet = + case fcall of + DNCall{} -> True + _ -> False + + topConDs + | forDotnet = + dsLookupGlobalId checkDotnetResName `thenDs` \ check_id -> + return (Just check_id) + | otherwise = return Nothing + + augmentResultDs + | forDotnet = + newSysLocalDs addrPrimTy `thenDs` \ err_res -> + returnDs (\ (mb_res_ty, resWrap) -> + case mb_res_ty of + Nothing -> (Just (mkTyConApp (tupleTyCon Unboxed 1) + [ addrPrimTy ]), + resWrap) + Just x -> (Just (mkTyConApp (tupleTyCon Unboxed 2) + [ x, addrPrimTy ]), + resWrap)) + | otherwise = returnDs id + in + augmentResultDs `thenDs` \ augment -> + topConDs `thenDs` \ topCon -> + boxResult augment topCon io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) -> - wrapper_arg_tys - | isDyn = stbl_ptr_ty:helper_arg_tys - | otherwise = helper_arg_tys + newUnique `thenDs` \ ccall_uniq -> + newUnique `thenDs` \ work_uniq -> + let + -- Build the worker + worker_ty = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) 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 = setImpInline no_hdrs $ -- See comments with setImpInline + mkSysLocal FSLIT("$wccall") work_uniq worker_ty + + -- Build the wrapper + work_app = mkApps (mkVarApps (Var work_id) tvs) val_args + 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)], empty, empty) - fe_app = mkGenApp (Var i) (map (TyArg . mkTyVarTy) tvs ++ map VarArg boxed_args) - the_app = - getFun_wrapper $ - mkValApp (Note (Coerce io_result_ty io_res) fe_app) - [VarArg s2] - in - newFailLocalDs (coreExprType the_app) `thenDs` \ wild -> - getModuleAndGroupDs `thenDs` \ (mod,_) -> - getUniqueDs `thenDs` \ uniq -> - let +unsafe_call (CCall (CCallSpec _ _ safety)) = playSafe safety +unsafe_call (DNCall _) = False +\end{code} - the_body = - mkTyLam tvs $ - mkValLam wrapper_args $ - mkValLam [s1] $ - foldr ($) (perform_and_unpack) arg_wrappers - perform_and_unpack = - Case the_app (AlgAlts [(ioOkDataCon, [s3, v1], unpack_result)] - (BindDefault wild err)) +%************************************************************************ +%* * +\subsection{Foreign export} +%* * +%************************************************************************ - c_nm = - case ext_name of - ExtName fs _ -> fs +The function that does most of the work for `@foreign export@' declarations. +(see below for the boilerplate code a `@foreign export@' declaration expands + into.) - full_msg = "Exception caught: " ++ _UNPK_ (nameString (idName i)) - msg = NoRepStr (_PK_ full_msg) - err = mkApp (Var eRROR_ID) [state_and_prim_ty] [LitArg msg] +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 +\end{itemize} +the user-written Haskell function `@M.foo@'. - f_helper_glob = (mkIdVisible mod uniq f_helper) - (hc_stub, h_stub, c_stub) = fexportEntry c_nm f_helper_glob wrapper_arg_tys the_prim_result_ty cconv +\begin{code} +dsFExport :: 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 => foreign export dynamic + -- so invoke IO action that's hanging off + -- the first argument's stable pointer + -> DsM ( SDoc -- contents of Module_stub.h + , SDoc -- contents of Module_stub.c + , [MachRep] -- primitive arguments expected by stub function + , Int -- size of args to stub function + ) + +dsFExport fn_id ty ext_name cconv isDyn + = + let + (_tvs,sans_foralls) = tcSplitForAllTys ty + (fe_arg_tys', orig_res_ty) = tcSplitFunTys sans_foralls + -- We must use tcSplits here, because we want to see + -- the (IO t) in the corner of the type! + fe_arg_tys | isDyn = tail fe_arg_tys' + | otherwise = fe_arg_tys' in - returnDs (NonRec f_helper_glob the_body, hc_stub, h_stub, c_stub) - where - (tvs,sans_foralls) = splitForAllTys ty - (fe_arg_tys', io_res) = splitFunTys sans_foralls - (ioOkDataCon, ioDataCon, res_ty) = getIoOkDataCon io_res - - maybe_data_type = splitAlgTyConApp_maybe res_ty - Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type - (the_data_con : other_data_cons) = data_cons - - data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys - (prim_result_ty : other_args_tys) = data_con_arg_tys - - ioDataConTy = idType ioDataCon - (io_tvs, ioDataConTy') = splitForAllTys ioDataConTy - ([arg_ty], _) = splitFunTys ioDataConTy' - io_result_ty = applyTy (mkForAllTys io_tvs arg_ty) res_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' - - (stbl_ptr_ty, helper_arg_tys) = - case (map unboxTy fe_arg_tys') of - (x:xs) | isDyn -> (x,xs) - ls -> (error "stbl_ptr_ty", ls) - - helper_ty = - mkForAllTys tvs $ - mkFunTys (arg_tys ++ [realWorldStatePrimTy]) - state_and_prim_ty - where - arg_tys - | isDyn = stbl_ptr_ty : helper_arg_tys - | otherwise = helper_arg_tys - - the_prim_result_ty - | null data_con_arg_tys = Nothing - | otherwise = Just prim_result_ty - - state_and_prim_ty - | (null other_data_cons) && - (null data_con_arg_tys) = realWorldStateTy - | otherwise = snd (getStatePairingConInfo (unboxTy res_ty)) + -- Look at the result type of the exported function, orig_res_ty + -- If it's IO t, return (t, True) + -- If it's plain t, return (t, False) + (case tcSplitTyConApp_maybe orig_res_ty of + -- We must use tcSplit here so that we see the (IO t) in + -- the type. [IO t is transparent to plain splitTyConApp.] + + Just (ioTyCon, [res_ty]) + -> ASSERT( ioTyCon `hasKey` ioTyConKey ) + -- The function already returns IO t + returnDs (res_ty, True) + + other -> -- The function returns t + returnDs (orig_res_ty, False) + ) + `thenDs` \ (res_ty, -- t + is_IO_res_ty) -> -- Bool + returnDs $ + mkFExportCBits ext_name + (if isDyn then Nothing else Just fn_id) + fe_arg_tys res_ty is_IO_res_ty cconv \end{code} -"foreign export dynamic" lets you dress up Haskell IO actions +@foreign export dynamic@ lets you dress up Haskell IO actions of some fixed type behind an externally callable interface (i.e., as a C function pointer). Useful for callbacks and stuff. \begin{verbatim} -foreign export stdcall f :: (Addr -> Int -> IO Int) -> IO Addr +foreign export dynamic f :: (Addr -> Int -> IO Int) -> IO Addr --- Haskell-visible constructor, which is generated from the --- above: +-- Haskell-visible constructor, which is generated from the above: +-- SUP: No check for NULL from createAdjustor anymore??? f :: (Addr -> Int -> IO Int) -> IO Addr -f cback = IO ( \ s1# -> - case makeStablePtr# cback s1# of { StateAndStablePtr# s2# sp# -> - case _ccall_ "mkAdjustor" sp# ``f_helper'' s2# of - StateAndAddr# s3# a# -> - case addr2Int# a# of - 0# -> IOfail s# err - _ -> - let - a :: Addr - a = A# a# - in - IOok s3# a) +f cback = + bindIO (newStablePtr cback) + (\StablePtr sp# -> IO (\s1# -> + case _ccall_ createAdjustor cconv sp# ``f_helper'' s1# of + (# s2#, a# #) -> (# s2#, A# a# #))) foreign export "f_helper" f_helper :: StablePtr (Addr -> Int -> IO Int) -> Addr -> Int -> IO Int -- `special' foreign export that invokes the closure pointed to by the @@ -311,219 +348,88 @@ foreign export "f_helper" f_helper :: StablePtr (Addr -> Int -> IO Int) -> Addr \begin{code} dsFExportDynamic :: Id - -> Type -- Type of foreign export. - -> ExtName - -> CallConv - -> DsM (CoreBinding, CoreBinding, SDoc, SDoc, SDoc) -dsFExportDynamic i ty ext_name cconv = - newSysLocalDs ty `thenDs` \ fe_id -> + -> CCallConv + -> DsM ([Binding], SDoc, SDoc) +dsFExportDynamic id cconv + = newSysLocalDs ty `thenDs` \ fe_id -> + getModuleDs `thenDs` \ mod_name -> let -- hack: need to get at the name of the C stub we're about to generate. - fe_nm = toCName fe_id - fe_ext_name = ExtName (_PK_ fe_nm) Nothing + fe_nm = mkFastString (unpackFS (zEncodeFS (moduleFS mod_name)) ++ "_" ++ toCName fe_id) in - dsFExport i export_ty fe_ext_name cconv True `thenDs` \ (fe@(NonRec fe_helper fe_expr), hc_code, h_code, c_code) -> - newSysLocalDs realWorldStatePrimTy `thenDs` \ s1 -> - newSysLocalDs realWorldStatePrimTy `thenDs` \ s2 -> - newSysLocalDs realWorldStatePrimTy `thenDs` \ s3 -> - newSysLocalDs arg_ty `thenDs` \ cback_arg -> - newSysLocalDs arg_ty `thenDs` \ cback -> - newSysLocalDs (mkStablePtrPrimTy arg_ty) `thenDs` \ stbl -> - newSysLocalDs addrPrimTy `thenDs` \ addrPrim -> - newSysLocalDs addrTy `thenDs` \ addr -> - mkPrimDs MakeStablePtrOp [TyArg arg_ty, - VarArg (Var cback), - VarArg (Var s1)] `thenDs` \ mkStablePtr_app -> - mkPrimDs Addr2IntOp [VarArg (Var addrPrim)] `thenDs` \ the_addr2Int_app -> - boxArg addrTy addrPrim `thenDs` \ (addr_result, addrPrim_wrapper) -> + newSysLocalDs arg_ty `thenDs` \ cback -> + dsLookupGlobalId newStablePtrName `thenDs` \ newStablePtrId -> + dsLookupTyCon stablePtrTyConName `thenDs` \ stable_ptr_tycon -> let - (stateAndStablePtrPrimDataCon, _) = getStatePairingConInfo (mkStablePtrPrimTy arg_ty) - (stateAndAddrPrimDataCon, stateAndAddrPrimTy) = getStatePairingConInfo addrPrimTy - - cc - | cconv == stdCallConv = 1 - | otherwise = 0 - - ccall_args = [Var s2, Lit (mkMachInt cc), - Var stbl, - Lit (MachLitLit (_PK_ fe_nm) AddrRep)] - - label = Just SLIT("createAdjustor") - the_ccall_op = CCallOp label False False{-won't GC-} cCallConv - (map coreExprType ccall_args) - stateAndAddrPrimTy + mk_stbl_ptr_app = mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ] + stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty] + export_ty = mkFunTy stable_ptr_ty arg_ty in - mkPrimDs the_ccall_op (map VarArg ccall_args) `thenDs` \ the_ccall_app -> - mkConDs ioOkDataCon - [TyArg res_ty, VarArg (Var s3), VarArg (Var addr_result)] - `thenDs` \ ioOkApp -> - newSysLocalDs intPrimTy `thenDs` \ default_val -> + dsLookupGlobalId bindIOName `thenDs` \ bindIOId -> + newSysLocalDs stable_ptr_ty `thenDs` \ stbl_value -> + dsFExport id export_ty fe_nm cconv True + `thenDs` \ (h_code, c_code, arg_reps, args_size) -> let - the_mkStablePtr = \ cont -> - Case mkStablePtr_app - (AlgAlts [(stateAndStablePtrPrimDataCon, [s2, stbl], cont)] - NoDefault) - - the_ccall = \ cont -> - Case the_ccall_app - (AlgAlts [(stateAndAddrPrimDataCon, [s3, addrPrim], cont)] - NoDefault) - the_addr2Int = \ cont -> - Case the_addr2Int_app - (PrimAlts [(mkMachInt 0, io_fail)] - (BindDefault default_val cont)) - - io_fail = mkApp (Var eRROR_ID) [coreExprType wrap_res] [LitArg msg] - full_msg = "Exception caught: " ++ _UNPK_ (nameString (idName i)) - msg = NoRepStr (_PK_ full_msg) - - wrap_res = addrPrim_wrapper ioOkApp - the_body = - mkTyLam tvs $ - mkValLam [cback,s1] $ - the_mkStablePtr $ - the_ccall $ - the_addr2Int wrap_res - - in - newSysLocalDs (coreExprType the_body) `thenDs` \ ds -> - newSysLocalDs (mkFunTy realWorldStatePrimTy - (coreExprType ioOkApp)) `thenDs` \ ap -> - let - io_app = mkValApp (mkTyApp (Var ioDataCon) [res_ty]) [VarArg ap] - io_action = - mkTyLam tvs $ - mkValLam [cback_arg] $ - mkCoLetAny (NonRec ds the_body) $ - mkCoLetAny (NonRec ap (mkValApp (mkTyApp (Var ds) (map mkTyVarTy tvs)) [VarArg cback_arg])) $ - io_app - in - returnDs (NonRec i io_action, fe, hc_code, h_code, c_code) - where - (tvs,sans_foralls) = splitForAllTys ty - ([arg_ty], io_res) = splitFunTys sans_foralls - (ioOkDataCon, ioDataCon, res_ty) = getIoOkDataCon io_res + stbl_app cont ret_ty = mkApps (Var bindIOId) + [ Type stable_ptr_ty + , Type ret_ty + , mk_stbl_ptr_app + , cont + ] + {- + The arguments to the external function which will + create a little bit of (template) code on the fly + for allowing the (stable pointed) Haskell closure + to be entered using an external calling convention + (stdcall, ccall). + -} + adj_args = [ mkIntLitInt (ccallConvToInt cconv) + , Var stbl_value + , mkLit (MachLabel fe_nm mb_sz_args) + , mkLit (mkStringLit arg_type_info) + ] + -- name of external entry point providing these services. + -- (probably in the RTS.) + adjustor = FSLIT("createAdjustor") + + arg_type_info = map repCharCode arg_reps + repCharCode F32 = 'f' + repCharCode F64 = 'd' + repCharCode I64 = 'l' + repCharCode _ = 'i' + + -- Determine the number of bytes of arguments to the stub function, + -- so that we can attach the '@N' suffix to its label if it is a + -- stdcall on Windows. + mb_sz_args = case cconv of + StdCallConv -> Just args_size + _ -> Nothing - ioDataConTy = idType ioDataCon - (io_tvs, ioDataConTy') = splitForAllTys ioDataConTy --- ([arg_ty], _) = splitFunTys ioDataConTy' - io_result_ty = applyTy (mkForAllTys io_tvs arg_ty) res_ty + in + dsCCall adjustor adj_args PlayRisky io_res_ty `thenDs` \ ccall_adj -> + -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback + let ccall_adj_ty = exprType ccall_adj + ccall_io_adj = mkLams [stbl_value] $ + Note (Coerce io_res_ty ccall_adj_ty) + ccall_adj + io_app = mkLams tvs $ + mkLams [cback] $ + stbl_app ccall_io_adj res_ty + fed = (id `setInlinePragma` NeverActive, io_app) + -- Never inline the f.e.d. function, because the litlit + -- might not be in scope in other modules. + in + returnDs ([fed], h_code, c_code) - export_ty = mkFunTy (mkTyConApp stablePtrTyCon [arg_ty]) arg_ty + where + ty = idType id + (tvs,sans_foralls) = tcSplitForAllTys ty + ([arg_ty], io_res_ty) = tcSplitFunTys sans_foralls + [res_ty] = tcTyConAppArgs io_res_ty + -- Must use tcSplit* to see the (IO t), which is a newtype toCName :: Id -> String toCName i = showSDoc (pprCode CStyle (ppr (idName i))) - -\end{code} - -%* -% -\subsection{Helper functions} -% -%* - -@boxArg@ boxes up an argument in preparation for calling -a function that maybe expects a boxed version of it, i.e., - -\begin{verbatim} -boxArg Addr a# ==> let ds_foo :: Addr ; ds_foo = A# a# in f ...ds_foo.. -\end{verbatim} - -\begin{code} -boxArg :: Type -- Expected type after possible boxing of arg. - -> Id -- The (unboxed) argument - -> DsM (Id, -- To pass as the actual, boxed argument - CoreExpr -> CoreExpr -- Wrapper to box the arg - ) -boxArg box_ty prim_arg - | isUnpointedType box_ty = returnDs (prim_arg, \body -> body) - -- Data types with a single constructor, - -- which has a single, primitive-typed arg - | otherwise - = newSysLocalDs box_ty `thenDs` \ box_arg -> - returnDs ( box_arg - , Let (NonRec box_arg (mkCon box_data_con tys_applied [VarArg prim_arg])) - ) - where - maybe_boxed_prim_arg_ty = maybeBoxedPrimType box_ty - (Just (_,tys_applied,_)) = splitAlgTyConApp_maybe box_ty - (Just (box_data_con, _)) = maybe_boxed_prim_arg_ty -\end{code} - -@foreign export@ed functions may return a value back to the outside world. -@unboxResult@ takes care of converting from the (boxed) value that the -exported action returns to the (unboxed) value that is returned across -the border. - -\begin{code} -unboxResult :: Maybe Type -- the (unboxed) type we want to return (along with the state token) - -- Nothing => no result, just the state token. - -> Type -- the (boxed) type we have in our hand. - -> Id -- the state token - -> Id -- boxed arg - -> DsM (Type, -- type of returned expression. - CoreExpr) -- expr that unboxes result and returns state+unboxed result. - -unboxResult mb_res_uboxed_ty res_ty new_s v_boxed - | not (maybeToBool mb_res_uboxed_ty) - = -- no result, just return state token - mkConDs stateDataCon [ TyArg realWorldTy - , VarArg (Var new_s)] `thenDs` \ the_st -> - returnDs (realWorldStateTy, the_st) - - | null data_cons - -- oops! can't see the data constructors - = can'tSeeDataConsPanic "result" res_ty - - | (maybeToBool maybe_data_type) && -- Data type - (null other_data_cons) && -- - with one constructor, - isUnpointedType res_uboxed_ty -- - and of primitive type. - -- (Glasgow extension) - = - newSysLocalDs res_uboxed_ty `thenDs` \ v_unboxed -> - mkConDs state_and_prim_datacon - ((TyArg realWorldTy):map (TyArg ) tycon_arg_tys ++ - [ VarArg (Var new_s) - , VarArg (Var v_unboxed)]) `thenDs` \ the_result -> - let - the_alt = (the_data_con, [v_unboxed], the_result) - in - returnDs (state_and_prim_ty, - Case (Var v_boxed) (AlgAlts [the_alt] NoDefault)) - - | otherwise - = pprPanic "unboxResult: " (ppr res_ty) - where - (Just res_uboxed_ty) = mb_res_uboxed_ty - - maybe_data_type = splitAlgTyConApp_maybe res_ty - Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type - (the_data_con : other_data_cons) = data_cons - - (state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo res_uboxed_ty - -\end{code} - -Returned the unboxed type of a (primitive) type: - -\begin{code} -unboxTy :: Type -> Type -unboxTy ty - | isUnpointedType ty || (ty == unitTy) = ty - | otherwise = - ASSERT( isFFIArgumentTy ty ) -- legal arg types subsume result types. - case splitTyConApp_maybe ty of - Just (tyc,ts) -> - case (tyConDataCons tyc) of - [dc] -> case (dataConArgTys dc ts) of - [ubox] -> ubox - -- HACK: for the array types, the prim type is - -- the second tycon arg. - [_,ubox] -> ubox - _ -> pprPanic "unboxTy: " (ppr ty) - _ -> pprPanic "unboxTy: " (ppr ty) - _ -> pprPanic "unboxTy: " (ppr ty) - \end{code} %* @@ -532,277 +438,209 @@ unboxTy ty % %* -[Severe hack to get @foreign export@ off the ground:] - -For each @foreign export@ function, a C stub together with a @.hc@ stub -is generated. The C stub enters the .hc stub, setting up the passing of -parameters from C land to STG land through the use of global variables -(don't worry, this just a temporary solution!). Ditto for the result. - -[ -The generation of .hc code will go once the transition is -made over to the new rts. Hence the hack, instead of extending -AbsCSyn to cope with the .hc code generated. -] +For each @foreign export@ function, a C stub function is generated. +The C stub constructs the application of the exported Haskell function +using the hugs/ghc rts invocation API. \begin{code} -fexportEntry :: FAST_STRING -> Id -> [Type] -> Maybe Type -> CallConv -> (SDoc, SDoc, SDoc) -fexportEntry c_nm helper args res cc = - ( paramArea $$ stopTemplate $$ startTemplate $$ vtblTemplate, h_code, c_code ) +mkFExportCBits :: FastString + -> Maybe Id -- Just==static, Nothing==dynamic + -> [Type] + -> Type + -> Bool -- True <=> returns an IO type + -> CCallConv + -> (SDoc, + SDoc, + [MachRep], -- the argument reps + Int -- total size of arguments + ) +mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc + = (header_bits, c_bits, + [rep | (_,_,_,rep) <- arg_info], -- just the real args + sum [ machRepByteWidth rep | (_,_,_,rep) <- aug_arg_info] -- all the args + ) where - (h_code, c_code) = mkCStub c_nm h_stub_nm args res cc + -- list the arguments to the C function + arg_info :: [(SDoc, -- arg name + SDoc, -- C type + Type, -- Haskell type + MachRep)] -- the MachRep + arg_info = [ (text ('a':show n), showStgType ty, ty, + typeMachRep (getPrimTyOf ty)) + | (ty,n) <- zip arg_htys [1..] ] + + -- add some auxiliary args; the stable ptr in the wrapper case, and + -- a slot for the dummy return address in the wrapper + ccall case + aug_arg_info + | isNothing maybe_target = stable_ptr_arg : insertRetAddr cc arg_info + | otherwise = arg_info + + stable_ptr_arg = + (text "the_stableptr", text "StgStablePtr", undefined, + typeMachRep (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 + + cResType | res_hty_is_unit = text "void" + | otherwise = showStgType res_hty + + -- Now we can cook up the prototype for the exported function. + pprCconv = case cc of + CCallConv -> empty + StdCallConv -> text (ccallConvAttribute cc) + + header_bits = ptext SLIT("extern") <+> fun_proto <> semi + + fun_proto = cResType <+> pprCconv <+> ftext c_nm <> + parens (hsep (punctuate comma (map (\(nm,ty,_,_) -> ty <+> nm) + aug_arg_info))) + + -- the target which will form the root of what we ask rts_evalIO to run + the_cfun + = case maybe_target of + Nothing -> text "(StgClosure*)deRefStablePtr(the_stableptr)" + Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure" + + cap = text "cap" <> comma + + -- the expression we give to rts_evalIO + expr_to_run + = foldl appArg the_cfun arg_info -- NOT aug_arg_info + where + appArg acc (arg_cname, _, arg_hty, _) + = text "rts_apply" + <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname)) + + -- various other bits for inside the fn + declareResult = text "HaskellObj ret;" + declareCResult | res_hty_is_unit = empty + | otherwise = cResType <+> text "cret;" + + assignCResult | res_hty_is_unit = empty + | otherwise = + text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi + + -- an extern decl for the fn being called + extern_decl + = case maybe_target of + Nothing -> empty + Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi + + + -- Initialise foreign exports by registering a stable pointer from an + -- __attribute__((constructor)) function. + -- The alternative is to do this from stginit functions generated in + -- codeGen/CodeGen.lhs; however, stginit functions have a negative impact + -- on binary sizes and link times because the static linker will think that + -- all modules that are imported directly or indirectly are actually used by + -- the program. + -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL) + + initialiser + = case maybe_target of + Nothing -> empty + Just hs_fn -> + vcat + [ text "static void stginit_export_" <> ppr hs_fn + <> text "() __attribute__((constructor));" + , text "static void stginit_export_" <> ppr hs_fn <> text "()" + , braces (text "getStablePtr" + <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure") + <> semi) + ] + + -- finally, the whole darn thing + c_bits = + space $$ + extern_decl $$ + fun_proto $$ + vcat + [ lbrace + , text "Capability *cap;" + , declareResult + , declareCResult + , text "cap = rts_lock();" + -- create the application + perform it. + , text "cap=rts_evalIO" <> parens ( + cap <> + text "rts_apply" <> parens ( + cap <> + text "(HaskellObj)" + <> text (if is_IO_res_ty + then "runIO_closure" + else "runNonIO_closure") + <> comma + <> expr_to_run + ) <+> comma + <> text "&ret" + ) <> semi + , text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm) + <> comma <> text "cap") <> semi + , assignCResult + , text "rts_unlock(cap);" + , if res_hty_is_unit then empty + else text "return cret;" + , rbrace + ] $$ + initialiser - paramArea = - vcat (zipWith declVar ( res_ty : param_tys ) ( res_name : param_names ) ) +-- 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) - -- name of the (Haskell) helper function generated by the desugarer. - h_nm = ppr helper - h_stub_nm = text foreign_export_prefix <> h_nm - closure = h_nm <> text "_closure" +mkHObj :: Type -> SDoc +mkHObj t = text "rts_mk" <> text (showFFIType t) - param_names = zipWith (\ i _ -> h_stub_nm <> text ('_':show i)) [1..] args - param_tys = map (ppr.typePrimRep) args +unpackHObj :: Type -> SDoc +unpackHObj t = text "rts_get" <> text (showFFIType t) - (res_name, res_ty) = - case res of - Nothing -> (empty, empty) - Just t -> (h_stub_nm <> text "_res", ppr (typePrimRep t)) +showStgType :: Type -> SDoc +showStgType t = text "Hs" <> text (showFFIType t) - startTemplate = - vcat - [ text "extern realWorldZh_closure;" - , ptext SLIT("STGFUN") <> parens (h_stub_nm) - , lbrace - , ptext SLIT("FUNBEGIN;") - , text "RestoreAllStgRegs();" - , stackCheck param_names - , pushRetReg - , pushCont - , pushRealWorld - , vcat (map pushArg (reverse param_names)) - , text "Node=" <> closure <> semi - , text "ENT_VIA_NODE();" -- ticky count - , text "InfoPtr=(D_)(INFO_PTR(Node));" - , text "JMP_(ENTRY_CODE(InfoPtr));" - , text "FUNEND;" - , rbrace - ] - - stopTemplate = - vcat - [ ptext SLIT("STGFUN") <> parens (text "stop" <> h_stub_nm <> text "DirectReturn") - , lbrace - , ptext SLIT("FUNBEGIN;") - , assignResult - , popRetReg - , text "#if defined(__STG_GCC_REGS__)" - , text "SaveAllStgRegs();" - , text "#else" - , text "SAVE_Hp = Hp;" - , text "SAVE_HpLim = HpLim;" - , text "#endif" - , text "JMP_(miniInterpretEnd);" - , text "FUNEND;" - , rbrace - ] - - vtblTemplate = - vcat - [ text "const W_ vtbl_" <> h_stub_nm <> text "[] = {" - , vcat (punctuate comma (replicate 8 dir_ret)) - , text "};" - ] - where - dir_ret = text "(W_)stop" <> h_stub_nm <> text "DirectReturn" - - assignResult = - case res of - Nothing -> empty - Just _ -> res_name <> equals <> text "R3.i;" -- wrong - - pushRetReg = - text "SpB -= BREL(1);" $$ - text "*SpB = (W_)RetReg;" - - popRetReg = - text "RetReg=(StgRetAddr)*SpB;" $$ - text "SpB += BREL(1);" - - pushCont = - text "RetReg=(StgRetAddr)UNVEC(stop" <> h_stub_nm <> - text "DirectReturn,vtbl_" <> h_stub_nm <> text ");" - - pushRealWorld = - text "SpB -= BREL(1);" $$ - text "*SpB = (W_)realWorldZh_closure;" - - - pushArg nm = - text "SpB -= BREL(1);" $$ - text "*SpB = (W_)" <> nm <> semi - - stackCheck args = - text "STK_CHK(LivenessReg,0," <> sz <> text ",0,0,0,0);" - where - sz = parens $ - hsep $ punctuate (text " + ") (text "1":(map sizer args)) - - sizer x = text "BYTES_TO_STGWORDS" <> parens (text "sizeof" <> parens x) - -foreign_export_prefix :: String -foreign_export_prefix = "__fexp_" - -mkCStub :: FAST_STRING -> SDoc -> [Type] -> Maybe Type -> CallConv -> (SDoc, SDoc) -mkCStub c_nm h_stub_nm args res cc = - ( hsep [ ptext SLIT("extern") - , cResType - , pprCconv - , ptext c_nm - , parens (hsep (punctuate comma (zipWith (<+>) stubParamTypes stubArgs))) - , semi - ] - , vcat - [ externDecls - , cResType - , pprCconv - , ptext c_nm <> parens (hsep (punctuate comma stubArgs)) - , vcat (zipWith declVar stubParamTypes stubArgs) - , lbrace - , vcat (zipWith assignArgs param_names c_args) - , text "miniInterpret" <> parens (parens (text "StgFunPtr") <> h_stub_nm) <> semi - , returnResult - , rbrace - ] - ) +showFFIType :: Type -> String +showFFIType t = getOccString (getName tc) where - -- tedious hack to let us deal with caller-cleans-up-stack - -- discipline that the C calling convention uses. - stubParamTypes - | cc == cCallConv = ptext SLIT("void*") : cParamTypes - | otherwise = cParamTypes - stubArgs - | cc == cCallConv = ptext SLIT("_a0") : c_args - | otherwise = c_args - - param_names = zipWith (\ i _ -> h_stub_nm <> text ('_':show i)) [1..] args - cParamTypes = map (text.showPrimRepToUser.typePrimRep) args - (cResType, cResDecl) = - case res of - Nothing -> (text "void", empty) - Just t -> (text (showPrimRepToUser (typePrimRep t)), - text "extern" <+> cResType <+> res_name <> semi) - - pprCconv - | cc == cCallConv = empty - | otherwise = pprCallConv cc - - externDecls = - vcat (zipWith mkExtern cParamTypes param_names) $$ - cResDecl $$ - text "extern void" <+> h_stub_nm <> text "();" - - mkExtern ty nm = text "extern" <+> ty <+> nm <> semi - - c_args = zipWith (\ _ n -> text ('a':show n)) args [0..] - - assignArgs p_nm c_arg = p_nm <+> equals <+> c_arg <> semi - - returnResult = - case res of - Nothing -> empty - Just _ -> text "return" <+> res_name <> semi - - (res_name, res_ty) = - case res of - Nothing -> (empty, empty) - Just t -> (h_stub_nm <> text "_res", ppr (typePrimRep t)) - -declVar :: SDoc -> SDoc -> SDoc -declVar ty var = ty <+> var <> semi - + tc = case tcSplitTyConApp_maybe (repType t) of + Just (tc,_) -> tc + Nothing -> pprPanic "showFFIType" (ppr t) + +#if !defined(x86_64_TARGET_ARCH) +insertRetAddr CCallConv args = ret_addr_arg : args +insertRetAddr _ args = args +#else +-- On x86_64 we insert the return address after the 6th +-- integer argument, because this is the point at which we +-- 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 + go n (arg@(_,_,_,rep):args) + | I64 <- rep = arg : go (n+1) args + | otherwise = arg : go n args + go n [] = [] +insertRetAddr _ args = args +#endif + +ret_addr_arg = (text "original_return_addr", text "void*", undefined, + typeMachRep addrPrimTy) + +-- This function returns the primitive type associated with the boxed +-- type argument to a foreign export (eg. Int ==> Int#). It assumes +-- that all the types we are interested in have a single constructor +-- with a single primitive-typed argument, which is true for all of the legal +-- foreign export argument types (see TcType.legalFEArgTyCon). +getPrimTyOf :: Type -> Type +getPrimTyOf ty = + case splitProductType_maybe (repType ty) of + Just (_, _, data_con, [prim_ty]) -> + ASSERT(dataConSourceArity data_con == 1) + ASSERT2(isUnLiftedType prim_ty, ppr prim_ty) + prim_ty + _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty) \end{code} - -When exporting - - f :: Int -> Int -> Int -> IO Int - -we'll emit the following stuff into the .hc file - -\begin{pseudocode} -StgInt __f_param_1; -StgInt __f_param_2; -StgInt __f_param_3; -StgInt __f_res; - -STGFUN(ds_f) -{ - FUNBEGIN; - RestoreAllStgRegs(); - STK_CHK(LivenessReg,0/*A*/,(SIZE_IN_WORDS(StgInt) + - SIZE_IN_WORDS(StgInt) + - SIZE_IN_WORDS(StgInt) + 1)/*B*/, 0, 0, 0/*prim*/, 0/*re-enter*/); - RetReg = (StgRetAddr) UNVEC(stopds_fDirectReturn,vtbl_stopds_f); - SpB -= BREL(1); - *SpB = (W_)__f_param_3; - SpB -= BREL(1); - *SpB = (W_)__f_param_2; - SpB -= BREL(1); - *SpB = (W_)__f_param_1; - - SpB -= BREL(1); - *SpB = (W_) realWorldZh_closure; - - Node = ds_f_helper_closure; - ENT_VIA_NODE(); - InfoPtr=(D_)(INFO_PTR(Node)); - JMP_(ENTRY_CODE(InfoPtr)); - FUNEND; -} - -STGFUN(stop_ds_fDirectReturn) -{ - FUNBEGIN; - __f_res=R1.i; - SaveAllStgRegs(); - RESUME(miniInterpretEnd); - FUNEND; -} - -const W_ vtbl_stopds_f[] = { - (W_) stopds_fDirectReturn, - (W_) stopds_fDirectReturn, - (W_) stopds_fDirectReturn, - (W_) stopds_fDirectReturn, - (W_) stopds_fDirectReturn, - (W_) stopds_fDirectReturn, - (W_) stopds_fDirectReturn, - (W_) stopds_fDirectReturn -}; - -\end{pseudocode} - -and a C stub - -\begin{pseudocode} -extern StgInt __f_param_1; -extern StgInt __f_param_2; -extern StgInt __f_param_3; -extern StgInt __f_res; - -extern void ds_f(); -extern void miniInterpret(StgAddr); - -int -f(a1,a2,a3) -int a1; -int a2; -int a3; -{ - __f_param_1=a1; - __f_param_2=a2; - __f_param_3=a3; - miniInterpret((StgAddr)ds_f); - return (__f_res); -} - -\end{pseudocode}