    {-
    (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