compiler/deSugar/DsCCall.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The AQUA Project, Glasgow University, 1994-1998
   4 %
   5
   6 Desugaring foreign calls
   7
   8 \begin{code}
   9 module DsCCall
  10         ( dsCCall
  11         , mkFCall
  12         , unboxArg
  13         , boxResult
  14         , resultWrapper
  15         ) where
  16
  17 #include "HsVersions.h"
  18
  19
  20 import CoreSyn
  21
  22 import DsMonad
  23
  24 import CoreUtils
  25 import Id
  26 import MkId
  27 import Maybes
  28 import ForeignCall
  29 import DataCon
  30
  31 import TcType
  32 import Type
  33 import Coercion
  34 import PrimOp
  35 import TysPrim
  36 import TyCon
  37 import TysWiredIn
  38 import BasicTypes
  39 import Literal
  40 import PrelNames
  41 import VarSet
  42 import Constants
  43 import Outputable
  44
  45 #ifdef DEBUG
  46 import TypeRep
  47 #endif
  48
  49 \end{code}
  50
  51 Desugaring of @ccall@s consists of adding some state manipulation,
  52 unboxing any boxed primitive arguments and boxing the result if
  53 desired.
  54
  55 The state stuff just consists of adding in
  56 @PrimIO (\ s -> case s of { S# s# -> ... })@ in an appropriate place.
  57
  58 The unboxing is straightforward, as all information needed to unbox is
  59 available from the type.  For each boxed-primitive argument, we
  60 transform:
  61 \begin{verbatim}
  62    _ccall_ foo [ r, t1, ... tm ] e1 ... em
  63    |
  64    |
  65    V
  66    case e1 of { T1# x1# ->
  67    ...
  68    case em of { Tm# xm# -> xm#
  69    ccall# foo [ r, t1#, ... tm# ] x1# ... xm#
  70    } ... }
  71 \end{verbatim}
  72
  73 The reboxing of a @_ccall_@ result is a bit tricker: the types don't
  74 contain information about the state-pairing functions so we have to
  75 keep a list of \tr{(type, s-p-function)} pairs.  We transform as
  76 follows:
  77 \begin{verbatim}
  78    ccall# foo [ r, t1#, ... tm# ] e1# ... em#
  79    |
  80    |
  81    V
  82    \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of
  83           (StateAnd<r># result# state#) -> (R# result#, realWorld#)
  84 \end{verbatim}
  85
  86 \begin{code}
  87 dsCCall :: CLabelString -- C routine to invoke
  88         -> [CoreExpr]   -- Arguments (desugared)
  89         -> Safety       -- Safety of the call
  90         -> Type         -- Type of the result: IO t
  91         -> DsM CoreExpr -- Result, of type ???
  92
  93 dsCCall lbl args may_gc result_ty
  94   = mapAndUnzipDs unboxArg args        `thenDs` \ (unboxed_args, arg_wrappers) ->
  95     boxResult id Nothing result_ty  `thenDs` \ (ccall_result_ty, res_wrapper) ->
  96     newUnique                          `thenDs` \ uniq ->
  97     let
  98         target = StaticTarget lbl
  99         the_fcall    = CCall (CCallSpec target CCallConv may_gc)
 100         the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
 101     in
 102     returnDs (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
 103
 104 mkFCall :: Unique -> ForeignCall
 105         -> [CoreExpr]   -- Args
 106         -> Type         -- Result type
 107         -> CoreExpr
 108 -- Construct the ccall.  The only tricky bit is that the ccall Id should have
 109 -- no free vars, so if any of the arg tys do we must give it a polymorphic type.
 110 --      [I forget *why* it should have no free vars!]
 111 -- For example:
 112 --      mkCCall ... [s::StablePtr (a->b), x::Addr, c::Char]
 113 --
 114 -- Here we build a ccall thus
 115 --      (ccallid::(forall a b.  StablePtr (a -> b) -> Addr -> Char -> IO Addr))
 116 --                      a b s x c
 117 mkFCall uniq the_fcall val_args res_ty
 118   = mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args
 119   where
 120     arg_tys = map exprType val_args
 121     body_ty = (mkFunTys arg_tys res_ty)
 122     tyvars  = varSetElems (tyVarsOfType body_ty)
 123     ty      = mkForAllTys tyvars body_ty
 124     the_fcall_id = mkFCallId uniq the_fcall ty
 125 \end{code}
 126
 127 \begin{code}
 128 unboxArg :: CoreExpr                    -- The supplied argument
 129          -> DsM (CoreExpr,              -- To pass as the actual argument
 130                  CoreExpr -> CoreExpr   -- Wrapper to unbox the arg
 131                 )
 132 -- Example: if the arg is e::Int, unboxArg will return
 133 --      (x#::Int#, \W. case x of I# x# -> W)
 134 -- where W is a CoreExpr that probably mentions x#
 135
 136 unboxArg arg
 137   -- Primtive types: nothing to unbox
 138   | isPrimitiveType arg_ty
 139   = returnDs (arg, \body -> body)
 140
 141   -- Recursive newtypes
 142   | Just(rep_ty, co) <- splitNewTypeRepCo_maybe arg_ty
 143   = unboxArg (mkCoerce co arg)
 144
 145   -- Booleans
 146   | Just (tc,_) <- splitTyConApp_maybe arg_ty,
 147     tc `hasKey` boolTyConKey
 148   = newSysLocalDs intPrimTy             `thenDs` \ prim_arg ->
 149     returnDs (Var prim_arg,
 150               \ body -> Case (Case arg (mkWildId arg_ty) intPrimTy
 151                                        [(DataAlt falseDataCon,[],mkIntLit 0),
 152                                         (DataAlt trueDataCon, [],mkIntLit 1)])
 153                                         -- In increasing tag order!
 154                              prim_arg
 155                              (exprType body)
 156                              [(DEFAULT,[],body)])
 157
 158   -- Data types with a single constructor, which has a single, primitive-typed arg
 159   -- This deals with Int, Float etc; also Ptr, ForeignPtr
 160   | is_product_type && data_con_arity == 1
 161   = ASSERT2(isUnLiftedType data_con_arg_ty1, pprType arg_ty)
 162                         -- Typechecker ensures this
 163     newSysLocalDs arg_ty                `thenDs` \ case_bndr ->
 164     newSysLocalDs data_con_arg_ty1      `thenDs` \ prim_arg ->
 165     returnDs (Var prim_arg,
 166               \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)]
 167     )
 168
 169   -- Byte-arrays, both mutable and otherwise; hack warning
 170   -- We're looking for values of type ByteArray, MutableByteArray
 171   --    data ByteArray          ix = ByteArray        ix ix ByteArray#
 172   --    data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)
 173   | is_product_type &&
 174     data_con_arity == 3 &&
 175     maybeToBool maybe_arg3_tycon &&
 176     (arg3_tycon ==  byteArrayPrimTyCon ||
 177      arg3_tycon ==  mutableByteArrayPrimTyCon)
 178   = newSysLocalDs arg_ty                `thenDs` \ case_bndr ->
 179     newSysLocalsDs data_con_arg_tys     `thenDs` \ vars@[l_var, r_var, arr_cts_var] ->
 180     returnDs (Var arr_cts_var,
 181               \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)]
 182
 183     )
 184
 185   | Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
 186     tc == listTyCon,
 187     Just (cc,[]) <- splitTyConApp_maybe arg_ty,
 188     cc == charTyCon
 189     -- String; dotnet only
 190   = dsLookupGlobalId marshalStringName `thenDs` \ unpack_id ->
 191     newSysLocalDs addrPrimTy           `thenDs` \ prim_string ->
 192     returnDs (Var prim_string,
 193               \ body ->
 194                 let
 195                  io_ty = exprType body
 196                  Just (_,io_arg) = tcSplitIOType_maybe io_ty
 197                 in
 198                 mkApps (Var unpack_id)
 199                        [ Type io_arg
 200                        , arg
 201                        , Lam prim_string body
 202                        ])
 203   | Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
 204     tyConName tc == objectTyConName
 205     -- Object; dotnet only
 206   = dsLookupGlobalId marshalObjectName `thenDs` \ unpack_id ->
 207     newSysLocalDs addrPrimTy           `thenDs` \ prim_obj  ->
 208     returnDs (Var prim_obj,
 209               \ body ->
 210                 let
 211                  io_ty = exprType body
 212                  Just (_,io_arg) = tcSplitIOType_maybe io_ty
 213                 in
 214                 mkApps (Var unpack_id)
 215                        [ Type io_arg
 216                        , arg
 217                        , Lam prim_obj body
 218                        ])
 219
 220   | otherwise
 221   = getSrcSpanDs `thenDs` \ l ->
 222     pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
 223   where
 224     arg_ty                                      = exprType arg
 225     maybe_product_type                          = splitProductType_maybe arg_ty
 226     is_product_type                             = maybeToBool maybe_product_type
 227     Just (_, _, data_con, data_con_arg_tys)     = maybe_product_type
 228     data_con_arity                              = dataConSourceArity data_con
 229     (data_con_arg_ty1 : _)                      = data_con_arg_tys
 230
 231     (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
 232     maybe_arg3_tycon               = splitTyConApp_maybe data_con_arg_ty3
 233     Just (arg3_tycon,_)            = maybe_arg3_tycon
 234 \end{code}
 235
 236
 237 \begin{code}
 238 boxResult :: ((Maybe Type, CoreExpr -> CoreExpr) -> (Maybe Type, CoreExpr -> CoreExpr))
 239           -> Maybe Id
 240           -> Type
 241           -> DsM (Type, CoreExpr -> CoreExpr)
 242
 243 -- Takes the result of the user-level ccall:
 244 --      either (IO t),
 245 --      or maybe just t for an side-effect-free call
 246 -- Returns a wrapper for the primitive ccall itself, along with the
 247 -- type of the result of the primitive ccall.  This result type
 248 -- will be of the form
 249 --      State# RealWorld -> (# State# RealWorld, t' #)
 250 -- where t' is the unwrapped form of t.  If t is simply (), then
 251 -- the result type will be
 252 --      State# RealWorld -> (# State# RealWorld #)
 253 --
 254 -- The gruesome 'augment' and 'mbTopCon' are to do with .NET foreign calls
 255 -- It looks a mess: I wonder if it could be refactored.
 256
 257 boxResult augment mbTopCon result_ty
 258   | Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty
 259         -- isIOType_maybe handles the case where the type is a
 260         -- simple wrapping of IO.  E.g.
 261         --      newtype Wrap a = W (IO a)
 262         -- No coercion necessay because its a non-recursive newtype
 263         -- (If we wanted to handle a *recursive* newtype too, we'd need
 264         -- another case, and a coercion.)
 265   =     -- The result is IO t, so wrap the result in an IO constructor
 266
 267     resultWrapper io_res_ty             `thenDs` \ res ->
 268     let aug_res          = augment res
 269         extra_result_tys = case aug_res of
 270                              (Just ty,_)
 271                                | isUnboxedTupleType ty
 272                                -> let (Just (_, ls)) = splitTyConApp_maybe ty in tail ls
 273                              _ -> []
 274
 275         return_result state anss
 276           = mkConApp (tupleCon Unboxed (2 + length extra_result_tys))
 277                      (map Type (realWorldStatePrimTy : io_res_ty : extra_result_tys)
 278                       ++ (state : anss))
 279     in
 280     mk_alt return_result aug_res        `thenDs` \ (ccall_res_ty, the_alt) ->
 281     newSysLocalDs realWorldStatePrimTy  `thenDs` \ state_id ->
 282     let
 283         io_data_con = head (tyConDataCons io_tycon)
 284         toIOCon = case mbTopCon of
 285                         Nothing -> dataConWrapId io_data_con
 286                         Just x  -> x
 287         wrap = \ the_call -> mkApps (Var toIOCon)
 288                                     [ Type io_res_ty,
 289                                       Lam state_id $
 290                                        Case (App the_call (Var state_id))
 291                                            (mkWildId ccall_res_ty)
 292                                             (coreAltType the_alt)
 293                                            [the_alt]
 294                                     ]
 295     in
 296     returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
 297
 298 boxResult augment mbTopCon result_ty
 299   =     -- It isn't IO, so do unsafePerformIO
 300         -- It's not conveniently available, so we inline it
 301     resultWrapper result_ty            `thenDs` \ res ->
 302     mk_alt return_result (augment res) `thenDs` \ (ccall_res_ty, the_alt) ->
 303     let
 304         wrap = \ the_call -> Case (App the_call (Var realWorldPrimId))
 305                                               (mkWildId ccall_res_ty)
 306                                               (coreAltType the_alt)
 307                                               [the_alt]
 308     in
 309     returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
 310   where
 311     return_result state [ans] = ans
 312     return_result _ _ = panic "return_result: expected single result"
 313
 314
 315 mk_alt return_result (Nothing, wrap_result)
 316   =     -- The ccall returns ()
 317           newSysLocalDs realWorldStatePrimTy    `thenDs` \ state_id ->
 318           let
 319                 the_rhs = return_result (Var state_id)
 320                                         [wrap_result (panic "boxResult")]
 321
 322                 ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy]
 323                 the_alt      = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs)
 324           in
 325           returnDs (ccall_res_ty, the_alt)
 326
 327 mk_alt return_result (Just prim_res_ty, wrap_result)
 328                 -- The ccall returns a non-() value
 329   | isUnboxedTupleType prim_res_ty
 330   = let
 331         Just (_, ls) = splitTyConApp_maybe prim_res_ty
 332         arity = 1 + length ls
 333     in
 334     mappM newSysLocalDs ls              `thenDs` \ args_ids@(result_id:as) ->
 335     newSysLocalDs realWorldStatePrimTy  `thenDs` \ state_id ->
 336     let
 337         the_rhs = return_result (Var state_id)
 338                                 (wrap_result (Var result_id) : map Var as)
 339         ccall_res_ty = mkTyConApp (tupleTyCon Unboxed arity)
 340                                   (realWorldStatePrimTy : ls)
 341         the_alt      = ( DataAlt (tupleCon Unboxed arity)
 342                        , (state_id : args_ids)
 343                        , the_rhs
 344                        )
 345     in
 346     returnDs (ccall_res_ty, the_alt)
 347
 348   | otherwise
 349   = newSysLocalDs prim_res_ty           `thenDs` \ result_id ->
 350     newSysLocalDs realWorldStatePrimTy  `thenDs` \ state_id ->
 351     let
 352         the_rhs = return_result (Var state_id)
 353                                 [wrap_result (Var result_id)]
 354         ccall_res_ty = mkTyConApp unboxedPairTyCon [realWorldStatePrimTy, prim_res_ty]
 355         the_alt      = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs)
 356     in
 357     returnDs (ccall_res_ty, the_alt)
 358
 359
 360 resultWrapper :: Type
 361               -> DsM (Maybe Type,               -- Type of the expected result, if any
 362                       CoreExpr -> CoreExpr)     -- Wrapper for the result
 363 resultWrapper result_ty
 364   -- Base case 1: primitive types
 365   | isPrimitiveType result_ty
 366   = returnDs (Just result_ty, \e -> e)
 367
 368   -- Base case 2: the unit type ()
 369   | Just (tc,_) <- maybe_tc_app, tc `hasKey` unitTyConKey
 370   = returnDs (Nothing, \e -> Var unitDataConId)
 371
 372   -- Base case 3: the boolean type
 373   | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey
 374   = returnDs
 375      (Just intPrimTy, \e -> Case e (mkWildId intPrimTy)
 376                                    boolTy
 377                                    [(DEFAULT             ,[],Var trueDataConId ),
 378                                     (LitAlt (mkMachInt 0),[],Var falseDataConId)])
 379
 380   -- Recursive newtypes
 381   | Just (rep_ty, co) <- splitNewTypeRepCo_maybe result_ty
 382   = resultWrapper rep_ty `thenDs` \ (maybe_ty, wrapper) ->
 383     returnDs (maybe_ty, \e -> mkCoerce (mkSymCoercion co) (wrapper e))
 384
 385   -- The type might contain foralls (eg. for dummy type arguments,
 386   -- referring to 'Ptr a' is legal).
 387   | Just (tyvar, rest) <- splitForAllTy_maybe result_ty
 388   = resultWrapper rest `thenDs` \ (maybe_ty, wrapper) ->
 389     returnDs (maybe_ty, \e -> Lam tyvar (wrapper e))
 390
 391   -- Data types with a single constructor, which has a single arg
 392   -- This includes types like Ptr and ForeignPtr
 393   | Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitProductType_maybe result_ty,
 394     dataConSourceArity data_con == 1
 395   = let
 396         (unwrapped_res_ty : _) = data_con_arg_tys
 397         narrow_wrapper         = maybeNarrow tycon
 398     in
 399     resultWrapper unwrapped_res_ty `thenDs` \ (maybe_ty, wrapper) ->
 400     returnDs
 401       (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con))
 402                               (map Type tycon_arg_tys ++ [wrapper (narrow_wrapper e)]))
 403
 404     -- Strings; 'dotnet' only.
 405   | Just (tc, [arg_ty]) <- maybe_tc_app,               tc == listTyCon,
 406     Just (cc,[])        <- splitTyConApp_maybe arg_ty, cc == charTyCon
 407   = dsLookupGlobalId unmarshalStringName        `thenDs` \ pack_id ->
 408     returnDs (Just addrPrimTy,
 409               \ e -> App (Var pack_id) e)
 410
 411     -- Objects; 'dotnet' only.
 412   | Just (tc, [arg_ty]) <- maybe_tc_app,
 413     tyConName tc == objectTyConName
 414   = dsLookupGlobalId unmarshalObjectName        `thenDs` \ pack_id ->
 415     returnDs (Just addrPrimTy,
 416               \ e -> App (Var pack_id) e)
 417
 418   | otherwise
 419   = pprPanic "resultWrapper" (ppr result_ty)
 420   where
 421     maybe_tc_app = splitTyConApp_maybe result_ty
 422
 423 -- When the result of a foreign call is smaller than the word size, we
 424 -- need to sign- or zero-extend the result up to the word size.  The C
 425 -- standard appears to say that this is the responsibility of the
 426 -- caller, not the callee.
 427
 428 maybeNarrow :: TyCon -> (CoreExpr -> CoreExpr)
 429 maybeNarrow tycon
 430   | tycon `hasKey` int8TyConKey   = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e
 431   | tycon `hasKey` int16TyConKey  = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e
 432   | tycon `hasKey` int32TyConKey
 433          && wORD_SIZE > 4         = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e
 434
 435   | tycon `hasKey` word8TyConKey  = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e
 436   | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e
 437   | tycon `hasKey` word32TyConKey
 438          && wORD_SIZE > 4         = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e
 439   | otherwise                     = id
 440 \end{code}