import DsMonad
import DsUtils
-import HsSyn ( ExtName(..), ForeignDecl(..), isDynamic )
+import HsSyn ( ExtName(..), ForeignDecl(..), isDynamic, ForKind(..) )
import CallConv
import TcHsSyn ( maybeBoxedPrimType, TypecheckedForeignDecl )
import CoreUtils ( coreExprType )
realWorldStateTy, stateDataCon,
isFFIArgumentTy, unitTy,
addrTy, stablePtrTyCon,
- stateAndPtrPrimDataCon
+ stateAndPtrPrimDataCon,
+ addrDataCon
)
import Outputable
\end{code}
| isForeignImport =
dsFImport i (idType i) uns ext_nm cconv `thenDs` \ b ->
returnDs (b:acc_fi, acc_fe, acc_hc, acc_h, acc_c)
+ | isForeignLabel =
+ dsFLabel i ext_nm `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)
returnDs (acc_fi, fe:acc_fe, hc $$ acc_hc, 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}
(ioOkDataCon, ioDataCon, result_ty) = getIoOkDataCon io_res_ty
in
boxResult ioOkDataCon result_ty `thenDs` \ (final_result_ty, res_wrapper) ->
+ (case ext_name of
+ Dynamic -> getUniqueDs `thenDs` \ u -> returnDs (Right u)
+ ExtName fs _ -> returnDs (Left fs)) `thenDs` \ label ->
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
\end{code}
+
+\begin{code}
+dsFLabel :: Id -> ExtName -> DsM CoreBinding
+dsFLabel nm ext_name =
+ returnDs (NonRec nm fo_rhs)
+ where
+ fo_rhs = mkCon addrDataCon [] [LitArg (MachLitLit enm AddrRep)]
+ enm =
+ case ext_name of
+ ExtName f _ -> f
+
+\end{code}
+
+
+
\begin{code}
dsFExport :: Id
-> Type -- Type of foreign export.
Var stbl,
Lit (MachLitLit (_PK_ fe_nm) AddrRep)]
- label = Just SLIT("createAdjustor")
+ label = Left SLIT("createAdjustor")
the_ccall_op = CCallOp label False False{-won't GC-} cCallConv
(map coreExprType ccall_args)
stateAndAddrPrimTy