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


Desugaring foreign calls
-}



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

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

import GHC.Prelude

import GHC.Core

import GHC.HsToCore.Monad
import GHC.Core.Utils
import GHC.Core.Make
import GHC.Types.SourceText
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.Core.Coercion
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.Panic
import GHC.Utils.Panic.Plain

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 representation-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
       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 = Unique -> ForeignCall -> [CoreExpr] -> Type -> CoreExpr
mkFCall Unique
uniq ForeignCall
the_fcall [CoreExpr]
unboxed_args Type
ccall_result_ty
       CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (((CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr)
-> CoreExpr -> [CoreExpr -> CoreExpr] -> CoreExpr
forall a b. (a -> b -> b) -> b -> [a] -> b
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 :: 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 :: Unique -> ForeignCall -> [CoreExpr] -> Type -> CoreExpr
mkFCall Unique
uniq ForeignCall
the_fcall [CoreExpr]
val_args Type
res_ty
  = Bool -> CoreExpr -> CoreExpr
forall a. HasCallStack => Bool -> a -> a
assert ((Var -> Bool) -> [Var] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Var -> Bool
isTyVar [Var]
tyvars) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ -- 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 (() :: Constraint) => CoreExpr -> Type
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 = Unique -> ForeignCall -> Type -> Var
mkFCallId Unique
uniq ForeignCall
the_fcall Type
ty

unboxArg :: CoreExpr                    -- The supplied argument, not representation-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-representation-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 a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
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
ManyTy Type
intPrimTy
       (CoreExpr, CoreExpr -> CoreExpr)
-> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
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
                             ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
body)
                             [AltCon -> [Var] -> CoreExpr -> Alt Var
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt 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
&& Arity
data_con_arity Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
1
  = Bool
-> SDoc
-> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
-> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ((() :: Constraint) => Type -> Bool
Type -> Bool
isUnliftedType Type
data_con_arg_ty1) (Type -> SDoc
pprType Type
arg_ty) (IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
 -> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr))
-> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
-> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
forall a b. (a -> b) -> a -> b
$
                        -- Typechecker ensures this
    do Var
case_bndr <- Type -> Type -> DsM Var
newSysLocalDs Type
ManyTy Type
arg_ty
       Var
prim_arg <- Type -> Type -> DsM Var
newSysLocalDs Type
ManyTy Type
data_con_arg_ty1
       (CoreExpr, CoreExpr -> CoreExpr)
-> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
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 ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
body) [AltCon -> [Var] -> CoreExpr -> Alt Var
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (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
&&
    Arity
data_con_arity Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
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
ManyTy 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 a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
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 ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
body) [AltCon -> [Var] -> CoreExpr -> Alt Var
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (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
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
arg_ty)
  where
    arg_ty :: Type
arg_ty                                      = (() :: Constraint) => CoreExpr -> Type
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 :: Arity
data_con_arity                              = DataCon -> Arity
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 return_result :: CoreExpr -> CoreExpr -> CoreExpr
return_result CoreExpr
state CoreExpr
anss = [CoreExpr] -> CoreExpr
mkCoreUnboxedTuple [CoreExpr
state, 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
ManyTy Type
realWorldStatePrimTy
        ; let io_data_con :: DataCon
io_data_con = [DataCon] -> DataCon
forall a. HasCallStack => [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 a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
realWorldStatePrimTy (() :: Constraint) => Type -> Type -> Type
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} {p}. p -> p -> p
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 a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
realWorldStatePrimTy (() :: Constraint) => Type -> Type -> Type
Type -> Type -> Type
`mkVisFunTyMany` Type
ccall_res_ty, CoreExpr -> CoreExpr
wrap)
  where
    return_result :: p -> p -> p
return_result p
_ p
ans = p
ans


mk_alt :: (Expr Var -> Expr Var -> Expr Var)
       -> (Maybe Type, Expr Var -> Expr Var)
       -> DsM (Type, CoreAlt)
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
ManyTy 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. HasCallStack => 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      = AltCon -> [Var] -> CoreExpr -> Alt Var
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt (Boxity -> Arity -> DataCon
tupleDataCon Boxity
Unboxed Arity
1)) [Var
state_id] CoreExpr
the_rhs

       (Type, Alt Var) -> DsM (Type, Alt Var)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
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
    Bool -> SDoc -> DsM (Type, Alt Var) -> DsM (Type, Alt Var)
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Type -> Bool
isPrimitiveType Type
prim_res_ty) (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
prim_res_ty) (DsM (Type, Alt Var) -> DsM (Type, Alt Var))
-> DsM (Type, Alt Var) -> DsM (Type, Alt Var)
forall a b. (a -> b) -> a -> b
$
             -- True because resultWrapper ensures it is so
    do { Var
result_id <- Type -> Type -> DsM Var
newSysLocalDs Type
ManyTy Type
prim_res_ty
       ; Var
state_id <- Type -> Type -> DsM Var
newSysLocalDs Type
ManyTy 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      = AltCon -> [Var] -> CoreExpr -> Alt Var
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt (Boxity -> Arity -> DataCon
tupleDataCon Boxity
Unboxed Arity
2)) [Var
state_id, Var
result_id] CoreExpr
the_rhs
       ; (Type, Alt Var) -> DsM (Type, Alt Var)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
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 a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
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 a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
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 -> [Var] -> CoreExpr -> Alt Var
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT                        [] (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
trueDataConId )
                   , AltCon -> [Var] -> CoreExpr -> Alt Var
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (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 a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
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 a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
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)
splitForAllTyCoVar_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 a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
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
tyConSingleAlgDataCon_maybe TyCon
tycon  -- One constructor
  , [Var] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DataCon -> [Var]
dataConExTyCoVars DataCon
data_con)                   -- no existentials
  , [Scaled Type
_ Type
unwrapped_res_ty] <- DataCon -> [Type] -> [Scaled Type]
dataConInstOrigArgTys DataCon
data_con [Type]
tycon_arg_tys  -- One argument
  = do { (Maybe Type
maybe_ty, CoreExpr -> CoreExpr
wrapper) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
resultWrapper Type
unwrapped_res_ty
       ; let 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
e
       ; (Maybe Type, CoreExpr -> CoreExpr)
-> DsM (Maybe Type, CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
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 = (() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
result_ty