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 {-# OPTIONS -w #-}
  10 -- The above warning supression flag is a temporary kludge.
  11 -- While working on this module you are encouraged to remove it and fix
  12 -- any warnings in the module. See
  13 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  14 -- for details
  15
  16 module DsCCall
  17         ( dsCCall
  18         , mkFCall
  19         , unboxArg
  20         , boxResult
  21         , resultWrapper
  22         ) where
  23
  24 #include "HsVersions.h"
  25
  26
  27 import CoreSyn
  28
  29 import DsMonad
  30
  31 import CoreUtils
  32 import Id
  33 import MkId
  34 import Maybes
  35 import ForeignCall
  36 import DataCon
  37
  38 import TcType
  39 import Type
  40 import Coercion
  41 import PrimOp
  42 import TysPrim
  43 import TyCon
  44 import TysWiredIn
  45 import BasicTypes
  46 import Literal
  47 import PrelNames
  48 import VarSet
  49 import Constants
  50 import Outputable
  51 \end{code}
  52
  53 Desugaring of @ccall@s consists of adding some state manipulation,
  54 unboxing any boxed primitive arguments and boxing the result if
  55 desired.
  56
  57 The state stuff just consists of adding in
  58 @PrimIO (\ s -> case s of { S# s# -> ... })@ in an appropriate place.
  59
  60 The unboxing is straightforward, as all information needed to unbox is
  61 available from the type.  For each boxed-primitive argument, we
  62 transform:
  63 \begin{verbatim}
  64    _ccall_ foo [ r, t1, ... tm ] e1 ... em
  65    |
  66    |
  67    V
  68    case e1 of { T1# x1# ->
  69    ...
  70    case em of { Tm# xm# -> xm#
  71    ccall# foo [ r, t1#, ... tm# ] x1# ... xm#
  72    } ... }
  73 \end{verbatim}
  74
  75 The reboxing of a @_ccall_@ result is a bit tricker: the types don't
  76 contain information about the state-pairing functions so we have to
  77 keep a list of \tr{(type, s-p-function)} pairs.  We transform as
  78 follows:
  79 \begin{verbatim}
  80    ccall# foo [ r, t1#, ... tm# ] e1# ... em#
  81    |
  82    |
  83    V
  84    \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of
  85           (StateAnd<r># result# state#) -> (R# result#, realWorld#)
  86 \end{verbatim}
  87
  88 \begin{code}
  89 dsCCall :: CLabelString -- C routine to invoke
  90         -> [CoreExpr]   -- Arguments (desugared)
  91         -> Safety       -- Safety of the call
  92         -> Type         -- Type of the result: IO t
  93         -> DsM CoreExpr -- Result, of type ???
  94
  95 dsCCall lbl args may_gc result_ty
  96   = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args
  97        (ccall_result_ty, res_wrapper) <- boxResult id Nothing result_ty
  98        uniq <- newUnique
  99        let
 100            target = StaticTarget lbl
 101            the_fcall    = CCall (CCallSpec target CCallConv may_gc)
 102            the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
 103        return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
 104
 105 mkFCall :: Unique -> ForeignCall
 106         -> [CoreExpr]   -- Args
 107         -> Type         -- Result type
 108         -> CoreExpr
 109 -- Construct the ccall.  The only tricky bit is that the ccall Id should have
 110 -- no free vars, so if any of the arg tys do we must give it a polymorphic type.
 111 --      [I forget *why* it should have no free vars!]
 112 -- For example:
 113 --      mkCCall ... [s::StablePtr (a->b), x::Addr, c::Char]
 114 --
 115 -- Here we build a ccall thus
 116 --      (ccallid::(forall a b.  StablePtr (a -> b) -> Addr -> Char -> IO Addr))
 117 --                      a b s x c
 118 mkFCall uniq the_fcall val_args res_ty
 119   = mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args
 120   where
 121     arg_tys = map exprType val_args
 122     body_ty = (mkFunTys arg_tys res_ty)
 123     tyvars  = varSetElems (tyVarsOfType body_ty)
 124     ty      = mkForAllTys tyvars body_ty
 125     the_fcall_id = mkFCallId uniq the_fcall ty
 126 \end{code}
 127
 128 \begin{code}
 129 unboxArg :: CoreExpr                    -- The supplied argument
 130          -> DsM (CoreExpr,              -- To pass as the actual argument
 131                  CoreExpr -> CoreExpr   -- Wrapper to unbox the arg
 132                 )
 133 -- Example: if the arg is e::Int, unboxArg will return
 134 --      (x#::Int#, \W. case x of I# x# -> W)
 135 -- where W is a CoreExpr that probably mentions x#
 136
 137 unboxArg arg
 138   -- Primtive types: nothing to unbox
 139   | isPrimitiveType arg_ty
 140   = return (arg, \body -> body)
 141
 142   -- Recursive newtypes
 143   | Just(rep_ty, co) <- splitNewTypeRepCo_maybe arg_ty
 144   = unboxArg (mkCoerce co arg)
 145
 146   -- Booleans
 147   | Just (tc,_) <- splitTyConApp_maybe arg_ty,
 148     tc `hasKey` boolTyConKey
 149   = do prim_arg <- newSysLocalDs intPrimTy
 150        return (Var prim_arg,
 151               \ body -> Case (Case arg (mkWildId arg_ty) intPrimTy
 152                                        [(DataAlt falseDataCon,[],mkIntLit 0),
 153                                         (DataAlt trueDataCon, [],mkIntLit 1)])
 154                                         -- In increasing tag order!
 155                              prim_arg
 156                              (exprType body)
 157                              [(DEFAULT,[],body)])
 158
 159   -- Data types with a single constructor, which has a single, primitive-typed arg
 160   -- This deals with Int, Float etc; also Ptr, ForeignPtr
 161   | is_product_type && data_con_arity == 1
 162   = ASSERT2(isUnLiftedType data_con_arg_ty1, pprType arg_ty)
 163                         -- Typechecker ensures this
 164     do case_bndr <- newSysLocalDs arg_ty
 165        prim_arg <- newSysLocalDs data_con_arg_ty1
 166        return (Var prim_arg,
 167                \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)]
 168               )
 169
 170   -- Byte-arrays, both mutable and otherwise; hack warning
 171   -- We're looking for values of type ByteArray, MutableByteArray
 172   --    data ByteArray          ix = ByteArray        ix ix ByteArray#
 173   --    data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)
 174   | is_product_type &&
 175     data_con_arity == 3 &&
 176     maybeToBool maybe_arg3_tycon &&
 177     (arg3_tycon ==  byteArrayPrimTyCon ||
 178      arg3_tycon ==  mutableByteArrayPrimTyCon)
 179   = do case_bndr <- newSysLocalDs arg_ty
 180        vars@[l_var, r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys
 181        return (Var arr_cts_var,
 182                \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)]
 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   = do unpack_id <- dsLookupGlobalId marshalStringName
 192        prim_string <- newSysLocalDs addrPrimTy
 193        return (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   = do unpack_id <- dsLookupGlobalId marshalObjectName
 208        prim_obj <- newSysLocalDs addrPrimTy
 209        return (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   = do l <- getSrcSpanDs
 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   = do -- It isn't IO, so do unsafePerformIO
 303        -- It's not conveniently available, so we inline it
 304        res <- resultWrapper result_ty
 305        (ccall_res_ty, the_alt) <- mk_alt return_result (augment res)
 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        return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
 312   where
 313     return_result state [ans] = ans
 314     return_result _ _ = panic "return_result: expected single result"
 315
 316
 317 mk_alt return_result (Nothing, wrap_result)
 318   = do -- The ccall returns ()
 319        state_id <- newSysLocalDs realWorldStatePrimTy
 320        let
 321              the_rhs = return_result (Var state_id)
 322                                      [wrap_result (panic "boxResult")]
 323
 324              ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy]
 325              the_alt      = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs)
 326
 327        return (ccall_res_ty, the_alt)
 328
 329 mk_alt return_result (Just prim_res_ty, wrap_result)
 330                 -- The ccall returns a non-() value
 331   | isUnboxedTupleType prim_res_ty= do
 332     let
 333         Just (_, ls) = splitTyConApp_maybe prim_res_ty
 334         arity = 1 + length ls
 335     args_ids@(result_id:as) <- mapM newSysLocalDs ls
 336     state_id <- newSysLocalDs realWorldStatePrimTy
 337     let
 338         the_rhs = return_result (Var state_id)
 339                                 (wrap_result (Var result_id) : map Var as)
 340         ccall_res_ty = mkTyConApp (tupleTyCon Unboxed arity)
 341                                   (realWorldStatePrimTy : ls)
 342         the_alt      = ( DataAlt (tupleCon Unboxed arity)
 343                        , (state_id : args_ids)
 344                        , the_rhs
 345                        )
 346     return (ccall_res_ty, the_alt)
 347
 348   | otherwise = do
 349     result_id <- newSysLocalDs prim_res_ty
 350     state_id <- newSysLocalDs realWorldStatePrimTy
 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     return (ccall_res_ty, the_alt)
 357
 358
 359 resultWrapper :: Type
 360               -> DsM (Maybe Type,               -- Type of the expected result, if any
 361                       CoreExpr -> CoreExpr)     -- Wrapper for the result
 362 -- resultWrapper deals with the result *value*
 363 -- E.g. foreign import foo :: Int -> IO T
 364 -- Then resultWrapper deals with marshalling the 'T' part
 365 resultWrapper result_ty
 366   -- Base case 1: primitive types
 367   | isPrimitiveType result_ty
 368   = return (Just result_ty, \e -> e)
 369
 370   -- Base case 2: the unit type ()
 371   | Just (tc,_) <- maybe_tc_app, tc `hasKey` unitTyConKey
 372   = return (Nothing, \e -> Var unitDataConId)
 373
 374   -- Base case 3: the boolean type
 375   | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey
 376   = return
 377      (Just intPrimTy, \e -> Case e (mkWildId intPrimTy)
 378                                    boolTy
 379                                    [(DEFAULT             ,[],Var trueDataConId ),
 380                                     (LitAlt (mkMachInt 0),[],Var falseDataConId)])
 381
 382   -- Recursive newtypes
 383   | Just (rep_ty, co) <- splitNewTypeRepCo_maybe result_ty
 384   = do (maybe_ty, wrapper) <- resultWrapper rep_ty
 385        return (maybe_ty, \e -> mkCoerce (mkSymCoercion co) (wrapper e))
 386
 387   -- The type might contain foralls (eg. for dummy type arguments,
 388   -- referring to 'Ptr a' is legal).
 389   | Just (tyvar, rest) <- splitForAllTy_maybe result_ty
 390   = do (maybe_ty, wrapper) <- resultWrapper rest
 391        return (maybe_ty, \e -> Lam tyvar (wrapper e))
 392
 393   -- Data types with a single constructor, which has a single arg
 394   -- This includes types like Ptr and ForeignPtr
 395   | Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitProductType_maybe result_ty,
 396     dataConSourceArity data_con == 1
 397   = do let
 398            (unwrapped_res_ty : _) = data_con_arg_tys
 399            narrow_wrapper         = maybeNarrow tycon
 400        (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty
 401        return
 402          (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con))
 403                                  (map Type tycon_arg_tys ++ [wrapper (narrow_wrapper e)]))
 404
 405     -- Strings; 'dotnet' only.
 406   | Just (tc, [arg_ty]) <- maybe_tc_app,               tc == listTyCon,
 407     Just (cc,[])        <- splitTyConApp_maybe arg_ty, cc == charTyCon
 408   = do pack_id <- dsLookupGlobalId unmarshalStringName
 409        return (Just addrPrimTy,
 410                  \ e -> App (Var pack_id) e)
 411
 412     -- Objects; 'dotnet' only.
 413   | Just (tc, [arg_ty]) <- maybe_tc_app,
 414     tyConName tc == objectTyConName
 415   = do pack_id <- dsLookupGlobalId unmarshalObjectName
 416        return (Just addrPrimTy,
 417                  \ e -> App (Var pack_id) e)
 418
 419   | otherwise
 420   = pprPanic "resultWrapper" (ppr result_ty)
 421   where
 422     maybe_tc_app = splitTyConApp_maybe result_ty
 423
 424 -- When the result of a foreign call is smaller than the word size, we
 425 -- need to sign- or zero-extend the result up to the word size.  The C
 426 -- standard appears to say that this is the responsibility of the
 427 -- caller, not the callee.
 428
 429 maybeNarrow :: TyCon -> (CoreExpr -> CoreExpr)
 430 maybeNarrow tycon
 431   | tycon `hasKey` int8TyConKey   = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e
 432   | tycon `hasKey` int16TyConKey  = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e
 433   | tycon `hasKey` int32TyConKey
 434          && wORD_SIZE > 4         = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e
 435
 436   | tycon `hasKey` word8TyConKey  = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e
 437   | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e
 438   | tycon `hasKey` word32TyConKey
 439          && wORD_SIZE > 4         = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e
 440   | otherwise                     = id
 441 \end{code}