%
% (c) The University of Glasgow 2006
% (c) The AQUA Project, Glasgow University, 19941998
%
Desugaring foreign calls
\begin{code}
module DsCCall
( dsCCall
, mkFCall
, unboxArg
, boxResult
, resultWrapper
) where
#include "HsVersions.h"
import CoreSyn
import DsMonad
import CoreUtils
import MkCore
import Var
import MkId
import Maybes
import ForeignCall
import DataCon
import TcType
import Type
import Coercion
import PrimOp
import TysPrim
import TyCon
import TysWiredIn
import BasicTypes
import Literal
import PrelNames
import VarSet
import Constants
import Outputable
\end{code}
Desugaring of @ccall@s consists of adding some state manipulation,
unboxing any boxed primitive arguments and boxing the result if
desired.
The state stuff just consists of adding in
@PrimIO (\ s -> case s of { S# s# -> ... })@ in an appropriate place.
The unboxing is straightforward, as all information needed to unbox is
available from the type. For each boxedprimitive argument, we
transform:
\begin{verbatim}
_ccall_ foo [ r, t1, ... tm ] e1 ... em
|
|
V
case e1 of { T1# x1# ->
...
case em of { Tm# xm# -> xm#
ccall# foo [ r, t1#, ... tm# ] x1# ... xm#
} ... }
\end{verbatim}
The reboxing of a @_ccall_@ result is a bit tricker: the types don't
contain information about the statepairing functions so we have to
keep a list of \tr{(type, spfunction)} pairs. We transform as
follows:
\begin{verbatim}
ccall# foo [ r, t1#, ... tm# ] e1# ... em#
|
|
V
\ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of
(StateAnd<r># result# state#) -> (R# result#, realWorld#)
\end{verbatim}
\begin{code}
dsCCall :: CLabelString
-> [CoreExpr]
-> Safety
-> Type
-> DsM CoreExpr
dsCCall lbl args may_gc result_ty
= do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args
(ccall_result_ty, res_wrapper) <- boxResult result_ty
uniq <- newUnique
let
target = StaticTarget lbl
the_fcall = CCall (CCallSpec target CCallConv may_gc)
the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
mkFCall :: Unique -> ForeignCall
-> [CoreExpr]
-> Type
-> CoreExpr
mkFCall uniq the_fcall val_args res_ty
= mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args
where
arg_tys = map exprType val_args
body_ty = (mkFunTys arg_tys res_ty)
tyvars = varSetElems (tyVarsOfType body_ty)
ty = mkForAllTys tyvars body_ty
the_fcall_id = mkFCallId uniq the_fcall ty
\end{code}
\begin{code}
unboxArg :: CoreExpr
-> DsM (CoreExpr,
CoreExpr -> CoreExpr
)
unboxArg arg
| isPrimitiveType arg_ty
= return (arg, \body -> body)
| Just(_rep_ty, co) <- splitNewTypeRepCo_maybe arg_ty
= unboxArg (mkCoerce co arg)
| Just (tc,_) <- splitTyConApp_maybe arg_ty,
tc `hasKey` boolTyConKey
= do prim_arg <- newSysLocalDs intPrimTy
return (Var prim_arg,
\ body -> Case (mkWildCase arg arg_ty intPrimTy
[(DataAlt falseDataCon,[],mkIntLit 0),
(DataAlt trueDataCon, [],mkIntLit 1)])
prim_arg
(exprType body)
[(DEFAULT,[],body)])
| is_product_type && data_con_arity == 1
= ASSERT2(isUnLiftedType data_con_arg_ty1, pprType arg_ty)
do case_bndr <- newSysLocalDs arg_ty
prim_arg <- newSysLocalDs data_con_arg_ty1
return (Var prim_arg,
\ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)]
)
| is_product_type &&
data_con_arity == 3 &&
maybeToBool maybe_arg3_tycon &&
(arg3_tycon == byteArrayPrimTyCon ||
arg3_tycon == mutableByteArrayPrimTyCon)
= do case_bndr <- newSysLocalDs arg_ty
vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys
return (Var arr_cts_var,
\ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)]
)
| Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
tc == listTyCon,
Just (cc,[]) <- splitTyConApp_maybe arg_ty,
cc == charTyCon
= do unpack_id <- dsLookupGlobalId marshalStringName
prim_string <- newSysLocalDs addrPrimTy
return (Var prim_string,
\ body ->
let
io_ty = exprType body
Just (_,io_arg,_) = tcSplitIOType_maybe io_ty
in
mkApps (Var unpack_id)
[ Type io_arg
, arg
, Lam prim_string body
])
| Just (tc, [_]) <- splitTyConApp_maybe arg_ty,
tyConName tc == objectTyConName
= do unpack_id <- dsLookupGlobalId marshalObjectName
prim_obj <- newSysLocalDs addrPrimTy
return (Var prim_obj,
\ body ->
let
io_ty = exprType body
Just (_,io_arg,_) = tcSplitIOType_maybe io_ty
in
mkApps (Var unpack_id)
[ Type io_arg
, arg
, Lam prim_obj body
])
| otherwise
= do l <- getSrcSpanDs
pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
where
arg_ty = exprType arg
maybe_product_type = splitProductType_maybe arg_ty
is_product_type = maybeToBool maybe_product_type
Just (_, _, data_con, data_con_arg_tys) = maybe_product_type
data_con_arity = dataConSourceArity data_con
(data_con_arg_ty1 : _) = data_con_arg_tys
(_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
maybe_arg3_tycon = splitTyConApp_maybe data_con_arg_ty3
Just (arg3_tycon,_) = maybe_arg3_tycon
\end{code}
\begin{code}
boxResult :: Type
-> DsM (Type, CoreExpr -> CoreExpr)
boxResult result_ty
| Just (io_tycon, io_res_ty, co) <- tcSplitIOType_maybe result_ty
= do { res <- resultWrapper io_res_ty
; let extra_result_tys
= case res of
(Just ty,_)
| isUnboxedTupleType ty
-> let (Just (_, ls)) = splitTyConApp_maybe ty in tail ls
_ -> []
return_result state anss
= mkConApp (tupleCon Unboxed (2 + length extra_result_tys))
(map Type (realWorldStatePrimTy : io_res_ty : extra_result_tys)
++ (state : anss))
; (ccall_res_ty, the_alt) <- mk_alt return_result res
; state_id <- newSysLocalDs realWorldStatePrimTy
; let io_data_con = head (tyConDataCons io_tycon)
toIOCon = dataConWrapId io_data_con
wrap the_call = mkCoerceI (mkSymCoI co) $
mkApps (Var toIOCon)
[ Type io_res_ty,
Lam state_id $
mkWildCase (App the_call (Var state_id))
ccall_res_ty
(coreAltType the_alt)
[the_alt]
]
; return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) }
boxResult result_ty
= do
res <- resultWrapper result_ty
(ccall_res_ty, the_alt) <- mk_alt return_result res
let
wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId))
ccall_res_ty
(coreAltType the_alt)
[the_alt]
return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
where
return_result _ [ans] = ans
return_result _ _ = panic "return_result: expected single result"
mk_alt :: (Expr Var -> [Expr Var] -> Expr Var)
-> (Maybe Type, Expr Var -> Expr Var)
-> DsM (Type, (AltCon, [Id], Expr Var))
mk_alt return_result (Nothing, wrap_result)
= do
state_id <- newSysLocalDs realWorldStatePrimTy
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)
return (ccall_res_ty, the_alt)
mk_alt return_result (Just prim_res_ty, wrap_result)
| isUnboxedTupleType prim_res_ty= do
let
Just (_, ls) = splitTyConApp_maybe prim_res_ty
arity = 1 + length ls
args_ids@(result_id:as) <- mapM newSysLocalDs ls
state_id <- newSysLocalDs realWorldStatePrimTy
let
the_rhs = return_result (Var state_id)
(wrap_result (Var result_id) : map Var as)
ccall_res_ty = mkTyConApp (tupleTyCon Unboxed arity)
(realWorldStatePrimTy : ls)
the_alt = ( DataAlt (tupleCon Unboxed arity)
, (state_id : args_ids)
, the_rhs
)
return (ccall_res_ty, the_alt)
| otherwise = do
result_id <- newSysLocalDs prim_res_ty
state_id <- newSysLocalDs realWorldStatePrimTy
let
the_rhs = return_result (Var state_id)
[wrap_result (Var result_id)]
ccall_res_ty = mkTyConApp unboxedPairTyCon [realWorldStatePrimTy, prim_res_ty]
the_alt = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs)
return (ccall_res_ty, the_alt)
resultWrapper :: Type
-> DsM (Maybe Type,
CoreExpr -> CoreExpr)
resultWrapper result_ty
| isPrimitiveType result_ty
= return (Just result_ty, \e -> e)
| Just (tc,_) <- maybe_tc_app, tc `hasKey` unitTyConKey
= return (Nothing, \_ -> Var unitDataConId)
| Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey
= return
(Just intPrimTy, \e -> mkWildCase e intPrimTy
boolTy
[(DEFAULT ,[],Var trueDataConId ),
(LitAlt (mkMachInt 0),[],Var falseDataConId)])
| Just (rep_ty, co) <- splitNewTypeRepCo_maybe result_ty
= do (maybe_ty, wrapper) <- resultWrapper rep_ty
return (maybe_ty, \e -> mkCoerce (mkSymCoercion co) (wrapper e))
| Just (tyvar, rest) <- splitForAllTy_maybe result_ty
= do (maybe_ty, wrapper) <- resultWrapper rest
return (maybe_ty, \e -> Lam tyvar (wrapper e))
| Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitProductType_maybe result_ty,
dataConSourceArity data_con == 1
= do let
(unwrapped_res_ty : _) = data_con_arg_tys
narrow_wrapper = maybeNarrow tycon
(maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty
return
(maybe_ty, \e -> mkApps (Var (dataConWrapId data_con))
(map Type tycon_arg_tys ++ [wrapper (narrow_wrapper e)]))
| Just (tc, [arg_ty]) <- maybe_tc_app, tc == listTyCon,
Just (cc,[]) <- splitTyConApp_maybe arg_ty, cc == charTyCon
= do pack_id <- dsLookupGlobalId unmarshalStringName
return (Just addrPrimTy,
\ e -> App (Var pack_id) e)
| Just (tc, [_]) <- maybe_tc_app,
tyConName tc == objectTyConName
= do pack_id <- dsLookupGlobalId unmarshalObjectName
return (Just addrPrimTy,
\ e -> App (Var pack_id) e)
| otherwise
= pprPanic "resultWrapper" (ppr result_ty)
where
maybe_tc_app = splitTyConApp_maybe result_ty
maybeNarrow :: TyCon -> (CoreExpr -> CoreExpr)
maybeNarrow tycon
| tycon `hasKey` int8TyConKey = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e
| tycon `hasKey` int16TyConKey = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e
| tycon `hasKey` int32TyConKey
&& wORD_SIZE > 4 = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e
| tycon `hasKey` word8TyConKey = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e
| tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e
| tycon `hasKey` word32TyConKey
&& wORD_SIZE > 4 = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e
| otherwise = id
\end{code}