never executed always true always false
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
9
10
11 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
12
13 module GHC.HsToCore.Foreign.Call
14 ( dsCCall
15 , mkFCall
16 , unboxArg
17 , boxResult
18 , resultWrapper
19 )
20 where
21
22 import GHC.Prelude
23
24 import GHC.Core
25
26 import GHC.HsToCore.Monad
27 import GHC.Core.Utils
28 import GHC.Core.Make
29 import GHC.Types.SourceText
30 import GHC.Types.Id.Make
31 import GHC.Types.ForeignCall
32 import GHC.Core.DataCon
33 import GHC.HsToCore.Utils
34
35 import GHC.Tc.Utils.TcType
36 import GHC.Core.Type
37 import GHC.Core.Multiplicity
38 import GHC.Core.Coercion
39 import GHC.Builtin.Types.Prim
40 import GHC.Core.TyCon
41 import GHC.Builtin.Types
42 import GHC.Types.Basic
43 import GHC.Types.Literal
44 import GHC.Builtin.Names
45 import GHC.Driver.Session
46 import GHC.Utils.Outputable
47 import GHC.Utils.Panic
48 import GHC.Utils.Panic.Plain
49
50 import Data.Maybe
51
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 { State# 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
89 dsCCall :: CLabelString -- C routine to invoke
90 -> [CoreExpr] -- Arguments (desugared)
91 -- Precondition: none have representation-polymorphic types
92 -> Safety -- Safety of the call
93 -> Type -- Type of the result: IO t
94 -> DsM CoreExpr -- Result, of type ???
95
96 dsCCall lbl args may_gc result_ty
97 = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args
98 (ccall_result_ty, res_wrapper) <- boxResult result_ty
99 uniq <- newUnique
100 dflags <- getDynFlags
101 let
102 target = StaticTarget NoSourceText lbl Nothing True
103 the_fcall = CCall (CCallSpec target CCallConv may_gc)
104 the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty
105 return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
106
107 mkFCall :: DynFlags -> Unique -> ForeignCall
108 -> [CoreExpr] -- Args
109 -> Type -- Result type
110 -> CoreExpr
111 -- Construct the ccall. The only tricky bit is that the ccall Id should have
112 -- no free vars, so if any of the arg tys do we must give it a polymorphic type.
113 -- [I forget *why* it should have no free vars!]
114 -- For example:
115 -- mkCCall ... [s::StablePtr (a->b), x::Addr, c::Char]
116 --
117 -- Here we build a ccall thus
118 -- (ccallid::(forall a b. StablePtr (a -> b) -> Addr -> Char -> IO Addr))
119 -- a b s x c
120 mkFCall dflags uniq the_fcall val_args res_ty
121 = assert (all isTyVar tyvars) $ -- this must be true because the type is top-level
122 mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args
123 where
124 arg_tys = map exprType val_args
125 body_ty = (mkVisFunTysMany arg_tys res_ty)
126 tyvars = tyCoVarsOfTypeWellScoped body_ty
127 ty = mkInfForAllTys tyvars body_ty
128 the_fcall_id = mkFCallId dflags uniq the_fcall ty
129
130 unboxArg :: CoreExpr -- The supplied argument, not representation-polymorphic
131 -> DsM (CoreExpr, -- To pass as the actual argument
132 CoreExpr -> CoreExpr -- Wrapper to unbox the arg
133 )
134 -- Example: if the arg is e::Int, unboxArg will return
135 -- (x#::Int#, \W. case x of I# x# -> W)
136 -- where W is a CoreExpr that probably mentions x#
137
138 -- always returns a non-representation-polymorphic expression
139
140 unboxArg arg
141 -- Primitive types: nothing to unbox
142 | isPrimitiveType arg_ty
143 = return (arg, \body -> body)
144
145 -- Recursive newtypes
146 | Just(co, _rep_ty) <- topNormaliseNewType_maybe arg_ty
147 = unboxArg (mkCastDs arg co)
148
149 -- Booleans
150 | Just tc <- tyConAppTyCon_maybe arg_ty,
151 tc `hasKey` boolTyConKey
152 = do dflags <- getDynFlags
153 let platform = targetPlatform dflags
154 prim_arg <- newSysLocalDs Many intPrimTy
155 return (Var prim_arg,
156 \ body -> Case (mkIfThenElse arg (mkIntLit platform 1) (mkIntLit platform 0))
157 prim_arg
158 (exprType body)
159 [Alt DEFAULT [] body])
160
161 -- Data types with a single constructor, which has a single, primitive-typed arg
162 -- This deals with Int, Float etc; also Ptr, ForeignPtr
163 | is_product_type && data_con_arity == 1
164 = assertPpr (isUnliftedType data_con_arg_ty1) (pprType arg_ty) $
165 -- Typechecker ensures this
166 do case_bndr <- newSysLocalDs Many arg_ty
167 prim_arg <- newSysLocalDs Many data_con_arg_ty1
168 return (Var prim_arg,
169 \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) [prim_arg] body]
170 )
171
172 -- Byte-arrays, both mutable and otherwise; hack warning
173 -- We're looking for values of type ByteArray, MutableByteArray
174 -- data ByteArray ix = ByteArray ix ix ByteArray#
175 -- data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)
176 | is_product_type &&
177 data_con_arity == 3 &&
178 isJust maybe_arg3_tycon &&
179 (arg3_tycon == byteArrayPrimTyCon ||
180 arg3_tycon == mutableByteArrayPrimTyCon)
181 = do case_bndr <- newSysLocalDs Many arg_ty
182 vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs (map unrestricted data_con_arg_tys)
183 return (Var arr_cts_var,
184 \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) vars body]
185 )
186
187 | otherwise
188 = do l <- getSrcSpanDs
189 pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
190 where
191 arg_ty = exprType arg
192 maybe_product_type = splitDataProductType_maybe arg_ty
193 is_product_type = isJust maybe_product_type
194 Just (_, _, data_con, scaled_data_con_arg_tys) = maybe_product_type
195 data_con_arg_tys = map scaledThing scaled_data_con_arg_tys
196 data_con_arity = dataConSourceArity data_con
197 (data_con_arg_ty1 : _) = data_con_arg_tys
198
199 (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
200 maybe_arg3_tycon = tyConAppTyCon_maybe data_con_arg_ty3
201 Just arg3_tycon = maybe_arg3_tycon
202
203 boxResult :: Type
204 -> DsM (Type, CoreExpr -> CoreExpr)
205
206 -- Takes the result of the user-level ccall:
207 -- either (IO t),
208 -- or maybe just t for a side-effect-free call
209 -- Returns a wrapper for the primitive ccall itself, along with the
210 -- type of the result of the primitive ccall. This result type
211 -- will be of the form
212 -- State# RealWorld -> (# State# RealWorld, t' #)
213 -- where t' is the unwrapped form of t. If t is simply (), then
214 -- the result type will be
215 -- State# RealWorld -> (# State# RealWorld #)
216
217 boxResult result_ty
218 | Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty
219 -- isIOType_maybe handles the case where the type is a
220 -- simple wrapping of IO. E.g.
221 -- newtype Wrap a = W (IO a)
222 -- No coercion necessary because its a non-recursive newtype
223 -- (If we wanted to handle a *recursive* newtype too, we'd need
224 -- another case, and a coercion.)
225 -- The result is IO t, so wrap the result in an IO constructor
226 = do { res <- resultWrapper io_res_ty
227 ; let return_result state anss
228 = mkCoreUbxTup
229 [realWorldStatePrimTy, io_res_ty]
230 [state, anss]
231
232 ; (ccall_res_ty, the_alt) <- mk_alt return_result res
233
234 ; state_id <- newSysLocalDs Many realWorldStatePrimTy
235 ; let io_data_con = head (tyConDataCons io_tycon)
236 toIOCon = dataConWrapId io_data_con
237
238 wrap the_call =
239 mkApps (Var toIOCon)
240 [ Type io_res_ty,
241 Lam state_id $
242 mkWildCase (App the_call (Var state_id))
243 (unrestricted ccall_res_ty)
244 (coreAltType the_alt)
245 [the_alt]
246 ]
247
248 ; return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap) }
249
250 boxResult result_ty
251 = do -- It isn't IO, so do unsafePerformIO
252 -- It's not conveniently available, so we inline it
253 res <- resultWrapper result_ty
254 (ccall_res_ty, the_alt) <- mk_alt return_result res
255 let
256 wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId))
257 (unrestricted ccall_res_ty)
258 (coreAltType the_alt)
259 [the_alt]
260 return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap)
261 where
262 return_result _ ans = ans
263
264
265 mk_alt :: (Expr Var -> Expr Var -> Expr Var)
266 -> (Maybe Type, Expr Var -> Expr Var)
267 -> DsM (Type, CoreAlt)
268 mk_alt return_result (Nothing, wrap_result)
269 = do -- The ccall returns ()
270 state_id <- newSysLocalDs Many realWorldStatePrimTy
271 let
272 the_rhs = return_result (Var state_id)
273 (wrap_result (panic "boxResult"))
274
275 ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy]
276 the_alt = Alt (DataAlt (tupleDataCon Unboxed 1)) [state_id] the_rhs
277
278 return (ccall_res_ty, the_alt)
279
280 mk_alt return_result (Just prim_res_ty, wrap_result)
281 = -- The ccall returns a non-() value
282 assertPpr (isPrimitiveType prim_res_ty) (ppr prim_res_ty) $
283 -- True because resultWrapper ensures it is so
284 do { result_id <- newSysLocalDs Many prim_res_ty
285 ; state_id <- newSysLocalDs Many realWorldStatePrimTy
286 ; let the_rhs = return_result (Var state_id)
287 (wrap_result (Var result_id))
288 ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty]
289 the_alt = Alt (DataAlt (tupleDataCon Unboxed 2)) [state_id, result_id] the_rhs
290 ; return (ccall_res_ty, the_alt) }
291
292
293 resultWrapper :: Type
294 -> DsM (Maybe Type, -- Type of the expected result, if any
295 CoreExpr -> CoreExpr) -- Wrapper for the result
296 -- resultWrapper deals with the result *value*
297 -- E.g. foreign import foo :: Int -> IO T
298 -- Then resultWrapper deals with marshalling the 'T' part
299 -- So if resultWrapper ty = (Just ty_rep, marshal)
300 -- then marshal (e :: ty_rep) :: ty
301 -- That is, 'marshal' wrape the result returned by the foreign call,
302 -- of type ty_rep, into the value Haskell expected, of type 'ty'
303 --
304 -- Invariant: ty_rep is always a primitive type
305 -- i.e. (isPrimitiveType ty_rep) is True
306
307 resultWrapper result_ty
308 -- Base case 1: primitive types
309 | isPrimitiveType result_ty
310 = return (Just result_ty, \e -> e)
311
312 -- Base case 2: the unit type ()
313 | Just (tc,_) <- maybe_tc_app
314 , tc `hasKey` unitTyConKey
315 = return (Nothing, \_ -> unitExpr)
316
317 -- Base case 3: the boolean type
318 | Just (tc,_) <- maybe_tc_app
319 , tc `hasKey` boolTyConKey
320 = do { dflags <- getDynFlags
321 ; let platform = targetPlatform dflags
322 ; let marshal_bool e
323 = mkWildCase e (unrestricted intPrimTy) boolTy
324 [ Alt DEFAULT [] (Var trueDataConId )
325 , Alt (LitAlt (mkLitInt platform 0)) [] (Var falseDataConId)]
326 ; return (Just intPrimTy, marshal_bool) }
327
328 -- Newtypes
329 | Just (co, rep_ty) <- topNormaliseNewType_maybe result_ty
330 = do { (maybe_ty, wrapper) <- resultWrapper rep_ty
331 ; return (maybe_ty, \e -> mkCastDs (wrapper e) (mkSymCo co)) }
332
333 -- The type might contain foralls (eg. for dummy type arguments,
334 -- referring to 'Ptr a' is legal).
335 | Just (tyvar, rest) <- splitForAllTyCoVar_maybe result_ty
336 = do { (maybe_ty, wrapper) <- resultWrapper rest
337 ; return (maybe_ty, \e -> Lam tyvar (wrapper e)) }
338
339 -- Data types with a single constructor, which has a single arg
340 -- This includes types like Ptr and ForeignPtr
341 | Just (tycon, tycon_arg_tys) <- maybe_tc_app
342 , Just data_con <- tyConSingleAlgDataCon_maybe tycon -- One constructor
343 , null (dataConExTyCoVars data_con) -- no existentials
344 , [Scaled _ unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys -- One argument
345 = do { (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty
346 ; let marshal_con e = Var (dataConWrapId data_con)
347 `mkTyApps` tycon_arg_tys
348 `App` wrapper e
349 ; return (maybe_ty, marshal_con) }
350
351 | otherwise
352 = pprPanic "resultWrapper" (ppr result_ty)
353 where
354 maybe_tc_app = splitTyConApp_maybe result_ty