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