{-
(c) The University of Glasgow 2006
(c) The AQUA Project, Glasgow University, 1994-1998


Desugaring foreign calls
-}

{-# LANGUAGE CPP #-}
module DsCCall
        ( dsCCall
        , mkFCall
        , unboxArg
        , boxResult
        , resultWrapper
        ) where

#include "HsVersions.h"


import GhcPrelude

import CoreSyn

import DsMonad
import CoreUtils
import MkCore
import MkId
import ForeignCall
import DataCon
import DsUtils

import TcType
import Type
import Id   ( Id )
import Coercion
import PrimOp
import TysPrim
import TyCon
import TysWiredIn
import BasicTypes
import Literal
import PrelNames
import DynFlags
import Outputable
import Util

import Data.Maybe

{-
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
@PrimIO (\ s -> case s of { S# s# -> ... })@ in an appropriate place.

The unboxing is straightforward, as all information needed to unbox is
available from the type.  For each boxed-primitive argument, we
transform:
\begin{verbatim}
   _ccall_ foo [ r, t1, ... tm ] e1 ... em
   |
   |
   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
          (StateAnd<r># result# state#) -> (R# result#, realWorld#)
\end{verbatim}
-}

dsCCall :: CLabelString -- C routine to invoke
        -> [CoreExpr]   -- Arguments (desugared)
                        -- Precondition: none have levity-polymorphic types
        -> Safety       -- Safety of the call
        -> Type         -- Type of the result: IO t
        -> DsM CoreExpr -- Result, of type ???

dsCCall :: CLabelString -> [CoreExpr] -> Safety -> Type -> DsM CoreExpr
dsCCall lbl :: CLabelString
lbl args :: [CoreExpr]
args may_gc :: Safety
may_gc result_ty :: Type
result_ty
  = do (unboxed_args :: [CoreExpr]
unboxed_args, arg_wrappers :: [CoreExpr -> CoreExpr]
arg_wrappers) <- (CoreExpr
 -> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr))
-> [CoreExpr]
-> IOEnv
     (Env DsGblEnv DsLclEnv) ([CoreExpr], [CoreExpr -> CoreExpr])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM CoreExpr
-> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
unboxArg [CoreExpr]
args
       (ccall_result_ty :: Type
ccall_result_ty, res_wrapper :: CoreExpr -> CoreExpr
res_wrapper) <- Type -> DsM (Type, CoreExpr -> CoreExpr)
boxResult Type
result_ty
       Unique
uniq <- TcRnIf DsGblEnv DsLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
       DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       let
           target :: CCallTarget
target = SourceText -> CLabelString -> Maybe UnitId -> Bool -> CCallTarget
StaticTarget SourceText
NoSourceText CLabelString
lbl Maybe UnitId
forall a. Maybe a
Nothing Bool
True
           the_fcall :: ForeignCall
the_fcall    = CCallSpec -> ForeignCall
CCall (CCallTarget -> CCallConv -> Safety -> CCallSpec
CCallSpec CCallTarget
target CCallConv
CCallConv Safety
may_gc)
           the_prim_app :: CoreExpr
the_prim_app = DynFlags -> Unique -> ForeignCall -> [CoreExpr] -> Type -> CoreExpr
mkFCall DynFlags
dflags Unique
uniq ForeignCall
the_fcall [CoreExpr]
unboxed_args Type
ccall_result_ty
       CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (((CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr)
-> CoreExpr -> [CoreExpr -> CoreExpr] -> CoreExpr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
($) (CoreExpr -> CoreExpr
res_wrapper CoreExpr
the_prim_app) [CoreExpr -> CoreExpr]
arg_wrappers)

mkFCall :: DynFlags -> Unique -> ForeignCall
        -> [CoreExpr]     -- Args
        -> Type           -- Result type
        -> CoreExpr
-- 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.
--      [I forget *why* it should have no free vars!]
-- For example:
--      mkCCall ... [s::StablePtr (a->b), x::Addr, c::Char]
--
-- Here we build a ccall thus
--      (ccallid::(forall a b.  StablePtr (a -> b) -> Addr -> Char -> IO Addr))
--                      a b s x c
mkFCall :: DynFlags -> Unique -> ForeignCall -> [CoreExpr] -> Type -> CoreExpr
mkFCall dflags :: DynFlags
dflags uniq :: Unique
uniq the_fcall :: ForeignCall
the_fcall val_args :: [CoreExpr]
val_args res_ty :: Type
res_ty
  = ASSERT( all isTyVar tyvars )  -- this must be true because the type is top-level
    CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (CoreExpr -> [Var] -> CoreExpr
forall b. Expr b -> [Var] -> Expr b
mkVarApps (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
the_fcall_id) [Var]
tyvars) [CoreExpr]
val_args
  where
    arg_tys :: [Type]
arg_tys = (CoreExpr -> Type) -> [CoreExpr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map CoreExpr -> Type
exprType [CoreExpr]
val_args
    body_ty :: Type
body_ty = ([Type] -> Type -> Type
mkFunTys [Type]
arg_tys Type
res_ty)
    tyvars :: [Var]
tyvars  = Type -> [Var]
tyCoVarsOfTypeWellScoped Type
body_ty
    ty :: Type
ty      = [Var] -> Type -> Type
mkInvForAllTys [Var]
tyvars Type
body_ty
    the_fcall_id :: Var
the_fcall_id = DynFlags -> Unique -> ForeignCall -> Type -> Var
mkFCallId DynFlags
dflags Unique
uniq ForeignCall
the_fcall Type
ty

unboxArg :: CoreExpr                    -- The supplied argument, not levity-polymorphic
         -> DsM (CoreExpr,              -- To pass as the actual argument
                 CoreExpr -> CoreExpr   -- Wrapper to unbox the arg
                )
-- Example: if the arg is e::Int, unboxArg will return
--      (x#::Int#, \W. case x of I# x# -> W)
-- where W is a CoreExpr that probably mentions x#

-- always returns a non-levity-polymorphic expression

unboxArg :: CoreExpr
-> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
unboxArg arg :: CoreExpr
arg
  -- Primitive types: nothing to unbox
  | Type -> Bool
isPrimitiveType Type
arg_ty
  = (CoreExpr, CoreExpr -> CoreExpr)
-> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr
arg, \body :: CoreExpr
body -> CoreExpr
body)

  -- Recursive newtypes
  | Just(co :: Coercion
co, _rep_ty :: Type
_rep_ty) <- Type -> Maybe (Coercion, Type)
topNormaliseNewType_maybe Type
arg_ty
  = CoreExpr
-> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
unboxArg (CoreExpr -> Coercion -> CoreExpr
mkCastDs CoreExpr
arg Coercion
co)

  -- Booleans
  | Just tc :: TyCon
tc <- Type -> Maybe TyCon
tyConAppTyCon_maybe Type
arg_ty,
    TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
boolTyConKey
  = do DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       Var
prim_arg <- Type -> DsM Var
newSysLocalDs Type
intPrimTy
       (CoreExpr, CoreExpr -> CoreExpr)
-> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
prim_arg,
              \ body :: CoreExpr
body -> CoreExpr -> Var -> Type -> [Alt Var] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (CoreExpr -> Type -> Type -> [Alt Var] -> CoreExpr
mkWildCase CoreExpr
arg Type
arg_ty Type
intPrimTy
                                       [(DataCon -> AltCon
DataAlt DataCon
falseDataCon,[],DynFlags -> Integer -> CoreExpr
forall b. DynFlags -> Integer -> Expr b
mkIntLit DynFlags
dflags 0),
                                        (DataCon -> AltCon
DataAlt DataCon
trueDataCon, [],DynFlags -> Integer -> CoreExpr
forall b. DynFlags -> Integer -> Expr b
mkIntLit DynFlags
dflags 1)])
                                        -- In increasing tag order!
                             Var
prim_arg
                             (CoreExpr -> Type
exprType CoreExpr
body)
                             [(AltCon
DEFAULT,[],CoreExpr
body)])

  -- Data types with a single constructor, which has a single, primitive-typed arg
  -- This deals with Int, Float etc; also Ptr, ForeignPtr
  | Bool
is_product_type Bool -> Bool -> Bool
&& Int
data_con_arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1
  = ASSERT2(isUnliftedType data_con_arg_ty1, pprType arg_ty)
                        -- Typechecker ensures this
    do Var
case_bndr <- Type -> DsM Var
newSysLocalDs Type
arg_ty
       Var
prim_arg <- Type -> DsM Var
newSysLocalDs Type
data_con_arg_ty1
       (CoreExpr, CoreExpr -> CoreExpr)
-> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
prim_arg,
               \ body :: CoreExpr
body -> CoreExpr -> Var -> Type -> [Alt Var] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
arg Var
case_bndr (CoreExpr -> Type
exprType CoreExpr
body) [(DataCon -> AltCon
DataAlt DataCon
data_con,[Var
prim_arg],CoreExpr
body)]
              )

  -- Byte-arrays, both mutable and otherwise; hack warning
  -- We're looking for values of type ByteArray, MutableByteArray
  --    data ByteArray          ix = ByteArray        ix ix ByteArray#
  --    data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)
  | Bool
is_product_type Bool -> Bool -> Bool
&&
    Int
data_con_arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 3 Bool -> Bool -> Bool
&&
    Maybe TyCon -> Bool
forall a. Maybe a -> Bool
isJust Maybe TyCon
maybe_arg3_tycon Bool -> Bool -> Bool
&&
    (TyCon
arg3_tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
==  TyCon
byteArrayPrimTyCon Bool -> Bool -> Bool
||
     TyCon
arg3_tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
==  TyCon
mutableByteArrayPrimTyCon)
  = do Var
case_bndr <- Type -> DsM Var
newSysLocalDs Type
arg_ty
       vars :: [Var]
vars@[_l_var :: Var
_l_var, _r_var :: Var
_r_var, arr_cts_var :: Var
arr_cts_var] <- [Type] -> DsM [Var]
newSysLocalsDs [Type]
data_con_arg_tys
       (CoreExpr, CoreExpr -> CoreExpr)
-> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
arr_cts_var,
               \ body :: CoreExpr
body -> CoreExpr -> Var -> Type -> [Alt Var] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
arg Var
case_bndr (CoreExpr -> Type
exprType CoreExpr
body) [(DataCon -> AltCon
DataAlt DataCon
data_con,[Var]
vars,CoreExpr
body)]
              )

  | Bool
otherwise
  = do SrcSpan
l <- DsM SrcSpan
getSrcSpanDs
       String
-> SDoc
-> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
forall a. HasCallStack => String -> SDoc -> a
pprPanic "unboxArg: " (SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
l SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
arg_ty)
  where
    arg_ty :: Type
arg_ty                                      = CoreExpr -> Type
exprType CoreExpr
arg
    maybe_product_type :: Maybe (TyCon, [Type], DataCon, [Type])
maybe_product_type                          = Type -> Maybe (TyCon, [Type], DataCon, [Type])
splitDataProductType_maybe Type
arg_ty
    is_product_type :: Bool
is_product_type                             = Maybe (TyCon, [Type], DataCon, [Type]) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (TyCon, [Type], DataCon, [Type])
maybe_product_type
    Just (_, _, data_con :: DataCon
data_con, data_con_arg_tys :: [Type]
data_con_arg_tys)     = Maybe (TyCon, [Type], DataCon, [Type])
maybe_product_type
    data_con_arity :: Int
data_con_arity                              = DataCon -> Int
dataConSourceArity DataCon
data_con
    (data_con_arg_ty1 :: Type
data_con_arg_ty1 : _)                      = [Type]
data_con_arg_tys

    (_ : _ : data_con_arg_ty3 :: Type
data_con_arg_ty3 : _) = [Type]
data_con_arg_tys
    maybe_arg3_tycon :: Maybe TyCon
maybe_arg3_tycon               = Type -> Maybe TyCon
tyConAppTyCon_maybe Type
data_con_arg_ty3
    Just arg3_tycon :: TyCon
arg3_tycon                = Maybe TyCon
maybe_arg3_tycon

boxResult :: Type
          -> DsM (Type, CoreExpr -> CoreExpr)

-- Takes the result of the user-level ccall:
--      either (IO t),
--      or maybe just t for a side-effect-free call
-- Returns a wrapper for the primitive ccall itself, along with the
-- type of the result of the primitive ccall.  This result type
-- will be of the form
--      State# RealWorld -> (# State# RealWorld, t' #)
-- where t' is the unwrapped form of t.  If t is simply (), then
-- the result type will be
--      State# RealWorld -> (# State# RealWorld #)

boxResult :: Type -> DsM (Type, CoreExpr -> CoreExpr)
boxResult result_ty :: Type
result_ty
  | Just (io_tycon :: TyCon
io_tycon, io_res_ty :: Type
io_res_ty) <- Type -> Maybe (TyCon, Type)
tcSplitIOType_maybe Type
result_ty
        -- 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  { (Maybe Type, CoreExpr -> CoreExpr)
res <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
resultWrapper Type
io_res_ty
        ; let extra_result_tys :: [Type]
extra_result_tys
                = case (Maybe Type, CoreExpr -> CoreExpr)
res of
                     (Just ty :: Type
ty,_)
                       | Type -> Bool
isUnboxedTupleType Type
ty
                       -> let Just ls :: [Type]
ls = Type -> Maybe [Type]
tyConAppArgs_maybe Type
ty in [Type] -> [Type]
forall a. [a] -> [a]
tail [Type]
ls
                     _ -> []

              return_result :: CoreExpr -> [CoreExpr] -> CoreExpr
return_result state :: CoreExpr
state anss :: [CoreExpr]
anss
                = [Type] -> [CoreExpr] -> CoreExpr
mkCoreUbxTup
                    (Type
realWorldStatePrimTy Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type
io_res_ty Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
extra_result_tys)
                    (CoreExpr
state CoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
: [CoreExpr]
anss)

        ; (ccall_res_ty :: Type
ccall_res_ty, the_alt :: Alt Var
the_alt) <- (CoreExpr -> [CoreExpr] -> CoreExpr)
-> (Maybe Type, CoreExpr -> CoreExpr) -> DsM (Type, Alt Var)
mk_alt CoreExpr -> [CoreExpr] -> CoreExpr
return_result (Maybe Type, CoreExpr -> CoreExpr)
res

        ; Var
state_id <- Type -> DsM Var
newSysLocalDs Type
realWorldStatePrimTy
        ; let io_data_con :: DataCon
io_data_con = [DataCon] -> DataCon
forall a. [a] -> a
head (TyCon -> [DataCon]
tyConDataCons TyCon
io_tycon)
              toIOCon :: Var
toIOCon     = DataCon -> Var
dataConWrapId DataCon
io_data_con

              wrap :: CoreExpr -> CoreExpr
wrap the_call :: CoreExpr
the_call =
                              CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
toIOCon)
                                     [ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
io_res_ty,
                                       Var -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Var
state_id (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
                                       CoreExpr -> Type -> Type -> [Alt Var] -> CoreExpr
mkWildCase (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
the_call (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
state_id))
                                             Type
ccall_res_ty
                                             (Alt Var -> Type
coreAltType Alt Var
the_alt)
                                             [Alt Var
the_alt]
                                     ]

        ; (Type, CoreExpr -> CoreExpr) -> DsM (Type, CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
realWorldStatePrimTy Type -> Type -> Type
`mkFunTy` Type
ccall_res_ty, CoreExpr -> CoreExpr
wrap) }

boxResult result_ty :: Type
result_ty
  = do -- It isn't IO, so do unsafePerformIO
       -- It's not conveniently available, so we inline it
       (Maybe Type, CoreExpr -> CoreExpr)
res <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
resultWrapper Type
result_ty
       (ccall_res_ty :: Type
ccall_res_ty, the_alt :: Alt Var
the_alt) <- (CoreExpr -> [CoreExpr] -> CoreExpr)
-> (Maybe Type, CoreExpr -> CoreExpr) -> DsM (Type, Alt Var)
mk_alt CoreExpr -> [CoreExpr] -> CoreExpr
forall p p. p -> [p] -> p
return_result (Maybe Type, CoreExpr -> CoreExpr)
res
       let
           wrap :: CoreExpr -> CoreExpr
wrap = \ the_call :: CoreExpr
the_call -> CoreExpr -> Type -> Type -> [Alt Var] -> CoreExpr
mkWildCase (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
the_call (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
realWorldPrimId))
                                           Type
ccall_res_ty
                                           (Alt Var -> Type
coreAltType Alt Var
the_alt)
                                           [Alt Var
the_alt]
       (Type, CoreExpr -> CoreExpr) -> DsM (Type, CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
realWorldStatePrimTy Type -> Type -> Type
`mkFunTy` Type
ccall_res_ty, CoreExpr -> CoreExpr
wrap)
  where
    return_result :: p -> [p] -> p
return_result _ [ans :: p
ans] = p
ans
    return_result _ _     = String -> p
forall a. String -> a
panic "return_result: expected single result"


mk_alt :: (Expr Var -> [Expr Var] -> Expr Var)
       -> (Maybe Type, Expr Var -> Expr Var)
       -> DsM (Type, (AltCon, [Id], Expr Var))
mk_alt :: (CoreExpr -> [CoreExpr] -> CoreExpr)
-> (Maybe Type, CoreExpr -> CoreExpr) -> DsM (Type, Alt Var)
mk_alt return_result :: CoreExpr -> [CoreExpr] -> CoreExpr
return_result (Nothing, wrap_result :: CoreExpr -> CoreExpr
wrap_result)
  = do -- The ccall returns ()
       Var
state_id <- Type -> DsM Var
newSysLocalDs Type
realWorldStatePrimTy
       let
             the_rhs :: CoreExpr
the_rhs = CoreExpr -> [CoreExpr] -> CoreExpr
return_result (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
state_id)
                                     [CoreExpr -> CoreExpr
wrap_result (String -> CoreExpr
forall a. String -> a
panic "boxResult")]

             ccall_res_ty :: Type
ccall_res_ty = Boxity -> [Type] -> Type
mkTupleTy Boxity
Unboxed [Type
realWorldStatePrimTy]
             the_alt :: Alt Var
the_alt      = (DataCon -> AltCon
DataAlt (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed 1), [Var
state_id], CoreExpr
the_rhs)

       (Type, Alt Var) -> DsM (Type, Alt Var)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
ccall_res_ty, Alt Var
the_alt)

mk_alt return_result :: CoreExpr -> [CoreExpr] -> CoreExpr
return_result (Just prim_res_ty :: Type
prim_res_ty, wrap_result :: CoreExpr -> CoreExpr
wrap_result)
  = -- The ccall returns a non-() value
    ASSERT2( isPrimitiveType prim_res_ty, ppr prim_res_ty )
             -- True because resultWrapper ensures it is so
    do { Var
result_id <- Type -> DsM Var
newSysLocalDs Type
prim_res_ty
       ; Var
state_id <- Type -> DsM Var
newSysLocalDs Type
realWorldStatePrimTy
       ; let the_rhs :: CoreExpr
the_rhs = CoreExpr -> [CoreExpr] -> CoreExpr
return_result (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
state_id)
                                [CoreExpr -> CoreExpr
wrap_result (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
result_id)]
             ccall_res_ty :: Type
ccall_res_ty = Boxity -> [Type] -> Type
mkTupleTy Boxity
Unboxed [Type
realWorldStatePrimTy, Type
prim_res_ty]
             the_alt :: Alt Var
the_alt      = (DataCon -> AltCon
DataAlt (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed 2), [Var
state_id, Var
result_id], CoreExpr
the_rhs)
       ; (Type, Alt Var) -> DsM (Type, Alt Var)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
ccall_res_ty, Alt Var
the_alt) }


resultWrapper :: Type
              -> DsM (Maybe Type,               -- Type of the expected result, if any
                      CoreExpr -> CoreExpr)     -- Wrapper for the result
-- resultWrapper deals with the result *value*
-- E.g. foreign import foo :: Int -> IO T
-- Then resultWrapper deals with marshalling the 'T' part
-- So if    resultWrapper ty = (Just ty_rep, marshal)
--  then      marshal (e :: ty_rep) :: ty
-- That is, 'marshal' wrape the result returned by the foreign call,
-- of type ty_rep, into the value Haskell expected, of type 'ty'
--
-- Invariant: ty_rep is always a primitive type
--            i.e. (isPrimitiveType ty_rep) is True

resultWrapper :: Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
resultWrapper result_ty :: Type
result_ty
  -- Base case 1: primitive types
  | Type -> Bool
isPrimitiveType Type
result_ty
  = (Maybe Type, CoreExpr -> CoreExpr)
-> DsM (Maybe Type, CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Maybe Type
forall a. a -> Maybe a
Just Type
result_ty, \e :: CoreExpr
e -> CoreExpr
e)

  -- Base case 2: the unit type ()
  | Just (tc :: TyCon
tc,_) <- Maybe (TyCon, [Type])
maybe_tc_app
  , TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
unitTyConKey
  = (Maybe Type, CoreExpr -> CoreExpr)
-> DsM (Maybe Type, CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Type
forall a. Maybe a
Nothing, \_ -> Var -> CoreExpr
forall b. Var -> Expr b
Var Var
unitDataConId)

  -- Base case 3: the boolean type
  | Just (tc :: TyCon
tc,_) <- Maybe (TyCon, [Type])
maybe_tc_app
  , TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
boolTyConKey
  = do { DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; let marshal_bool :: CoreExpr -> CoreExpr
marshal_bool e :: CoreExpr
e
               = CoreExpr -> Type -> Type -> [Alt Var] -> CoreExpr
mkWildCase CoreExpr
e Type
intPrimTy Type
boolTy
                   [ (AltCon
DEFAULT                   ,[],Var -> CoreExpr
forall b. Var -> Expr b
Var Var
trueDataConId )
                   , (Literal -> AltCon
LitAlt (DynFlags -> Integer -> Literal
mkLitInt DynFlags
dflags 0),[],Var -> CoreExpr
forall b. Var -> Expr b
Var Var
falseDataConId)]
       ; (Maybe Type, CoreExpr -> CoreExpr)
-> DsM (Maybe Type, CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Maybe Type
forall a. a -> Maybe a
Just Type
intPrimTy, CoreExpr -> CoreExpr
marshal_bool) }

  -- Newtypes
  | Just (co :: Coercion
co, rep_ty :: Type
rep_ty) <- Type -> Maybe (Coercion, Type)
topNormaliseNewType_maybe Type
result_ty
  = do { (maybe_ty :: Maybe Type
maybe_ty, wrapper :: CoreExpr -> CoreExpr
wrapper) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
resultWrapper Type
rep_ty
       ; (Maybe Type, CoreExpr -> CoreExpr)
-> DsM (Maybe Type, CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Type
maybe_ty, \e :: CoreExpr
e -> CoreExpr -> Coercion -> CoreExpr
mkCastDs (CoreExpr -> CoreExpr
wrapper CoreExpr
e) (Coercion -> Coercion
mkSymCo Coercion
co)) }

  -- The type might contain foralls (eg. for dummy type arguments,
  -- referring to 'Ptr a' is legal).
  | Just (tyvar :: Var
tyvar, rest :: Type
rest) <- Type -> Maybe (Var, Type)
splitForAllTy_maybe Type
result_ty
  = do { (maybe_ty :: Maybe Type
maybe_ty, wrapper :: CoreExpr -> CoreExpr
wrapper) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
resultWrapper Type
rest
       ; (Maybe Type, CoreExpr -> CoreExpr)
-> DsM (Maybe Type, CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Type
maybe_ty, \e :: CoreExpr
e -> Var -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Var
tyvar (CoreExpr -> CoreExpr
wrapper CoreExpr
e)) }

  -- Data types with a single constructor, which has a single arg
  -- This includes types like Ptr and ForeignPtr
  | Just (tycon :: TyCon
tycon, tycon_arg_tys :: [Type]
tycon_arg_tys) <- Maybe (TyCon, [Type])
maybe_tc_app
  , Just data_con :: DataCon
data_con <- TyCon -> Maybe DataCon
isDataProductTyCon_maybe TyCon
tycon  -- One constructor, no existentials
  , [unwrapped_res_ty :: Type
unwrapped_res_ty] <- DataCon -> [Type] -> [Type]
dataConInstOrigArgTys DataCon
data_con [Type]
tycon_arg_tys  -- One argument
  = do { DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; (maybe_ty :: Maybe Type
maybe_ty, wrapper :: CoreExpr -> CoreExpr
wrapper) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
resultWrapper Type
unwrapped_res_ty
       ; let narrow_wrapper :: CoreExpr -> CoreExpr
narrow_wrapper = DynFlags -> TyCon -> CoreExpr -> CoreExpr
maybeNarrow DynFlags
dflags TyCon
tycon
             marshal_con :: CoreExpr -> CoreExpr
marshal_con e :: CoreExpr
e  = Var -> CoreExpr
forall b. Var -> Expr b
Var (DataCon -> Var
dataConWrapId DataCon
data_con)
                              CoreExpr -> [Type] -> CoreExpr
forall b. Expr b -> [Type] -> Expr b
`mkTyApps` [Type]
tycon_arg_tys
                              CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr -> CoreExpr
wrapper (CoreExpr -> CoreExpr
narrow_wrapper CoreExpr
e)
       ; (Maybe Type, CoreExpr -> CoreExpr)
-> DsM (Maybe Type, CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Type
maybe_ty, CoreExpr -> CoreExpr
marshal_con) }

  | Bool
otherwise
  = String -> SDoc -> DsM (Maybe Type, CoreExpr -> CoreExpr)
forall a. HasCallStack => String -> SDoc -> a
pprPanic "resultWrapper" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
result_ty)
  where
    maybe_tc_app :: Maybe (TyCon, [Type])
maybe_tc_app = HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
result_ty

-- 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.

maybeNarrow :: DynFlags -> TyCon -> (CoreExpr -> CoreExpr)
maybeNarrow :: DynFlags -> TyCon -> CoreExpr -> CoreExpr
maybeNarrow dflags :: DynFlags
dflags tycon :: TyCon
tycon
  | TyCon
tycon TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
int8TyConKey   = \e :: CoreExpr
e -> CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Var -> CoreExpr
forall b. Var -> Expr b
Var (PrimOp -> Var
mkPrimOpId PrimOp
Narrow8IntOp)) CoreExpr
e
  | TyCon
tycon TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
int16TyConKey  = \e :: CoreExpr
e -> CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Var -> CoreExpr
forall b. Var -> Expr b
Var (PrimOp -> Var
mkPrimOpId PrimOp
Narrow16IntOp)) CoreExpr
e
  | TyCon
tycon TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
int32TyConKey
         Bool -> Bool -> Bool
&& DynFlags -> Int
wORD_SIZE DynFlags
dflags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 4         = \e :: CoreExpr
e -> CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Var -> CoreExpr
forall b. Var -> Expr b
Var (PrimOp -> Var
mkPrimOpId PrimOp
Narrow32IntOp)) CoreExpr
e

  | TyCon
tycon TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
word8TyConKey  = \e :: CoreExpr
e -> CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Var -> CoreExpr
forall b. Var -> Expr b
Var (PrimOp -> Var
mkPrimOpId PrimOp
Narrow8WordOp)) CoreExpr
e
  | TyCon
tycon TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
word16TyConKey = \e :: CoreExpr
e -> CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Var -> CoreExpr
forall b. Var -> Expr b
Var (PrimOp -> Var
mkPrimOpId PrimOp
Narrow16WordOp)) CoreExpr
e
  | TyCon
tycon TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
word32TyConKey
         Bool -> Bool -> Bool
&& DynFlags -> Int
wORD_SIZE DynFlags
dflags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 4         = \e :: CoreExpr
e -> CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Var -> CoreExpr
forall b. Var -> Expr b
Var (PrimOp -> Var
mkPrimOpId PrimOp
Narrow32WordOp)) CoreExpr
e
  | Bool
otherwise                     = CoreExpr -> CoreExpr
forall a. a -> a
id