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