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