    {-
    (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
    Many 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
    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 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
    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 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
    <+> 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
                    = [Type] -> [CoreExpr] -> CoreExpr
    mkCoreUbxTup
                        [Type
    realWorldStatePrimTy, Type
    io_res_ty]
                        [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
    Many 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 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 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
    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      = 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
    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      = 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