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