path: root/compiler/deSugar/DsCCall.lhs

%
% (c) The AQUA Project, Glasgow University, 1994-1998
%
\section[DsCCall]{Desugaring C calls}

\begin{code}
module DsCCall 
	( dsCCall
	, mkFCall
	, unboxArg
	, boxResult
	, resultWrapper
	) where

#include "HsVersions.h"


import CoreSyn

import DsMonad

import CoreUtils	( exprType, coreAltType, mkCoerce2 )
import Id		( Id, mkWildId )
import MkId		( mkFCallId, realWorldPrimId, mkPrimOpId )
import Maybes		( maybeToBool )
import ForeignCall	( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety, 
			  CCallConv(..), CLabelString )
import DataCon		( splitProductType_maybe, dataConSourceArity, dataConWrapId )

import TcType		( tcSplitTyConApp_maybe )
import Type		( Type, isUnLiftedType, mkFunTys, mkFunTy,
			  tyVarsOfType, mkForAllTys, mkTyConApp, 
			  isPrimitiveType, splitTyConApp_maybe, 
			  splitRecNewType_maybe, splitForAllTy_maybe,
			  isUnboxedTupleType
			)

import PrimOp		( PrimOp(..) )
import TysPrim		( realWorldStatePrimTy, intPrimTy,
			  byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
			  addrPrimTy
			)
import TyCon		( TyCon, tyConDataCons, tyConName )
import TysWiredIn	( unitDataConId,
			  unboxedSingletonDataCon, unboxedPairDataCon,
			  unboxedSingletonTyCon, unboxedPairTyCon,
			  trueDataCon, falseDataCon, 
			  trueDataConId, falseDataConId,
			  listTyCon, charTyCon, boolTy, 
			  tupleTyCon, tupleCon
			)
import BasicTypes       ( Boxity(..) )
import Literal		( mkMachInt )
import PrelNames	( Unique, hasKey, ioTyConKey, boolTyConKey, unitTyConKey,
			  int8TyConKey, int16TyConKey, int32TyConKey,
			  word8TyConKey, word16TyConKey, word32TyConKey
			  -- dotnet interop
			  , marshalStringName, unmarshalStringName
			  , marshalObjectName, unmarshalObjectName
			  , objectTyConName
			)
import VarSet		( varSetElems )
import Constants	( wORD_SIZE)
import Outputable

#ifdef DEBUG
import TypeRep
#endif

\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 boxed-primitive 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 state-pairing functions so we have to
keep a list of \tr{(type, s-p-function)} 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	-- C routine to invoke
	-> [CoreExpr]	-- Arguments (desugared)
	-> Safety	-- Safety of the call
	-> Type		-- Type of the result: IO t
	-> DsM CoreExpr

dsCCall lbl args may_gc result_ty
  = mapAndUnzipDs unboxArg args	       `thenDs` \ (unboxed_args, arg_wrappers) ->
    boxResult id Nothing result_ty  `thenDs` \ (ccall_result_ty, res_wrapper) ->
    newUnique			       `thenDs` \ uniq ->
    let
	target = StaticTarget lbl
	the_fcall    = CCall (CCallSpec target CCallConv may_gc)
 	the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
    in
    returnDs (foldr ($) (res_wrapper the_prim_app) arg_wrappers)

mkFCall :: Unique -> ForeignCall 
	-> [CoreExpr] 	-- Args
	-> Type 	-- Result type
	-> CoreExpr
-- Construct the ccall.  The only tricky bit is that the ccall Id should have
-- no free vars, so if any of the arg tys do we must give it a polymorphic type.
-- 	[I forget *why* it should have no free vars!]
-- For example:
--	mkCCall ... [s::StablePtr (a->b), x::Addr, c::Char]
--
-- Here we build a ccall thus
--	(ccallid::(forall a b.  StablePtr (a -> b) -> Addr -> Char -> IO Addr))
--			a b s x c
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			-- The supplied argument
	 -> DsM (CoreExpr,		-- To pass as the actual argument
		 CoreExpr -> CoreExpr	-- Wrapper to unbox the arg
		)
-- Example: if the arg is e::Int, unboxArg will return
--	(x#::Int#, \W. case x of I# x# -> W)
-- where W is a CoreExpr that probably mentions x#

unboxArg arg
  -- Primtive types: nothing to unbox
  | isPrimitiveType arg_ty
  = returnDs (arg, \body -> body)

  -- Recursive newtypes
  | Just rep_ty <- splitRecNewType_maybe arg_ty
  = unboxArg (mkCoerce2 rep_ty arg_ty arg)
      
  -- Booleans
  | Just (tc,_) <- splitTyConApp_maybe arg_ty, 
    tc `hasKey` boolTyConKey
  = newSysLocalDs intPrimTy		`thenDs` \ prim_arg ->
    returnDs (Var prim_arg,
	      \ body -> Case (Case arg (mkWildId arg_ty) intPrimTy
  		                       [(DataAlt falseDataCon,[],mkIntLit 0),
	                                (DataAlt trueDataCon, [],mkIntLit 1)])
					-- In increasing tag order!
                             prim_arg
                             (exprType body) 
			     [(DEFAULT,[],body)])

  -- Data types with a single constructor, which has a single, primitive-typed arg
  -- This deals with Int, Float etc; also Ptr, ForeignPtr
  | is_product_type && data_con_arity == 1 
  = ASSERT2(isUnLiftedType data_con_arg_ty1, pprType arg_ty)
			-- Typechecker ensures this
    newSysLocalDs arg_ty		`thenDs` \ case_bndr ->
    newSysLocalDs data_con_arg_ty1	`thenDs` \ prim_arg ->
    returnDs (Var prim_arg,
	      \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)]
    )

  -- Byte-arrays, both mutable and otherwise; hack warning
  -- We're looking for values of type ByteArray, MutableByteArray
  --	data ByteArray          ix = ByteArray        ix ix ByteArray#
  --	data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)
  | is_product_type &&
    data_con_arity == 3 &&
    maybeToBool maybe_arg3_tycon &&
    (arg3_tycon ==  byteArrayPrimTyCon ||
     arg3_tycon ==  mutableByteArrayPrimTyCon)
  = newSysLocalDs arg_ty		`thenDs` \ case_bndr ->
    newSysLocalsDs data_con_arg_tys	`thenDs` \ vars@[l_var, r_var, arr_cts_var] ->
    returnDs (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
    -- String; dotnet only
  = dsLookupGlobalId marshalStringName `thenDs` \ unpack_id ->
    newSysLocalDs addrPrimTy	       `thenDs` \ prim_string ->
    returnDs (Var prim_string,
    	      \ body ->
	        let
		 io_ty = exprType body
		 (Just (_,[io_arg])) = tcSplitTyConApp_maybe io_ty
		in
	      	mkApps (Var unpack_id)
		       [ Type io_arg
		       , arg
		       , Lam prim_string body
		       ])
  | Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
    tyConName tc == objectTyConName
    -- Object; dotnet only
  = dsLookupGlobalId marshalObjectName `thenDs` \ unpack_id ->
    newSysLocalDs addrPrimTy	       `thenDs` \ prim_obj  ->
    returnDs (Var prim_obj,
    	      \ body ->
	        let
		 io_ty = exprType body
		 (Just (_,[io_arg])) = tcSplitTyConApp_maybe io_ty
		in
	      	mkApps (Var unpack_id)
		       [ Type io_arg
		       , arg
		       , Lam prim_obj body
		       ])

  | otherwise
  = getSrcSpanDs `thenDs` \ l ->
    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 :: ((Maybe Type, CoreExpr -> CoreExpr) -> (Maybe Type, CoreExpr -> CoreExpr))
	  -> Maybe Id
	  -> Type
	  -> DsM (Type, CoreExpr -> CoreExpr)

-- Takes the result of the user-level ccall: 
--	either (IO t), 
--	or maybe just t for an side-effect-free call
-- Returns a wrapper for the primitive ccall itself, along with the
-- type of the result of the primitive ccall.  This result type
-- will be of the form  
--	State# RealWorld -> (# State# RealWorld, t' #)
-- where t' is the unwrapped form of t.  If t is simply (), then
-- the result type will be 
--	State# RealWorld -> (# State# RealWorld #)

boxResult augment mbTopCon result_ty
  = case tcSplitTyConApp_maybe result_ty of
	-- This split absolutely has to be a tcSplit, because we must
	-- see the IO type; and it's a newtype which is transparent to splitTyConApp.

	-- The result is IO t, so wrap the result in an IO constructor
	Just (io_tycon, [io_res_ty]) | io_tycon `hasKey` ioTyConKey
		-> resultWrapper io_res_ty             `thenDs` \ res ->
		   let aug_res          = augment res
		       extra_result_tys =
		         case aug_res of
			   (Just ty,_) 
			     | isUnboxedTupleType ty ->
			        let (Just (_, ls)) = splitTyConApp_maybe ty in tail ls
			   _ -> []
	           in
		   mk_alt (return_result extra_result_tys) aug_res 
		   					`thenDs` \ (ccall_res_ty, the_alt) ->
		   newSysLocalDs  realWorldStatePrimTy  `thenDs` \ state_id ->
		   let
			io_data_con = head (tyConDataCons io_tycon)
			toIOCon = 
			  case mbTopCon of
			    Nothing -> dataConWrapId io_data_con
			    Just x  -> x
			wrap = \ the_call -> 
				 mkApps (Var toIOCon)
					   [ Type io_res_ty, 
					     Lam state_id $
					      Case (App the_call (Var state_id))
						   (mkWildId ccall_res_ty)
                                                   (coreAltType the_alt) 
						   [the_alt]
					   ]
		   in
		   returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
		where
		   return_result ts state anss 
		     = mkConApp (tupleCon Unboxed (2 + length ts))
			        (Type realWorldStatePrimTy : Type io_res_ty : map Type ts ++
			         state : anss) 
	-- It isn't, so do unsafePerformIO
	-- It's not conveniently available, so we inline it
	other -> resultWrapper result_ty            `thenDs` \ res ->
	         mk_alt return_result (augment res) `thenDs` \ (ccall_res_ty, the_alt) ->
		 let
		    wrap = \ the_call -> Case (App the_call (Var realWorldPrimId)) 
					      (mkWildId ccall_res_ty)
                                              (coreAltType the_alt)
					      [the_alt]
		 in
		 returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
	      where
		 return_result state [ans] = ans
		 return_result _ _ = panic "return_result: expected single result"
  where
    mk_alt return_result (Nothing, wrap_result)
	= 	-- The ccall returns ()
	  newSysLocalDs realWorldStatePrimTy	`thenDs` \ state_id ->
	  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
	  returnDs (ccall_res_ty, the_alt)

    mk_alt return_result (Just prim_res_ty, wrap_result)
    		-- The ccall returns a non-() value
        | isUnboxedTupleType prim_res_ty
        = let
		Just (_, ls) = splitTyConApp_maybe prim_res_ty
		arity = 1 + length ls
	  in
	  mappM newSysLocalDs ls 		`thenDs` \ args_ids@(result_id:as) ->
	  newSysLocalDs realWorldStatePrimTy	`thenDs` \ state_id ->
	  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
			       )
	  in
	  returnDs (ccall_res_ty, the_alt)
	| otherwise
	= newSysLocalDs prim_res_ty 		`thenDs` \ result_id ->
	  newSysLocalDs realWorldStatePrimTy	`thenDs` \ state_id ->
	  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)
	  in
	  returnDs (ccall_res_ty, the_alt)


resultWrapper :: Type
   	      -> DsM (Maybe Type,		-- Type of the expected result, if any
		      CoreExpr -> CoreExpr)	-- Wrapper for the result 
resultWrapper result_ty
  -- Base case 1: primitive types
  | isPrimitiveType result_ty
  = returnDs (Just result_ty, \e -> e)

  -- Base case 2: the unit type ()
  | Just (tc,_) <- maybe_tc_app, tc `hasKey` unitTyConKey
  = returnDs (Nothing, \e -> Var unitDataConId)

  -- Base case 3: the boolean type
  | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey
  = returnDs
     (Just intPrimTy, \e -> Case e (mkWildId intPrimTy)
                                   boolTy
	                           [(DEFAULT             ,[],Var trueDataConId ),
				    (LitAlt (mkMachInt 0),[],Var falseDataConId)])

  -- Recursive newtypes
  | Just rep_ty <- splitRecNewType_maybe result_ty
  = resultWrapper rep_ty `thenDs` \ (maybe_ty, wrapper) ->
    returnDs (maybe_ty, \e -> mkCoerce2 result_ty rep_ty (wrapper e))

  -- The type might contain foralls (eg. for dummy type arguments,
  -- referring to 'Ptr a' is legal).
  | Just (tyvar, rest) <- splitForAllTy_maybe result_ty
  = resultWrapper rest `thenDs` \ (maybe_ty, wrapper) ->
    returnDs (maybe_ty, \e -> Lam tyvar (wrapper e))

  -- Data types with a single constructor, which has a single arg
  -- This includes types like Ptr and ForeignPtr
  | Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitProductType_maybe result_ty,
    dataConSourceArity data_con == 1
  = let
	(unwrapped_res_ty : _) = data_con_arg_tys
	narrow_wrapper         = maybeNarrow tycon
    in
    resultWrapper unwrapped_res_ty `thenDs` \ (maybe_ty, wrapper) ->
    returnDs
      (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con)) 
			      (map Type tycon_arg_tys ++ [wrapper (narrow_wrapper e)]))

    -- Strings; 'dotnet' only.
  | Just (tc, [arg_ty]) <- maybe_tc_app,               tc == listTyCon,
    Just (cc,[])        <- splitTyConApp_maybe arg_ty, cc == charTyCon
  = dsLookupGlobalId unmarshalStringName	`thenDs` \ pack_id ->
    returnDs (Just addrPrimTy,
    	      \ e -> App (Var pack_id) e)

    -- Objects; 'dotnet' only.
  | Just (tc, [arg_ty]) <- maybe_tc_app, 
    tyConName tc == objectTyConName
  = dsLookupGlobalId unmarshalObjectName	`thenDs` \ pack_id ->
    returnDs (Just addrPrimTy,
    	      \ e -> App (Var pack_id) e)

  | otherwise
  = pprPanic "resultWrapper" (ppr result_ty)
  where
    maybe_tc_app = splitTyConApp_maybe result_ty

-- When the result of a foreign call is smaller than the word size, we
-- need to sign- or zero-extend the result up to the word size.  The C
-- standard appears to say that this is the responsibility of the
-- caller, not the callee.

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}