Commit 4c72f121 authored by simonmar's avatar simonmar
Browse files

[project @ 2001-05-03 14:31:58 by simonmar]

Arrange to call touch# on each ForeignObj# argument after a 'safe'
foreign import call.

This turned out to be the easiest place to implement it: if we'd done
it in CorePrep or CoreToStg, it would have been awkward to generate
the simplest code.  At least doing it in the desugarer gives the
simplifier a crack at it later.
parent bbc670f4
......@@ -19,8 +19,8 @@ import CoreSyn
import DsMonad
import CoreUtils ( exprType, mkCoerce )
import Id ( mkWildId )
import MkId ( mkCCallOpId, realWorldPrimId )
import Id ( Id, mkWildId, idType )
import MkId ( mkCCallOpId, realWorldPrimId, mkPrimOpId )
import Maybes ( maybeToBool )
import PrimOp ( CCall(..), CCallTarget(..) )
import DataCon ( splitProductType_maybe, dataConSourceArity, dataConWrapId )
......@@ -30,8 +30,10 @@ import Type ( isUnLiftedType, splitAlgTyConApp_maybe, mkFunTys,
isNewType, repType, isUnLiftedType, mkFunTy, mkTyConApp,
Type
)
import PrimOp ( PrimOp(TouchOp) )
import TysPrim ( realWorldStatePrimTy,
byteArrayPrimTyCon, mutableByteArrayPrimTyCon, intPrimTy
byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
intPrimTy, foreignObjPrimTy
)
import TysWiredIn ( unitDataConId,
unboxedSingletonDataCon, unboxedPairDataCon,
......@@ -91,7 +93,7 @@ dsCCall :: CLabelString -- C routine to invoke
dsCCall lbl args may_gc is_asm result_ty
= mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
boxResult result_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
boxResult [] result_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
getUniqueDs `thenDs` \ uniq ->
let
the_ccall = CCall (StaticTarget lbl) is_asm may_gc cCallConv
......@@ -191,7 +193,7 @@ unboxArg arg
\begin{code}
boxResult :: Type -> DsM (Type, CoreExpr -> CoreExpr)
boxResult :: [Id] -> Type -> DsM (Type, CoreExpr -> CoreExpr)
-- Takes the result of the user-level ccall:
-- either (IO t),
......@@ -204,20 +206,28 @@ boxResult :: Type -> DsM (Type, CoreExpr -> CoreExpr)
-- the result type will be
-- State# RealWorld -> (# State# RealWorld #)
boxResult result_ty
-- Here is where we arrange that ForeignPtrs which are passed to a 'safe'
-- foreign import don't get finalized until the call returns. For each
-- argument of type ForeignObj# we arrange to touch# the argument after
-- the call. The arg_ids passed in are the Ids passed to the actual ccall.
boxResult arg_ids result_ty
= case splitAlgTyConApp_maybe result_ty of
-- The result is IO t, so wrap the result in an IO constructor
Just (io_tycon, [io_res_ty], [io_data_con]) | io_tycon `hasKey` ioTyConKey
-> mk_alt return_result
(resultWrapper io_res_ty) `thenDs` \ (ccall_res_ty, the_alt) ->
newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
let
wrap = \ the_call -> mkApps (Var (dataConWrapId io_data_con))
[Type io_res_ty, Lam state_id $
Case (App the_call (Var state_id))
(mkWildId ccall_res_ty)
[the_alt]]
wrap = \ the_call ->
mkApps (Var (dataConWrapId io_data_con))
[ Type io_res_ty,
Lam state_id $
Case (App the_call (Var state_id))
(mkWildId ccall_res_ty)
[the_alt]
]
in
returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
where
......@@ -228,7 +238,7 @@ boxResult result_ty
-- It isn't, so do unsafePerformIO
-- It's not conveniently available, so we inline it
other -> mk_alt return_result
(resultWrapper result_ty) `thenDs` \ (ccall_res_ty, the_alt) ->
(resultWrapper result_ty) `thenDs` \ (ccall_res_ty, the_alt) ->
let
wrap = \ the_call -> Case (App the_call (Var realWorldPrimId))
(mkWildId ccall_res_ty)
......@@ -240,9 +250,13 @@ boxResult result_ty
where
mk_alt return_result (Nothing, wrap_result)
= -- The ccall returns ()
let
rhs_fun state_id = return_result (Var state_id)
(wrap_result (panic "boxResult"))
in
newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
mkTouches arg_ids state_id rhs_fun `thenDs` \ the_rhs ->
let
the_rhs = return_result (Var state_id) (wrap_result (panic "boxResult"))
ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy]
the_alt = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs)
in
......@@ -250,15 +264,29 @@ boxResult result_ty
mk_alt return_result (Just prim_res_ty, wrap_result)
= -- The ccall returns a non-() value
newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
newSysLocalDs prim_res_ty `thenDs` \ result_id ->
let
the_rhs = return_result (Var state_id) (wrap_result (Var result_id))
rhs_fun state_id = return_result (Var state_id)
(wrap_result (Var result_id))
in
newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
mkTouches arg_ids state_id rhs_fun `thenDs` \ the_rhs ->
let
ccall_res_ty = mkTyConApp unboxedPairTyCon [realWorldStatePrimTy, prim_res_ty]
the_alt = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs)
in
returnDs (ccall_res_ty, the_alt)
touchzh = mkPrimOpId TouchOp
mkTouches [] s cont = returnDs (cont s)
mkTouches (v:vs) s cont
| idType v /= foreignObjPrimTy = mkTouches vs s cont
| otherwise = newSysLocalDs realWorldStatePrimTy `thenDs` \s' ->
mkTouches vs s' cont `thenDs` \ rest ->
returnDs (Case (mkApps (Var touchzh) [Type foreignObjPrimTy,
Var v, Var s]) s'
[(DEFAULT, [], rest)])
resultWrapper :: Type
-> (Maybe Type, -- Type of the expected result, if any
......
......@@ -125,30 +125,39 @@ because it exposes the boxing to the call site.
\begin{code}
dsFImport :: Id
-> Type -- Type of foreign import.
-> Bool -- True <=> might cause Haskell GC
-> Bool -- True <=> cannot re-enter the Haskell RTS
-> ExtName
-> CallConv
-> DsM [Binding]
dsFImport fn_id ty may_not_gc ext_name cconv
dsFImport fn_id ty unsafe ext_name cconv
= let
(tvs, fun_ty) = splitForAllTys ty
(arg_tys, io_res_ty) = splitFunTys fun_ty
in
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) ->
getUniqueDs `thenDs` \ ccall_uniq ->
getUniqueDs `thenDs` \ work_uniq ->
let
work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars
-- these are the ids we pass to boxResult, which are used to decide
-- whether to touch# an argument after the call (used to keep
-- ForeignObj#s live across a 'safe' foreign import).
maybe_arg_ids | unsafe = []
| otherwise = work_arg_ids
in
boxResult work_arg_ids io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
getUniqueDs `thenDs` \ ccall_uniq ->
getUniqueDs `thenDs` \ work_uniq ->
let
lbl = case ext_name of
Dynamic -> dynamicTarget
ExtName fs _ -> StaticTarget fs
-- 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 = CCall lbl False (not unsafe) 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
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment