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   ----- Cases for .NET; almost certainly bit-rotted ---------
 186   | Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
 187     tc == listTyCon,
 188     Just (cc,[]) <- splitTyConApp_maybe arg_ty,
 189     cc == charTyCon
 190     -- String; dotnet only
 191   = dsLookupGlobalId marshalStringName `thenDs` \ unpack_id ->
 192     newSysLocalDs addrPrimTy           `thenDs` \ prim_string ->
 193     returnDs (Var prim_string,
 194               \ body ->
 195                 let
 196                  io_ty = exprType body
 197                  Just (_,io_arg,_) = tcSplitIOType_maybe io_ty
 198                 in
 199                 mkApps (Var unpack_id)
 200                        [ Type io_arg
 201                        , arg
 202                        , Lam prim_string body
 203                        ])
 204   | Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
 205     tyConName tc == objectTyConName
 206     -- Object; dotnet only
 207   = dsLookupGlobalId marshalObjectName `thenDs` \ unpack_id ->
 208     newSysLocalDs addrPrimTy           `thenDs` \ prim_obj  ->
 209     returnDs (Var prim_obj,
 210               \ body ->
 211                 let
 212                  io_ty = exprType body
 213                  Just (_,io_arg,_) = tcSplitIOType_maybe io_ty
 214                 in
 215                 mkApps (Var unpack_id)
 216                        [ Type io_arg
 217                        , arg
 218                        , Lam prim_obj body
 219                        ])
 220   --------------- End of cases for .NET --------------------
 221
 222   | otherwise
 223   = getSrcSpanDs `thenDs` \ l ->
 224     pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
 225   where
 226     arg_ty                                      = exprType arg
 227     maybe_product_type                          = splitProductType_maybe arg_ty
 228     is_product_type                             = maybeToBool maybe_product_type
 229     Just (_, _, data_con, data_con_arg_tys)     = maybe_product_type
 230     data_con_arity                              = dataConSourceArity data_con
 231     (data_con_arg_ty1 : _)                      = data_con_arg_tys
 232
 233     (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
 234     maybe_arg3_tycon               = splitTyConApp_maybe data_con_arg_ty3
 235     Just (arg3_tycon,_)            = maybe_arg3_tycon
 236 \end{code}
 237
 238
 239 \begin{code}
 240 boxResult :: ((Maybe Type, CoreExpr -> CoreExpr)
 241                  -> (Maybe Type, CoreExpr -> CoreExpr))
 242           -> Maybe Id
 243           -> Type
 244           -> DsM (Type, CoreExpr -> CoreExpr)
 245
 246 -- Takes the result of the user-level ccall:
 247 --      either (IO t),
 248 --      or maybe just t for an side-effect-free call
 249 -- Returns a wrapper for the primitive ccall itself, along with the
 250 -- type of the result of the primitive ccall.  This result type
 251 -- will be of the form
 252 --      State# RealWorld -> (# State# RealWorld, t' #)
 253 -- where t' is the unwrapped form of t.  If t is simply (), then
 254 -- the result type will be
 255 --      State# RealWorld -> (# State# RealWorld #)
 256 --
 257 -- The gruesome 'augment' and 'mbTopCon' are to do with .NET foreign calls
 258 -- It looks a mess: I wonder if it could be refactored.
 259
 260 boxResult augment mbTopCon result_ty
 261   | Just (io_tycon, io_res_ty, co) <- tcSplitIOType_maybe result_ty
 262         -- isIOType_maybe handles the case where the type is a
 263         -- simple wrapping of IO.  E.g.
 264         --      newtype Wrap a = W (IO a)
 265         -- No coercion necessary because its a non-recursive newtype
 266         -- (If we wanted to handle a *recursive* newtype too, we'd need
 267         -- another case, and a coercion.)
 268         -- The result is IO t, so wrap the result in an IO constructor
 269   = do  { res <- resultWrapper io_res_ty
 270         ; let aug_res = augment res
 271               extra_result_tys
 272                 = case aug_res of
 273                      (Just ty,_)
 274                        | isUnboxedTupleType ty
 275                        -> let (Just (_, ls)) = splitTyConApp_maybe ty in tail ls
 276                      _ -> []
 277
 278               return_result state anss
 279                 = mkConApp (tupleCon Unboxed (2 + length extra_result_tys))
 280                            (map Type (realWorldStatePrimTy : io_res_ty : extra_result_tys)
 281                               ++ (state : anss))
 282
 283         ; (ccall_res_ty, the_alt) <- mk_alt return_result aug_res
 284
 285         ; state_id <- newSysLocalDs realWorldStatePrimTy
 286         ; let io_data_con = head (tyConDataCons io_tycon)
 287               toIOCon     = mbTopCon `orElse` dataConWrapId io_data_con
 288
 289               wrap the_call = mkCoerceI (mkSymCoI co) $
 290                               mkApps (Var toIOCon)
 291                                      [ Type io_res_ty,
 292                                        Lam state_id $
 293                                        Case (App the_call (Var state_id))
 294                                              (mkWildId ccall_res_ty)
 295                                              (coreAltType the_alt)
 296                                              [the_alt]
 297                                      ]
 298
 299         ; return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) }
 300
 301 boxResult augment mbTopCon result_ty
 302   =     -- It isn't IO, so do unsafePerformIO
 303         -- It's not conveniently available, so we inline it
 304     resultWrapper result_ty            `thenDs` \ res ->
 305     mk_alt return_result (augment res) `thenDs` \ (ccall_res_ty, the_alt) ->
 306     let
 307         wrap = \ the_call -> Case (App the_call (Var realWorldPrimId))
 308                                   (mkWildId ccall_res_ty)
 309                                   (coreAltType the_alt)
 310                                   [the_alt]
 311     in
 312     returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
 313   where
 314     return_result state [ans] = ans
 315     return_result _ _ = panic "return_result: expected single result"
 316
 317
 318 mk_alt return_result (Nothing, wrap_result)
 319   =     -- The ccall returns ()
 320           newSysLocalDs realWorldStatePrimTy    `thenDs` \ state_id ->
 321           let
 322                 the_rhs = return_result (Var state_id)
 323                                         [wrap_result (panic "boxResult")]
 324
 325                 ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy]
 326                 the_alt      = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs)
 327           in
 328           returnDs (ccall_res_ty, the_alt)
 329
 330 mk_alt return_result (Just prim_res_ty, wrap_result)
 331                 -- The ccall returns a non-() value
 332   | isUnboxedTupleType prim_res_ty
 333   = let
 334         Just (_, ls) = splitTyConApp_maybe prim_res_ty
 335         arity = 1 + length ls
 336     in
 337     mappM newSysLocalDs ls              `thenDs` \ args_ids@(result_id:as) ->
 338     newSysLocalDs realWorldStatePrimTy  `thenDs` \ state_id ->
 339     let
 340         the_rhs = return_result (Var state_id)
 341                                 (wrap_result (Var result_id) : map Var as)
 342         ccall_res_ty = mkTyConApp (tupleTyCon Unboxed arity)
 343                                   (realWorldStatePrimTy : ls)
 344         the_alt      = ( DataAlt (tupleCon Unboxed arity)
 345                        , (state_id : args_ids)
 346                        , the_rhs
 347                        )
 348     in
 349     returnDs (ccall_res_ty, the_alt)
 350
 351   | otherwise
 352   = newSysLocalDs prim_res_ty           `thenDs` \ result_id ->
 353     newSysLocalDs realWorldStatePrimTy  `thenDs` \ state_id ->
 354     let
 355         the_rhs = return_result (Var state_id)
 356                                 [wrap_result (Var result_id)]
 357         ccall_res_ty = mkTyConApp unboxedPairTyCon [realWorldStatePrimTy, prim_res_ty]
 358         the_alt      = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs)
 359     in
 360     returnDs (ccall_res_ty, the_alt)
 361
 362
 363 resultWrapper :: Type
 364               -> DsM (Maybe Type,               -- Type of the expected result, if any
 365                       CoreExpr -> CoreExpr)     -- Wrapper for the result
 366 -- resultWrapper deals with the result *value*
 367 -- E.g. foreign import foo :: Int -> IO T
 368 -- Then resultWrapper deals with marshalling the 'T' part
 369 resultWrapper result_ty
 370   -- Base case 1: primitive types
 371   | isPrimitiveType result_ty
 372   = returnDs (Just result_ty, \e -> e)
 373
 374   -- Base case 2: the unit type ()
 375   | Just (tc,_) <- maybe_tc_app, tc `hasKey` unitTyConKey
 376   = returnDs (Nothing, \e -> Var unitDataConId)
 377
 378   -- Base case 3: the boolean type
 379   | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey
 380   = returnDs
 381      (Just intPrimTy, \e -> Case e (mkWildId intPrimTy)
 382                                    boolTy
 383                                    [(DEFAULT             ,[],Var trueDataConId ),
 384                                     (LitAlt (mkMachInt 0),[],Var falseDataConId)])
 385
 386   -- Recursive newtypes
 387   | Just (rep_ty, co) <- splitNewTypeRepCo_maybe result_ty
 388   = resultWrapper rep_ty `thenDs` \ (maybe_ty, wrapper) ->
 389     returnDs (maybe_ty, \e -> mkCoerce (mkSymCoercion co) (wrapper e))
 390
 391   -- The type might contain foralls (eg. for dummy type arguments,
 392   -- referring to 'Ptr a' is legal).
 393   | Just (tyvar, rest) <- splitForAllTy_maybe result_ty
 394   = resultWrapper rest `thenDs` \ (maybe_ty, wrapper) ->
 395     returnDs (maybe_ty, \e -> Lam tyvar (wrapper e))
 396
 397   -- Data types with a single constructor, which has a single arg
 398   -- This includes types like Ptr and ForeignPtr
 399   | Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitProductType_maybe result_ty,
 400     dataConSourceArity data_con == 1
 401   = let
 402         (unwrapped_res_ty : _) = data_con_arg_tys
 403         narrow_wrapper         = maybeNarrow tycon
 404     in
 405     resultWrapper unwrapped_res_ty `thenDs` \ (maybe_ty, wrapper) ->
 406     returnDs
 407       (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con))
 408                               (map Type tycon_arg_tys ++ [wrapper (narrow_wrapper e)]))
 409
 410     -- Strings; 'dotnet' only.
 411   | Just (tc, [arg_ty]) <- maybe_tc_app,               tc == listTyCon,
 412     Just (cc,[])        <- splitTyConApp_maybe arg_ty, cc == charTyCon
 413   = dsLookupGlobalId unmarshalStringName        `thenDs` \ pack_id ->
 414     returnDs (Just addrPrimTy,
 415               \ e -> App (Var pack_id) e)
 416
 417     -- Objects; 'dotnet' only.
 418   | Just (tc, [arg_ty]) <- maybe_tc_app,
 419     tyConName tc == objectTyConName
 420   = dsLookupGlobalId unmarshalObjectName        `thenDs` \ pack_id ->
 421     returnDs (Just addrPrimTy,
 422               \ e -> App (Var pack_id) e)
 423
 424   | otherwise
 425   = pprPanic "resultWrapper" (ppr result_ty)
 426   where
 427     maybe_tc_app = splitTyConApp_maybe result_ty
 428
 429 -- When the result of a foreign call is smaller than the word size, we
 430 -- need to sign- or zero-extend the result up to the word size.  The C
 431 -- standard appears to say that this is the responsibility of the
 432 -- caller, not the callee.
 433
 434 maybeNarrow :: TyCon -> (CoreExpr -> CoreExpr)
 435 maybeNarrow tycon
 436   | tycon `hasKey` int8TyConKey   = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e
 437   | tycon `hasKey` int16TyConKey  = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e
 438   | tycon `hasKey` int32TyConKey
 439          && wORD_SIZE > 4         = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e
 440
 441   | tycon `hasKey` word8TyConKey  = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e
 442   | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e
 443   | tycon `hasKey` word32TyConKey
 444          && wORD_SIZE > 4         = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e
 445   | otherwise                     = id
 446 \end{code}