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