ForeignImport(..), CImportSpec(..) )
import TcHsSyn ( TypecheckedForeignDecl )
import CoreUtils ( exprType, mkInlineMe )
-import Id ( Id, idType, idName, mkVanillaGlobal, mkSysLocal,
- setInlinePragma )
-import IdInfo ( vanillaIdInfo )
+import Id ( Id, idType, idName, mkSysLocal, setInlinePragma )
import Literal ( Literal(..) )
-import Module ( Module, moduleUserString )
-import Name ( mkGlobalName, nameModule, nameOccName, getOccString,
- mkForeignExportOcc, isLocalName,
- NamedThing(..),
- )
+import Module ( moduleString )
+import Name ( getOccString, NamedThing(..) )
import OccName ( encodeFS )
import Type ( repType, eqType )
import TcType ( Type, mkFunTys, mkForAllTys, mkTyConApp,
- mkFunTy, applyTy,
+ mkFunTy, tcSplitTyConApp_maybe,
tcSplitForAllTys, tcSplitFunTys, tcTyConAppArgs,
- tcSplitTyConApp_maybe, tcSplitAppTy,
- tcFunResultTy
)
+import HscTypes ( ForeignStubs(..) )
import ForeignCall ( ForeignCall(..), CCallSpec(..),
Safety(..), playSafe,
CExportSpec(..),
ccallConvAttribute
)
import CStrings ( CLabelString )
-import TysWiredIn ( addrTy, unitTy, stablePtrTyCon )
+import TysWiredIn ( unitTy, stablePtrTyCon )
import TysPrim ( addrPrimTy )
-import PrelNames ( hasKey, ioTyConKey, deRefStablePtrName, newStablePtrName,
- bindIOName, returnIOName
- )
+import PrelNames ( hasKey, ioTyConKey, newStablePtrName, bindIOName )
import BasicTypes ( Activation( NeverActive ) )
-import ErrUtils ( addShortWarnLocLine )
import Outputable
import Maybe ( fromJust )
+import FastString
\end{code}
Desugaring of @foreign@ declarations is naturally split up into
type Binding = (Id, CoreExpr) -- No rec/nonrec structure;
-- the occurrence analyser will sort it all out
-dsForeigns :: Module
- -> [TypecheckedForeignDecl]
- -> DsM ( [Id] -- Foreign-exported binders;
- -- we have to generate code to register these
- , [Binding]
- , SDoc -- Header file prototypes for
- -- "foreign exported" functions.
- , SDoc -- C stubs to use when calling
- -- "foreign exported" functions.
- , [FAST_STRING] -- headers that need to be included
- -- into C code generated for this module
- )
-dsForeigns mod_name fos
- = foldlDs combine ([], [], empty, empty, []) fos
+dsForeigns :: [TypecheckedForeignDecl]
+ -> DsM (ForeignStubs, [Binding])
+dsForeigns fos
+ = foldlDs combine (ForeignStubs empty empty [] [], []) fos
where
- combine (acc_feb, acc_f, acc_h, acc_c, acc_header)
+ combine (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f)
(ForeignImport id _ spec depr loc)
- = dsFImport mod_name id spec `thenDs` \(bs, h, c, hd) ->
+ = dsFImport id spec `thenDs` \(bs, h, c, hd) ->
warnDepr depr loc `thenDs` \_ ->
- returnDs (acc_feb, bs ++ acc_f, h $$ acc_h, c $$ acc_c, hd ++ acc_header)
+ returnDs (ForeignStubs (h $$ acc_h) (c $$ acc_c) (hd ++ acc_hdrs) acc_feb,
+ bs ++ acc_f)
- combine (acc_feb, acc_f, acc_h, acc_c, acc_header)
+ combine (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f)
(ForeignExport id _ (CExport (CExportStatic ext_nm cconv)) depr loc)
- = dsFExport mod_name id (idType id)
+ = dsFExport id (idType id)
ext_nm cconv False `thenDs` \(h, c) ->
warnDepr depr loc `thenDs` \_ ->
- returnDs (acc_feb, acc_f, h $$ acc_h, c $$ acc_c, acc_header)
+ returnDs (ForeignStubs (h $$ acc_h) (c $$ acc_c) acc_hdrs (id:acc_feb),
+ acc_f)
warnDepr False _ = returnDs ()
- warnDepr True loc = dsWarn (addShortWarnLocLine loc msg)
+ warnDepr True loc = dsWarn (loc, msg)
where
msg = ptext SLIT("foreign declaration uses deprecated non-standard syntax")
\end{code}
because it exposes the boxing to the call site.
\begin{code}
-dsFImport :: Module
- -> Id
+dsFImport :: Id
-> ForeignImport
- -> DsM ([Binding], SDoc, SDoc, [FAST_STRING])
-dsFImport modName id (CImport cconv safety header lib spec)
- = dsCImport modName id spec cconv safety `thenDs` \(ids, h, c) ->
- returnDs (ids, h, c, if _NULL_ header then [] else [header])
+ -> DsM ([Binding], SDoc, SDoc, [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 [] else [header])
+ where
+ no_hdrs = nullFastString 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 `_NULL_ lib', the value was not given
-dsFImport modName id (DNImport spec)
- = dsFCall modName id (DNCall spec) `thenDs` \(ids, h, c) ->
+ -- 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, [])
-dsCImport :: Module
- -> Id
+dsCImport :: Id
-> CImportSpec
-> CCallConv
-> Safety
+ -> Bool -- True <=> no headers in the f.i decl
-> DsM ([Binding], SDoc, SDoc)
-dsCImport modName id (CLabel cid) _ _
+dsCImport id (CLabel cid) _ _ no_hdrs
= ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this
- returnDs ([(id, rhs)], empty, empty)
+ returnDs ([(setImpInline no_hdrs id, rhs)], empty, empty)
where
(resTy, foRhs) = resultWrapper (idType id)
rhs = foRhs (mkLit (MachLabel cid))
-dsCImport modName id (CFunction target) cconv safety
- = dsFCall modName id (CCall (CCallSpec target cconv safety))
-dsCImport modName id CWrapper cconv _
- = dsFExportDynamic modName id cconv
+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}
%************************************************************************
\begin{code}
-dsFCall mod_Name fn_id fcall
+dsFCall fn_id fcall no_hdrs
= let
ty = idType fn_id
(tvs, fun_ty) = tcSplitForAllTys ty
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 = mkSysLocal (encodeFS SLIT("$wccall")) work_uniq worker_ty
+ work_id = setImpInline no_hdrs $ -- See comments with setImpInline
+ mkSysLocal (encodeFS FSLIT("$wccall")) work_uniq worker_ty
-- Build the wrapper
work_app = mkApps (mkVarApps (Var work_id) tvs) val_args
the user-written Haskell function `@M.foo@'.
\begin{code}
-dsFExport :: Module
- -> Id -- Either the exported Id,
+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
, SDoc -- contents of Module_stub.c
)
-dsFExport mod_name fn_id ty ext_name cconv isDyn
+dsFExport fn_id ty ext_name cconv isDyn
=
let
(tvs,sans_foralls) = tcSplitForAllTys ty
)
`thenDs` \ (res_ty, -- t
is_IO_res_ty) -> -- Bool
- getModuleDs
- `thenDs` \ mod ->
let
(h_stub, c_stub)
- = mkFExportCBits (moduleUserString mod) ext_name
+ = mkFExportCBits ext_name
(if isDyn then Nothing else Just fn_id)
fe_arg_tys res_ty is_IO_res_ty cconv
in
\end{verbatim}
\begin{code}
-dsFExportDynamic :: Module
- -> Id
+dsFExportDynamic :: Id
-> CCallConv
-> DsM ([Binding], SDoc, SDoc)
-dsFExportDynamic mod_name id cconv
- = newSysLocalDs ty `thenDs` \ fe_id ->
+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 = _PK_ (moduleUserString mod_name ++ "_" ++ toCName fe_id)
+ fe_nm = mkFastString (moduleString mod_name ++ "_" ++ toCName fe_id)
in
- dsFExport mod_name id export_ty fe_nm cconv True `thenDs` \ (h_code, c_code) ->
- newSysLocalDs arg_ty `thenDs` \ cback ->
- dsLookupGlobalValue newStablePtrName `thenDs` \ newStablePtrId ->
+ dsFExport id export_ty fe_nm cconv True `thenDs` \ (h_code, c_code) ->
+ newSysLocalDs arg_ty `thenDs` \ cback ->
+ dsLookupGlobalId newStablePtrName `thenDs` \ newStablePtrId ->
let
mk_stbl_ptr_app = mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
in
- dsLookupGlobalValue bindIOName `thenDs` \ bindIOId ->
+ dsLookupGlobalId bindIOName `thenDs` \ bindIOId ->
newSysLocalDs (mkTyConApp stablePtrTyCon [arg_ty]) `thenDs` \ stbl_value ->
let
stbl_app cont ret_ty
]
-- name of external entry point providing these services.
-- (probably in the RTS.)
- adjustor = SLIT("createAdjustor")
+ adjustor = FSLIT("createAdjustor")
in
dsCCall adjustor adj_args PlayRisky False io_res_ty `thenDs` \ ccall_adj ->
-- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
using the hugs/ghc rts invocation API.
\begin{code}
-mkFExportCBits :: String
- -> FAST_STRING
+mkFExportCBits :: FastString
-> Maybe Id -- Just==static, Nothing==dynamic
-> [Type]
-> Type
-> Bool -- True <=> returns an IO type
-> CCallConv
-> (SDoc, SDoc)
-mkFExportCBits mod_nm c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
+mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
= (header_bits, c_bits)
where
-- Create up types and names for the real args
header_bits = ptext SLIT("extern") <+> fun_proto <> semi
- fun_proto = cResType <+> pprCconv <+> ptext c_nm <>
+ fun_proto = cResType <+> pprCconv <+> ftext c_nm <>
parens (hsep (punctuate comma (map (\(nm,ty) -> ty <+> nm)
all_cnames_and_ctys)))
the_cfun
= case maybe_target of
Nothing -> text "(StgClosure*)deRefStablePtr(the_stableptr)"
- Just hs_fn -> ppr hs_fn <> text "_closure"
+ Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"
-- the expression we give to rts_evalIO
expr_to_run
-- various other bits for inside the fn
declareResult = text "HaskellObj ret;"
+ declareCResult | res_hty_is_unit = empty
+ | otherwise = cResType <+> text "cret;"
- return_what | res_hty_is_unit = empty
- | otherwise = parens (unpackHObj res_hty <> parens (text "ret"))
+ 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
+ Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi
-- finally, the whole darn thing
c_bits =
[ lbrace
, text "SchedulerStatus rc;"
, declareResult
+ , declareCResult
+ , text "rts_lock();"
-- create the application + perform it.
- , text (if is_IO_res_ty then "rc=rts_evalIO" else "rc=rts_eval")
- <> parens (expr_to_run <+> comma <> text "&ret")
- <> semi
- , text "rts_checkSchedStatus" <> parens (doubleQuotes (ptext c_nm)
+ , text "rc=rts_evalIO" <> parens (
+ text "rts_apply" <> parens (
+ 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 "rc") <> semi
- , text "return" <> return_what <> semi
+ , assignCResult
+ , text "rts_unlock();"
+ , if res_hty_is_unit then empty
+ else text "return cret;"
, rbrace
]
projects / ghc-hetmet.git / blobdiff