DsCCall.hs 14.3 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3 4
{-
(c) The University of Glasgow 2006
(c) The AQUA Project, Glasgow University, 1994-1998

Simon Marlow's avatar
Simon Marlow committed
5 6

Desugaring foreign calls
Austin Seipp's avatar
Austin Seipp committed
7
-}
8

9
{-# LANGUAGE CPP #-}
10 11 12 13 14 15 16
module DsCCall
        ( dsCCall
        , mkFCall
        , unboxArg
        , boxResult
        , resultWrapper
        ) where
17

18
#include "HsVersions.h"
19

20

21
import CoreSyn
22

23 24
import DsMonad

Simon Marlow's avatar
Simon Marlow committed
25
import CoreUtils
26
import MkCore
Ian Lynagh's avatar
Ian Lynagh committed
27
import Var
Simon Marlow's avatar
Simon Marlow committed
28 29 30 31 32 33 34 35 36 37 38 39
import MkId
import ForeignCall
import DataCon

import TcType
import Type
import Coercion
import PrimOp
import TysPrim
import TyCon
import TysWiredIn
import BasicTypes
40
import FastString ( unpackFS )
Simon Marlow's avatar
Simon Marlow committed
41 42 43
import Literal
import PrelNames
import VarSet
Ian Lynagh's avatar
Ian Lynagh committed
44
import DynFlags
45
import Outputable
46
import Util
Icelandjack's avatar
Icelandjack committed
47 48

import Data.Maybe
49

Austin Seipp's avatar
Austin Seipp committed
50
{-
51 52 53 54 55
Desugaring of @ccall@s consists of adding some state manipulation,
unboxing any boxed primitive arguments and boxing the result if
desired.

The state stuff just consists of adding in
56
@PrimIO (\ s -> case s of { S# s# -> ... })@ in an appropriate place.
57 58 59 60 61

The unboxing is straightforward, as all information needed to unbox is
available from the type.  For each boxed-primitive argument, we
transform:
\begin{verbatim}
62
   _ccall_ foo [ r, t1, ... tm ] e1 ... em
63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82
   |
   |
   V
   case e1 of { T1# x1# ->
   ...
   case em of { Tm# xm# -> xm#
   ccall# foo [ r, t1#, ... tm# ] x1# ... xm#
   } ... }
\end{verbatim}

The reboxing of a @_ccall_@ result is a bit tricker: the types don't
contain information about the state-pairing functions so we have to
keep a list of \tr{(type, s-p-function)} pairs.  We transform as
follows:
\begin{verbatim}
   ccall# foo [ r, t1#, ... tm# ] e1# ... em#
   |
   |
   V
   \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of
83
          (StateAnd<r># result# state#) -> (R# result#, realWorld#)
84
\end{verbatim}
Austin Seipp's avatar
Austin Seipp committed
85
-}
86

87 88 89 90 91
dsCCall :: CLabelString -- C routine to invoke
        -> [CoreExpr]   -- Arguments (desugared)
        -> Safety       -- Safety of the call
        -> Type         -- Type of the result: IO t
        -> DsM CoreExpr -- Result, of type ???
92

93
dsCCall lbl args may_gc result_ty
94
  = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args
95
       (ccall_result_ty, res_wrapper) <- boxResult result_ty
96
       uniq <- newUnique
Ian Lynagh's avatar
Ian Lynagh committed
97
       dflags <- getDynFlags
98
       let
99
           target = StaticTarget (unpackFS lbl) lbl Nothing True
100
           the_fcall    = CCall (CCallSpec target CCallConv may_gc)
Ian Lynagh's avatar
Ian Lynagh committed
101
           the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty
102
       return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
103

104 105 106 107
mkFCall :: DynFlags -> Unique -> ForeignCall
        -> [CoreExpr]   -- Args
        -> Type         -- Result type
        -> CoreExpr
108 109
-- Construct the ccall.  The only tricky bit is that the ccall Id should have
-- no free vars, so if any of the arg tys do we must give it a polymorphic type.
110
--      [I forget *why* it should have no free vars!]
111
-- For example:
112
--      mkCCall ... [s::StablePtr (a->b), x::Addr, c::Char]
113 114
--
-- Here we build a ccall thus
115 116
--      (ccallid::(forall a b.  StablePtr (a -> b) -> Addr -> Char -> IO Addr))
--                      a b s x c
Ian Lynagh's avatar
Ian Lynagh committed
117
mkFCall dflags uniq the_fcall val_args res_ty
118
  = mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args
119 120 121 122
  where
    arg_tys = map exprType val_args
    body_ty = (mkFunTys arg_tys res_ty)
    tyvars  = varSetElems (tyVarsOfType body_ty)
123
    ty      = mkForAllTys tyvars body_ty
Ian Lynagh's avatar
Ian Lynagh committed
124
    the_fcall_id = mkFCallId dflags uniq the_fcall ty
125

126 127 128 129
unboxArg :: CoreExpr                    -- The supplied argument
         -> DsM (CoreExpr,              -- To pass as the actual argument
                 CoreExpr -> CoreExpr   -- Wrapper to unbox the arg
                )
130
-- Example: if the arg is e::Int, unboxArg will return
131
--      (x#::Int#, \W. case x of I# x# -> W)
132
-- where W is a CoreExpr that probably mentions x#
133

134
unboxArg arg
135 136
  -- Primtive types: nothing to unbox
  | isPrimitiveType arg_ty
137
  = return (arg, \body -> body)
138

139
  -- Recursive newtypes
140
  | Just(co, _rep_ty) <- topNormaliseNewType_maybe arg_ty
141
  = unboxArg (mkCast arg co)
142

143
  -- Booleans
144
  | Just tc <- tyConAppTyCon_maybe arg_ty,
145
    tc `hasKey` boolTyConKey
146 147
  = do dflags <- getDynFlags
       prim_arg <- newSysLocalDs intPrimTy
148
       return (Var prim_arg,
149
              \ body -> Case (mkWildCase arg arg_ty intPrimTy
150 151
                                       [(DataAlt falseDataCon,[],mkIntLit dflags 0),
                                        (DataAlt trueDataCon, [],mkIntLit dflags 1)])
152
                                        -- In increasing tag order!
153
                             prim_arg
154
                             (exprType body)
155
                             [(DEFAULT,[],body)])
156 157

  -- Data types with a single constructor, which has a single, primitive-typed arg
158
  -- This deals with Int, Float etc; also Ptr, ForeignPtr
159
  | is_product_type && data_con_arity == 1
160
  = ASSERT2(isUnLiftedType data_con_arg_ty1, pprType arg_ty)
161 162 163 164 165 166
                        -- Typechecker ensures this
    do case_bndr <- newSysLocalDs arg_ty
       prim_arg <- newSysLocalDs data_con_arg_ty1
       return (Var prim_arg,
               \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)]
              )
167

168
  -- Byte-arrays, both mutable and otherwise; hack warning
169
  -- We're looking for values of type ByteArray, MutableByteArray
170 171
  --    data ByteArray          ix = ByteArray        ix ix ByteArray#
  --    data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)
172
  | is_product_type &&
173
    data_con_arity == 3 &&
Icelandjack's avatar
Icelandjack committed
174
    isJust maybe_arg3_tycon &&
175 176
    (arg3_tycon ==  byteArrayPrimTyCon ||
     arg3_tycon ==  mutableByteArrayPrimTyCon)
177
  = do case_bndr <- newSysLocalDs arg_ty
Ian Lynagh's avatar
Ian Lynagh committed
178
       vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys
179 180 181
       return (Var arr_cts_var,
               \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)]
              )
182 183

  | otherwise
184 185
  = do l <- getSrcSpanDs
       pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
186
  where
187 188 189 190 191 192
    arg_ty                                      = exprType arg
    maybe_product_type                          = splitDataProductType_maybe arg_ty
    is_product_type                             = isJust maybe_product_type
    Just (_, _, data_con, data_con_arg_tys)     = maybe_product_type
    data_con_arity                              = dataConSourceArity data_con
    (data_con_arg_ty1 : _)                      = data_con_arg_tys
193

194
    (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
195 196
    maybe_arg3_tycon               = tyConAppTyCon_maybe data_con_arg_ty3
    Just arg3_tycon                = maybe_arg3_tycon
197

198
boxResult :: Type
199
          -> DsM (Type, CoreExpr -> CoreExpr)
200

201 202 203
-- Takes the result of the user-level ccall:
--      either (IO t),
--      or maybe just t for an side-effect-free call
204 205
-- Returns a wrapper for the primitive ccall itself, along with the
-- type of the result of the primitive ccall.  This result type
206 207
-- will be of the form
--      State# RealWorld -> (# State# RealWorld, t' #)
208
-- where t' is the unwrapped form of t.  If t is simply (), then
209 210
-- the result type will be
--      State# RealWorld -> (# State# RealWorld #)
211

212
boxResult result_ty
213
  | Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty
214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229
        -- isIOType_maybe handles the case where the type is a
        -- simple wrapping of IO.  E.g.
        --      newtype Wrap a = W (IO a)
        -- No coercion necessary because its a non-recursive newtype
        -- (If we wanted to handle a *recursive* newtype too, we'd need
        -- another case, and a coercion.)
        -- The result is IO t, so wrap the result in an IO constructor
  = do  { res <- resultWrapper io_res_ty
        ; let extra_result_tys
                = case res of
                     (Just ty,_)
                       | isUnboxedTupleType ty
                       -> let Just ls = tyConAppArgs_maybe ty in tail ls
                     _ -> []

              return_result state anss
230
                = mkCoreConApps (tupleDataCon Unboxed (2 + length extra_result_tys))
231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250
                                (map Type (realWorldStatePrimTy : io_res_ty : extra_result_tys)
                                 ++ (state : anss))

        ; (ccall_res_ty, the_alt) <- mk_alt return_result res

        ; state_id <- newSysLocalDs realWorldStatePrimTy
        ; let io_data_con = head (tyConDataCons io_tycon)
              toIOCon     = dataConWrapId io_data_con

              wrap the_call =
                              mkApps (Var toIOCon)
                                     [ Type io_res_ty,
                                       Lam state_id $
                                       mkWildCase (App the_call (Var state_id))
                                             ccall_res_ty
                                             (coreAltType the_alt)
                                             [the_alt]
                                     ]

        ; return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) }
251

252
boxResult result_ty
253 254 255
  = do -- It isn't IO, so do unsafePerformIO
       -- It's not conveniently available, so we inline it
       res <- resultWrapper result_ty
256
       (ccall_res_ty, the_alt) <- mk_alt return_result res
257
       let
258 259 260 261
           wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId))
                                           ccall_res_ty
                                           (coreAltType the_alt)
                                           [the_alt]
262
       return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
263
  where
Ian Lynagh's avatar
Ian Lynagh committed
264 265
    return_result _ [ans] = ans
    return_result _ _     = panic "return_result: expected single result"
266 267


Ian Lynagh's avatar
Ian Lynagh committed
268 269 270
mk_alt :: (Expr Var -> [Expr Var] -> Expr Var)
       -> (Maybe Type, Expr Var -> Expr Var)
       -> DsM (Type, (AltCon, [Id], Expr Var))
271
mk_alt return_result (Nothing, wrap_result)
272 273 274
  = do -- The ccall returns ()
       state_id <- newSysLocalDs realWorldStatePrimTy
       let
275
             the_rhs = return_result (Var state_id)
276
                                     [wrap_result (panic "boxResult")]
277

278 279
             ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy]
             the_alt      = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs)
280

281
       return (ccall_res_ty, the_alt)
282

283
mk_alt return_result (Just prim_res_ty, wrap_result)
284
                -- The ccall returns a non-() value
285
  | isUnboxedTupleType prim_res_ty= do
286
    let
287
        Just ls = tyConAppArgs_maybe prim_res_ty
288 289 290 291
        arity = 1 + length ls
    args_ids@(result_id:as) <- mapM newSysLocalDs ls
    state_id <- newSysLocalDs realWorldStatePrimTy
    let
292
        the_rhs = return_result (Var state_id)
293
                                (wrap_result (Var result_id) : map Var as)
294
        ccall_res_ty = mkTyConApp (tupleTyCon Unboxed arity)
295
                                  (realWorldStatePrimTy : ls)
296
        the_alt      = ( DataAlt (tupleDataCon Unboxed arity)
297 298 299 300 301 302 303 304
                       , (state_id : args_ids)
                       , the_rhs
                       )
    return (ccall_res_ty, the_alt)

  | otherwise = do
    result_id <- newSysLocalDs prim_res_ty
    state_id <- newSysLocalDs realWorldStatePrimTy
305
    let
306
        the_rhs = return_result (Var state_id)
307 308 309 310
                                [wrap_result (Var result_id)]
        ccall_res_ty = mkTyConApp unboxedPairTyCon [realWorldStatePrimTy, prim_res_ty]
        the_alt      = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs)
    return (ccall_res_ty, the_alt)
311 312 313


resultWrapper :: Type
314
              -> DsM (Maybe Type,               -- Type of the expected result, if any
315
                      CoreExpr -> CoreExpr)     -- Wrapper for the result
316 317 318
-- resultWrapper deals with the result *value*
-- E.g. foreign import foo :: Int -> IO T
-- Then resultWrapper deals with marshalling the 'T' part
319 320
resultWrapper result_ty
  -- Base case 1: primitive types
321
  | isPrimitiveType result_ty
322
  = return (Just result_ty, \e -> e)
323

324
  -- Base case 2: the unit type ()
325
  | Just (tc,_) <- maybe_tc_app, tc `hasKey` unitTyConKey
Ian Lynagh's avatar
Ian Lynagh committed
326
  = return (Nothing, \_ -> Var unitDataConId)
327

328
  -- Base case 3: the boolean type
329
  | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey
330 331 332
  = do
    dflags <- getDynFlags
    return
333
     (Just intPrimTy, \e -> mkWildCase e intPrimTy
334
                                   boolTy
335 336
                                   [(DEFAULT                    ,[],Var trueDataConId ),
                                    (LitAlt (mkMachInt dflags 0),[],Var falseDataConId)])
337

338 339
  -- Newtypes
  | Just (co, rep_ty) <- topNormaliseNewType_maybe result_ty
340
  = do (maybe_ty, wrapper) <- resultWrapper rep_ty
341
       return (maybe_ty, \e -> mkCast (wrapper e) (mkSymCo co))
342

343 344 345
  -- The type might contain foralls (eg. for dummy type arguments,
  -- referring to 'Ptr a' is legal).
  | Just (tyvar, rest) <- splitForAllTy_maybe result_ty
346 347
  = do (maybe_ty, wrapper) <- resultWrapper rest
       return (maybe_ty, \e -> Lam tyvar (wrapper e))
348

349
  -- Data types with a single constructor, which has a single arg
350
  -- This includes types like Ptr and ForeignPtr
351
  | Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitDataProductType_maybe result_ty,
352
    dataConSourceArity data_con == 1
353 354
  = do dflags <- getDynFlags
       let
355
           (unwrapped_res_ty : _) = data_con_arg_tys
356
           narrow_wrapper         = maybeNarrow dflags tycon
357 358
       (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty
       return
359
         (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con))
360
                                 (map Type tycon_arg_tys ++ [wrapper (narrow_wrapper e)]))
sof's avatar
sof committed
361

362
  | otherwise
363
  = pprPanic "resultWrapper" (ppr result_ty)
364
  where
365
    maybe_tc_app = splitTyConApp_maybe result_ty
366 367 368 369 370 371

-- When the result of a foreign call is smaller than the word size, we
-- need to sign- or zero-extend the result up to the word size.  The C
-- standard appears to say that this is the responsibility of the
-- caller, not the callee.

372 373
maybeNarrow :: DynFlags -> TyCon -> (CoreExpr -> CoreExpr)
maybeNarrow dflags tycon
374 375 376
  | tycon `hasKey` int8TyConKey   = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e
  | tycon `hasKey` int16TyConKey  = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e
  | tycon `hasKey` int32TyConKey
377
         && wORD_SIZE dflags > 4         = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e
378 379 380 381

  | tycon `hasKey` word8TyConKey  = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e
  | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e
  | tycon `hasKey` word32TyConKey
382 383
         && wORD_SIZE dflags > 4         = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e
  | otherwise                     = id