X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsForeign.lhs;h=a5780f93f16428fe0a30845bc3d24856b0c5489a;hb=1d78b48000c25695e70ba539760c9e6260971562;hp=f495cd2c237539d53b9f17d566a0e9ea4c9f27e9;hpb=e88bfcee5cc2f6f678cf95bd115c7bd3c478051f;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index f495cd2..a5780f9 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -8,97 +8,120 @@ Expanding out @foreign import@ and @foreign export@ declarations. \begin{code} module DsForeign ( dsForeigns ) where - #include "HsVersions.h" import CoreSyn -import DsCCall ( getIoOkDataCon, boxResult, unboxArg, - can'tSeeDataConsPanic - ) +import DsCCall ( dsCCall, mkCCall, boxResult, unboxArg ) import DsMonad import DsUtils -import HsSyn ( ExtName(..), ForeignDecl(..), isDynamic ) +import HsSyn ( ExtName(..), ForeignDecl(..), isDynamicExtName, ForKind(..) ) +import HsDecls ( extNameStatic ) import CallConv -import TcHsSyn ( maybeBoxedPrimType, TypecheckedForeignDecl ) -import CoreUtils ( coreExprType ) -import Id ( Id, dataConArgTys, idType, idName, - mkVanillaId, dataConRawArgTys, - dataConTyCon, mkIdVisible +import TcHsSyn ( TypecheckedForeignDecl ) +import CoreUtils ( exprType, mkInlineMe ) +import DataCon ( DataCon, dataConWrapId ) +import Id ( Id, idType, idName, mkWildId, mkVanillaId, mkSysLocal ) +import MkId ( mkWorkerId ) +import Literal ( Literal(..) ) +import Module ( Module, moduleUserString ) +import Name ( mkGlobalName, nameModule, nameOccName, getOccString, + mkForeignExportOcc, isLocalName, + NamedThing(..), Provenance(..), ExportFlag(..) ) -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, +import Type ( unUsgTy, repType, 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 + Type, mkFunTys, mkForAllTys, mkTyConApp, + mkTyVarTy, mkFunTy, splitAppTy, applyTy, funResultTy ) -import TysWiredIn ( getStatePairingConInfo, - unitDataCon, stringTy, - realWorldStateTy, stateDataCon, - isFFIArgumentTy, unitTy, - addrTy, stablePtrTyCon, - stateAndPtrPrimDataCon +import PprType ( {- instance Outputable Type -} ) +import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) ) +import Var ( TyVar ) +import TysPrim ( realWorldStatePrimTy, addrPrimTy ) +import TysWiredIn ( unitTy, addrTy, stablePtrTyCon, + addrDataCon ) +import Unique ( Uniquable(..), hasKey, + ioTyConKey, deRefStablePtrIdKey, returnIOIdKey, + bindIOIdKey, makeStablePtrIdKey + ) +import Maybes ( maybeToBool ) import Outputable \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 :: Module + -> [TypecheckedForeignDecl] + -> DsM ( [CoreBind] -- desugared foreign imports + , [CoreBind] -- helper functions for foreign exports + , SDoc -- Header file prototypes for + -- "foreign exported" functions. + , SDoc -- C stubs to use when calling + -- "foreign exported" functions. ) -dsForeigns fos = foldlDs combine ([],[],empty,empty,empty) fos +dsForeigns mod_name fos = foldlDs combine ([],[],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) - + combine (acc_fi, acc_fe, 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 (bs ++ acc_fi, acc_fe, acc_h, acc_c) + | isForeignLabel = + dsFLabel i ext_nm `thenDs` \ b -> + returnDs (b:acc_fi, acc_fe, acc_h, acc_c) + | isDynamicExtName ext_nm = + dsFExportDynamic i (idType i) mod_name ext_nm cconv `thenDs` \ (fi,fe,h,c) -> + returnDs (fi:acc_fi, fe:acc_fe, h $$ acc_h, c $$ acc_c) + + | otherwise = -- foreign export + dsFExport i (idType i) mod_name ext_nm cconv False `thenDs` \ (fe,h,c) -> + returnDs (acc_fi, fe:acc_fe, h $$ acc_h, c $$ acc_c) where - isForeignImport = maybeToBool imp_exp - (Just uns) = imp_exp + isForeignImport = + case imp_exp of + FoImport _ -> True + _ -> False + + isForeignLabel = + case imp_exp of + FoLabel -> True + _ -> False + + (FoImport uns) = imp_exp \end{code} 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 @@ -106,179 +129,171 @@ dsFImport :: Id -> 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 + -> DsM [CoreBind] +dsFImport fn_id ty may_not_gc ext_name cconv + = let + (tvs, fun_ty) = splitForAllTys ty + (arg_tys, io_res_ty) = splitFunTys fun_ty in - boxResult ioOkDataCon result_ty `thenDs` \ (final_result_ty, res_wrapper) -> + newSysLocalsDs arg_tys `thenDs` \ args -> + mapAndUnzipDs unboxArg (map Var args) `thenDs` \ (val_args, arg_wrappers) -> + boxResult io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) -> + (case ext_name of - Dynamic -> getUniqueDs `thenDs` \ u -> returnDs (Right u) - ExtName fs _ -> returnDs (Left fs)) `thenDs` \ label -> - let - 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 -> + Dynamic -> getUniqueDs `thenDs` \ u -> + returnDs (DynamicTarget u) + ExtName fs _ -> returnDs (StaticTarget fs)) `thenDs` \ lbl -> + + getUniqueDs `thenDs` \ ccall_uniq -> + getUniqueDs `thenDs` \ work_uniq -> 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) + -- Build the worker + work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars + worker_ty = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty) + the_ccall = CCall lbl False (not may_not_gc) cconv + the_ccall_app = mkCCall ccall_uniq the_ccall 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 + + -- 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 (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) + returnDs [NonRec fn_id wrap_rhs, NonRec work_id work_rhs] +\end{code} + +Foreign labels + +\begin{code} +dsFLabel :: Id -> ExtName -> DsM CoreBind +dsFLabel nm ext_name = returnDs (NonRec nm fo_rhs) where - (tvs, sans_foralls) = splitForAllTys ty - + fo_rhs = mkConApp addrDataCon [mkLit (MachLitLit enm addrPrimTy)] + enm = extNameStatic ext_name \end{code} +The function that does most of the work for `@foreign export@' declarations. +(see below for the boilerplate code a `@foreign export@' declaration expands + into.) + +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@'. + \begin{code} dsFExport :: Id -> Type -- Type of foreign export. + -> Module -> 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 -> + -> DsM ( CoreBind + , SDoc + , SDoc + ) +dsFExport fn_id ty mod_name 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) + -- If it's plain t, return (\x.returnIO x, IO t, t) + (case splitTyConApp_maybe orig_res_ty of + Just (ioTyCon, [res_ty]) + -> ASSERT( ioTyCon `hasKey` ioTyConKey ) + -- The function already returns IO t + returnDs (\body -> body, orig_res_ty, res_ty) + + other -> -- The function returns t, so wrap the call in returnIO + dsLookupGlobalValue returnIOIdKey `thenDs` \ retIOId -> + returnDs (\body -> mkApps (Var retIOId) [Type orig_res_ty, body], + funResultTy (applyTy (idType retIOId) orig_res_ty), + -- We don't have ioTyCon conveniently to hand + orig_res_ty) + + ) `thenDs` \ (return_io_wrapper, -- Either identity or returnIO + io_res_ty, -- IO t + res_ty) -> -- t + + + -- BUILD THE deRefStablePtr WRAPPER, if necessary (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 -> + newSysLocalDs stbl_ptr_to_ty `thenDs` \ stbl_value -> + dsLookupGlobalValue deRefStablePtrIdKey `thenDs` \ deRefStablePtrId -> + dsLookupGlobalValue bindIOIdKey `thenDs` \ bindIOId -> let - stbl_app = \ cont -> - Case the_deref_app - (AlgAlts [(stateAndPtrPrimDataCon, [s11, f], cont)] - NoDefault) + the_deref_app = mkApps (Var deRefStablePtrId) + [ Type stbl_ptr_to_ty, Var stbl_ptr ] + + stbl_app cont = mkApps (Var bindIOId) + [ Type stbl_ptr_to_ty + , Type res_ty + , the_deref_app + , mkLams [stbl_value] cont] in - returnDs (f, stbl_app, s11, stbl_ptr) + returnDs (stbl_value, stbl_app, stbl_ptr) else - returnDs (i, + returnDs (fn_id, \ body -> body, - s1, panic "stbl_ptr" -- should never be touched. - )) `thenDs` \ (i, getFun_wrapper, s2, stbl_ptr) -> - let - (boxed_args, arg_wrappers) = unzip stuff - - wrapper_args - | isDyn = stbl_ptr:helper_args - | otherwise = helper_args + )) `thenDs` \ (i, getFun_wrapper, stbl_ptr) -> - wrapper_arg_tys - | isDyn = stbl_ptr_ty:helper_arg_tys - | otherwise = helper_arg_tys - 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 -> + -- BUILD THE HELPER + getModuleDs `thenDs` \ mod -> + getUniqueDs `thenDs` \ uniq -> + getSrcLocDs `thenDs` \ src_loc -> + newSysLocalsDs fe_arg_tys `thenDs` \ fe_args -> let - - 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)) - - c_nm = - case ext_name of - ExtName fs _ -> fs - - full_msg = "Exception caught: " ++ _UNPK_ (nameString (idName i)) - msg = NoRepStr (_PK_ full_msg) - err = mkApp (Var eRROR_ID) [state_and_prim_ty] [LitArg msg] - - 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 + wrapper_args | isDyn = stbl_ptr:fe_args + | otherwise = fe_args + + wrapper_arg_tys | isDyn = stbl_ptr_ty:fe_arg_tys + | otherwise = fe_arg_tys + + helper_ty = mkForAllTys tvs $ + mkFunTys wrapper_arg_tys io_res_ty + + f_helper_glob = mkVanillaId helper_name helper_ty + where + name = idName fn_id + mod + | isLocalName name = mod_name + | otherwise = nameModule name + + occ = mkForeignExportOcc (nameOccName name) + prov = LocalDef src_loc Exported + helper_name = mkGlobalName uniq mod occ prov + + 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 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 + returnDs (NonRec f_helper_glob the_body, h_stub, c_stub) - 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 + where + (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' - 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)) + fe_arg_tys | isDyn = tail fe_arg_tys' + | otherwise = fe_arg_tys' + + stbl_ptr_ty | isDyn = head fe_arg_tys' + | otherwise = error "stbl_ptr_ty" \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. @@ -310,218 +325,75 @@ foreign export "f_helper" f_helper :: StablePtr (Addr -> Int -> IO Int) -> Addr \begin{code} dsFExportDynamic :: Id -> Type -- Type of foreign export. + -> Module -> ExtName -> CallConv - -> DsM (CoreBinding, CoreBinding, SDoc, SDoc, SDoc) -dsFExportDynamic i ty ext_name cconv = + -> DsM (CoreBind, CoreBind, SDoc, SDoc) +dsFExportDynamic i ty mod_name ext_name 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 = toCName fe_id + fe_nm = moduleUserString mod_name ++ "_" ++ toCName fe_id fe_ext_name = ExtName (_PK_ fe_nm) Nothing 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) -> + dsFExport i export_ty mod_name fe_ext_name cconv True + `thenDs` \ (fe@(NonRec fe_helper fe_expr), h_code, c_code) -> + newSysLocalDs arg_ty `thenDs` \ cback -> + dsLookupGlobalValue makeStablePtrIdKey `thenDs` \ makeStablePtrId -> 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 = Left SLIT("createAdjustor") - the_ccall_op = CCallOp label False False{-won't GC-} cCallConv - (map coreExprType ccall_args) - stateAndAddrPrimTy + mk_stbl_ptr_app = mkApps (Var makeStablePtrId) [ Type arg_ty, Var cback ] 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 -> + dsLookupGlobalValue bindIOIdKey `thenDs` \ bindIOId -> + newSysLocalDs (mkTyConApp stablePtrTyCon [arg_ty]) `thenDs` \ stbl_value -> 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) + stbl_app cont ret_ty + = mkApps (Var bindIOId) + [ Type (mkTyConApp stablePtrTyCon [arg_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 (callConvToInt cconv) + , Var stbl_value + , mkLit (MachLitLit (_PK_ fe_nm) addrPrimTy) + ] + -- name of external entry point providing these services. + -- (probably in the RTS.) + adjustor = SLIT("createAdjustor") + in + dsCCall adjustor adj_args False False ioAddrTy `thenDs` \ ccall_adj -> + let ccall_adj_ty = exprType ccall_adj + ccall_io_adj = mkLams [stbl_value] $ + Note (Coerce io_res_ty (unUsgTy ccall_adj_ty)) + ccall_adj + in + let io_app = mkLams tvs $ + mkLams [cback] $ + stbl_app ccall_io_adj addrTy + in + returnDs (NonRec i io_app, fe, h_code, c_code) + where (tvs,sans_foralls) = splitForAllTys ty - ([arg_ty], io_res) = splitFunTys sans_foralls - (ioOkDataCon, ioDataCon, res_ty) = getIoOkDataCon io_res + ([arg_ty], io_res_ty) = splitFunTys sans_foralls - ioDataConTy = idType ioDataCon - (io_tvs, ioDataConTy') = splitForAllTys ioDataConTy --- ([arg_ty], _) = splitFunTys ioDataConTy' - io_result_ty = applyTy (mkForAllTys io_tvs arg_ty) res_ty + Just (ioTyCon, [res_ty]) = splitTyConApp_maybe io_res_ty export_ty = mkFunTy (mkTyConApp stablePtrTyCon [arg_ty]) arg_ty + ioAddrTy :: Type -- IO Addr + ioAddrTy = mkTyConApp ioTyCon [addrTy] + 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} %* @@ -530,277 +402,98 @@ 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 ) +fexportEntry :: String + -> FAST_STRING + -> Id + -> [Type] + -> Type + -> CallConv + -> Bool + -> (SDoc, SDoc) +fexportEntry mod_nm c_nm helper args res_ty cc isDyn = (header_bits, c_bits) where - (h_code, c_code) = mkCStub c_nm h_stub_nm args res cc - - paramArea = - vcat (zipWith declVar ( res_ty : param_tys ) ( res_name : param_names ) ) - -- 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" - - param_names = zipWith (\ i _ -> h_stub_nm <> text ('_':show i)) [1..] args - param_tys = map (ppr.typePrimRep) args + h_nm = ppr helper <> text "_closure" + -- prototype for the exported function. + header_bits = ptext SLIT("extern") <+> fun_proto <> semi - (res_name, res_ty) = - case res of - Nothing -> (empty, empty) - Just t -> (h_stub_nm <> text "_res", ppr (typePrimRep t)) + fun_proto = cResType <+> pprCconv <+> ptext c_nm <> + parens (hsep (punctuate comma (zipWith (<+>) cParamTypes proto_args))) - startTemplate = + c_bits = + externDecl $$ + fun_proto $$ 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);" + [ lbrace + , text "SchedulerStatus rc;" + , declareResult + -- create the application + perform it. + , text "rc=rts_evalIO" <> + parens (foldl appArg (text "(StgClosure*)&" <> h_nm) (zip args c_args) <> comma <> text "&ret") <> semi + , text "rts_checkSchedStatus" <> parens (doubleQuotes (ptext c_nm) + <> comma <> text "rc") <> semi + , text "return" <> return_what <> semi + , rbrace + ] - pushCont = - text "RetReg=(StgRetAddr)UNVEC(stop" <> h_stub_nm <> - text "DirectReturn,vtbl_" <> h_stub_nm <> text ");" + appArg acc (a,c_a) = + text "rts_apply" <> parens (acc <> comma <> mkHObj a <> parens c_a) - pushRealWorld = - text "SpB -= BREL(1);" $$ - text "*SpB = (W_)realWorldZh_closure;" + cParamTypes = map showStgType real_args + res_ty_is_unit = res_ty == unitTy - 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 - ] - ) - 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) + cResType | res_ty_is_unit = text "void" + | otherwise = showStgType res_ty pprCconv | cc == cCallConv = empty | otherwise = pprCallConv cc - externDecls = - vcat (zipWith mkExtern cParamTypes param_names) $$ - cResDecl $$ - text "extern void" <+> h_stub_nm <> text "();" + declareResult = text "HaskellObj ret;" + + externDecl = mkExtern (text "HaskellObj") h_nm mkExtern ty nm = text "extern" <+> ty <+> nm <> semi - c_args = zipWith (\ _ n -> text ('a':show n)) args [0..] + return_what | res_ty_is_unit = empty + | otherwise = parens (unpackHObj res_ty <> parens (text "ret")) - assignArgs p_nm c_arg = p_nm <+> equals <+> c_arg <> semi + c_args = mkCArgNames 0 args - returnResult = - case res of - Nothing -> empty - Just _ -> text "return" <+> res_name <> semi + {- + If we're generating an entry point for a 'foreign export ccall dynamic', + then we receive the return address of the C function that wants to + invoke a Haskell function as any other C function, as second arg. + This arg is unused within the body of the generated C stub, but + needed by the Adjustor.c code to get the stack cleanup right. + -} + (proto_args, real_args) + | cc == cCallConv && isDyn = ( text "a0" : text "a_" : mkCArgNames 1 (tail args) + , head args : addrTy : tail args) + | otherwise = (mkCArgNames 0 args, args) - (res_name, res_ty) = - case res of - Nothing -> (empty, empty) - Just t -> (h_stub_nm <> text "_res", ppr (typePrimRep t)) +mkCArgNames :: Int -> [a] -> [SDoc] +mkCArgNames n as = zipWith (\ _ n -> text ('a':show n)) as [n..] -declVar :: SDoc -> SDoc -> SDoc -declVar ty var = ty <+> var <> semi +mkHObj :: Type -> SDoc +mkHObj t = text "rts_mk" <> text (showFFIType t) -\end{code} +unpackHObj :: Type -> SDoc +unpackHObj t = text "rts_get" <> text (showFFIType t) -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} +showStgType :: Type -> SDoc +showStgType t = text "Stg" <> text (showFFIType t) + +showFFIType :: Type -> String +showFFIType t = getOccString (getName tc) + where + tc = case splitTyConApp_maybe (repType t) of + Just (tc,_) -> tc + Nothing -> pprPanic "showFFIType" (ppr t) +\end{code}