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