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


Desugaring foreign calls
-}

{-# LANGUAGE CPP #-}

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

module GHC.HsToCore.Foreign.Call
   ( dsCCall
   , mkFCall
   , unboxArg
   , boxResult
   , resultWrapper
   )
where

#include "HsVersions.h"


import GHC.Prelude
import GHC.Platform

import GHC.Core

import GHC.HsToCore.Monad
import GHC.Core.Utils
import GHC.Core.Make
import GHC.Types.Id.Make
import GHC.Types.ForeignCall
import GHC.Core.DataCon
import GHC.HsToCore.Utils

import GHC.Tc.Utils.TcType
import GHC.Core.Type
import GHC.Core.Multiplicity
import GHC.Types.Id   ( Id )
import GHC.Core.Coercion
import GHC.Builtin.PrimOps
import GHC.Builtin.Types.Prim
import GHC.Core.TyCon
import GHC.Builtin.Types
import GHC.Types.Basic
import GHC.Types.Literal
import GHC.Builtin.Names
import GHC.Driver.Session
import GHC.Utils.Outputable
import GHC.Utils.Misc

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 { State# 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 CLabelString
lbl [CoreExpr]
args Safety
may_gc Type
result_ty
  = do ([CoreExpr]
unboxed_args, [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
       (Type
ccall_result_ty, 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 Unit -> Bool -> CCallTarget
StaticTarget SourceText
NoSourceText CLabelString
lbl Maybe Unit
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 DynFlags
dflags Unique
uniq ForeignCall
the_fcall [CoreExpr]
val_args 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
mkVisFunTysMany [Type]
arg_tys Type
res_ty)
    tyvars :: [Var]
tyvars  = Type -> [Var]
tyCoVarsOfTypeWellScoped Type
body_ty
    ty :: Type
ty      = [Var] -> Type -> Type
mkInfForAllTys [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 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, \CoreExpr
body -> CoreExpr
body)

  -- Recursive newtypes
  | Just(Coercion
co, 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 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
       let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
       Var
prim_arg <- Type -> Type -> DsM Var
newSysLocalDs Type
Many 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,
              \ CoreExpr
body -> CoreExpr -> Var -> Type -> [Alt Var] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
mkIfThenElse CoreExpr
arg (Platform -> Integer -> CoreExpr
forall b. Platform -> Integer -> Expr b
mkIntLit Platform
platform Integer
1) (Platform -> Integer -> CoreExpr
forall b. Platform -> Integer -> Expr b
mkIntLit Platform
platform Integer
0))
                             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
== Int
1
  = ASSERT2(isUnliftedType data_con_arg_ty1, pprType arg_ty)
                        -- Typechecker ensures this
    do Var
case_bndr <- Type -> Type -> DsM Var
newSysLocalDs Type
Many Type
arg_ty
       Var
prim_arg <- Type -> Type -> DsM Var
newSysLocalDs Type
Many 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,
               \ 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
== Int
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 -> Type -> DsM Var
newSysLocalDs Type
Many Type
arg_ty
       vars :: [Var]
vars@[Var
_l_var, Var
_r_var, Var
arr_cts_var] <- [Scaled Type] -> DsM [Var]
newSysLocalsDs ((Type -> Scaled Type) -> [Type] -> [Scaled Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Scaled Type
forall a. a -> Scaled a
unrestricted [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,
               \ 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 String
"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, [Scaled Type])
maybe_product_type                          = Type -> Maybe (TyCon, [Type], DataCon, [Scaled Type])
splitDataProductType_maybe Type
arg_ty
    is_product_type :: Bool
is_product_type                             = Maybe (TyCon, [Type], DataCon, [Scaled Type]) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (TyCon, [Type], DataCon, [Scaled Type])
maybe_product_type
    Just (TyCon
_, [Type]
_, DataCon
data_con, [Scaled Type]
scaled_data_con_arg_tys) = Maybe (TyCon, [Type], DataCon, [Scaled Type])
maybe_product_type
    data_con_arg_tys :: [Type]
data_con_arg_tys                            = (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing [Scaled Type]
scaled_data_con_arg_tys
    data_con_arity :: Int
data_con_arity                              = DataCon -> Int
dataConSourceArity DataCon
data_con
    (Type
data_con_arg_ty1 : [Type]
_)                      = [Type]
data_con_arg_tys

    (Type
_ : Type
_ : Type
data_con_arg_ty3 : [Type]
_) = [Type]
data_con_arg_tys
    maybe_arg3_tycon :: Maybe TyCon
maybe_arg3_tycon               = Type -> Maybe TyCon
tyConAppTyCon_maybe Type
data_con_arg_ty3
    Just 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 Type
result_ty
  | Just (TyCon
io_tycon, 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 Type
ty,CoreExpr -> CoreExpr
_)
                       | Type -> Bool
isUnboxedTupleType Type
ty
                       -> let Just [Type]
ls = Type -> Maybe [Type]
tyConAppArgs_maybe Type
ty in [Type] -> [Type]
forall a. [a] -> [a]
tail [Type]
ls
                     (Maybe Type, CoreExpr -> CoreExpr)
_ -> []

              return_result :: CoreExpr -> [CoreExpr] -> CoreExpr
return_result CoreExpr
state [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)

        ; (Type
ccall_res_ty, 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 -> Type -> DsM Var
newSysLocalDs Type
Many 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 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 -> Scaled 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 -> Scaled Type
forall a. a -> Scaled a
unrestricted 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
`mkVisFunTyMany` Type
ccall_res_ty, CoreExpr -> CoreExpr
wrap) }

boxResult 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
       (Type
ccall_res_ty, Alt Var
the_alt) <- (CoreExpr -> [CoreExpr] -> CoreExpr)
-> (Maybe Type, CoreExpr -> CoreExpr) -> DsM (Type, Alt Var)
mk_alt CoreExpr -> [CoreExpr] -> CoreExpr
forall {p} {a}. p -> [a] -> a
return_result (Maybe Type, CoreExpr -> CoreExpr)
res
       let
           wrap :: CoreExpr -> CoreExpr
wrap = \ CoreExpr
the_call -> CoreExpr -> Scaled 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 -> Scaled Type
forall a. a -> Scaled a
unrestricted 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
`mkVisFunTyMany` Type
ccall_res_ty, CoreExpr -> CoreExpr
wrap)
  where
    return_result :: p -> [a] -> a
return_result p
_ [a
ans] = a
ans
    return_result p
_ [a]
_     = String -> a
forall a. String -> a
panic String
"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 CoreExpr -> [CoreExpr] -> CoreExpr
return_result (Maybe Type
Nothing, CoreExpr -> CoreExpr
wrap_result)
  = do -- The ccall returns ()
       Var
state_id <- Type -> Type -> DsM Var
newSysLocalDs Type
Many 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 String
"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 Int
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 CoreExpr -> [CoreExpr] -> CoreExpr
return_result (Just Type
prim_res_ty, 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 -> Type -> DsM Var
newSysLocalDs Type
Many Type
prim_res_ty
       ; Var
state_id <- Type -> Type -> DsM Var
newSysLocalDs Type
Many 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 Int
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 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, \CoreExpr
e -> CoreExpr
e)

  -- Base case 2: the unit type ()
  | Just (TyCon
tc,[Type]
_) <- 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, \CoreExpr
_ -> CoreExpr
unitExpr)

  -- Base case 3: the boolean type
  | Just (TyCon
tc,[Type]
_) <- 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 platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
       ; let marshal_bool :: CoreExpr -> CoreExpr
marshal_bool CoreExpr
e
               = CoreExpr -> Scaled Type -> Type -> [Alt Var] -> CoreExpr
mkWildCase CoreExpr
e (Type -> Scaled Type
forall a. a -> Scaled a
unrestricted Type
intPrimTy) Type
boolTy
                   [ (AltCon
DEFAULT                     ,[],Var -> CoreExpr
forall b. Var -> Expr b
Var Var
trueDataConId )
                   , (Literal -> AltCon
LitAlt (Platform -> Integer -> Literal
mkLitInt Platform
platform Integer
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 (Coercion
co, Type
rep_ty) <- Type -> Maybe (Coercion, Type)
topNormaliseNewType_maybe Type
result_ty
  = do { (Maybe Type
maybe_ty, 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, \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 (Var
tyvar, Type
rest) <- Type -> Maybe (Var, Type)
splitForAllTy_maybe Type
result_ty
  = do { (Maybe Type
maybe_ty, 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, \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, [Type]
tycon_arg_tys) <- Maybe (TyCon, [Type])
maybe_tc_app
  , Just DataCon
data_con <- TyCon -> Maybe DataCon
isDataProductTyCon_maybe TyCon
tycon  -- One constructor, no existentials
  , [Scaled Type
_ Type
unwrapped_res_ty] <- DataCon -> [Type] -> [Scaled 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
       ; let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
       ; (Maybe Type
maybe_ty, CoreExpr -> CoreExpr
wrapper) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
resultWrapper Type
unwrapped_res_ty
       ; let narrow_wrapper :: CoreExpr -> CoreExpr
narrow_wrapper = Platform -> TyCon -> CoreExpr -> CoreExpr
maybeNarrow Platform
platform TyCon
tycon
             marshal_con :: CoreExpr -> CoreExpr
marshal_con 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 String
"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 :: Platform -> TyCon -> (CoreExpr -> CoreExpr)
maybeNarrow :: Platform -> TyCon -> CoreExpr -> CoreExpr
maybeNarrow Platform
platform TyCon
tycon
  | TyCon
tycon TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
int8TyConKey   = \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  = \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
  , Platform -> Int
platformWordSizeInBytes Platform
platform Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
4
  = \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  = \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 = \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
  , Platform -> Int
platformWordSizeInBytes Platform
platform Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
4
  = \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