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


Desugaring foreign declarations (see also DsCCall).
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

module DsForeign ( dsForeigns ) where

#include "HsVersions.h"
import GhcPrelude

import TcRnMonad        -- temp

import CoreSyn

import DsCCall
import DsMonad

import GHC.Hs
import DataCon
import CoreUnfold
import Id
import Literal
import Module
import Name
import Type
import RepType
import TyCon
import Coercion
import TcEnv
import TcType

import CmmExpr
import CmmUtils
import HscTypes
import ForeignCall
import TysWiredIn
import TysPrim
import PrelNames
import BasicTypes
import SrcLoc
import Outputable
import FastString
import DynFlags
import GHC.Platform
import OrdList
import Pair
import Util
import Hooks
import Encoding

import Data.Maybe
import Data.List

{-
Desugaring of @foreign@ declarations is naturally split up into
parts, an @import@ and an @export@  part. A @foreign import@
declaration
\begin{verbatim}
  foreign import cc nm f :: prim_args -> IO prim_res
\end{verbatim}
is the same as
\begin{verbatim}
  f :: prim_args -> IO prim_res
  f a1 ... an = _ccall_ nm cc a1 ... an
\end{verbatim}
so we reuse the desugaring code in @DsCCall@ to deal with these.
-}

type Binding = (Id, CoreExpr) -- No rec/nonrec structure;
                              -- the occurrence analyser will sort it all out

dsForeigns :: [LForeignDecl GhcTc]
           -> DsM (ForeignStubs, OrdList Binding)
dsForeigns :: [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding)
dsForeigns [LForeignDecl GhcTc]
fos = (Hooks
 -> Maybe
      ([LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding)))
-> ([LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding))
-> IOEnv
     (Env DsGblEnv DsLclEnv)
     ([LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding))
forall (f :: * -> *) a.
(Functor f, HasDynFlags f) =>
(Hooks -> Maybe a) -> a -> f a
getHooked Hooks
-> Maybe
     ([LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding))
dsForeignsHook [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding)
dsForeigns' IOEnv
  (Env DsGblEnv DsLclEnv)
  ([LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding))
-> (([LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding))
    -> DsM (ForeignStubs, OrdList Binding))
-> DsM (ForeignStubs, OrdList Binding)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (([LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding))
-> [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding)
forall a b. (a -> b) -> a -> b
$ [LForeignDecl GhcTc]
fos)

dsForeigns' :: [LForeignDecl GhcTc]
            -> DsM (ForeignStubs, OrdList Binding)
dsForeigns' :: [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding)
dsForeigns' []
  = (ForeignStubs, OrdList Binding)
-> DsM (ForeignStubs, OrdList Binding)
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignStubs
NoStubs, OrdList Binding
forall a. OrdList a
nilOL)
dsForeigns' [LForeignDecl GhcTc]
fos = do
    [(SDoc, SDoc, [Var], [Binding])]
fives <- (LForeignDecl GhcTc
 -> IOEnv (Env DsGblEnv DsLclEnv) (SDoc, SDoc, [Var], [Binding]))
-> [LForeignDecl GhcTc]
-> IOEnv (Env DsGblEnv DsLclEnv) [(SDoc, SDoc, [Var], [Binding])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LForeignDecl GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) (SDoc, SDoc, [Var], [Binding])
forall a pass.
(HasSrcSpan a, Outputable (IdP pass),
 XXForeignDecl pass ~ NoExtCon, IdP pass ~ Var,
 XForeignImport pass ~ Coercion, XForeignExport pass ~ Coercion,
 SrcSpanLess a ~ ForeignDecl pass) =>
a -> IOEnv (Env DsGblEnv DsLclEnv) (SDoc, SDoc, [Var], [Binding])
do_ldecl [LForeignDecl GhcTc]
fos
    let
        ([SDoc]
hs, [SDoc]
cs, [[Var]]
idss, [[Binding]]
bindss) = [(SDoc, SDoc, [Var], [Binding])]
-> ([SDoc], [SDoc], [[Var]], [[Binding]])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 [(SDoc, SDoc, [Var], [Binding])]
fives
        fe_ids :: [Var]
fe_ids = [[Var]] -> [Var]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Var]]
idss
        fe_init_code :: [SDoc]
fe_init_code = (Var -> SDoc) -> [Var] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Var -> SDoc
foreignExportInitialiser [Var]
fe_ids
    --
    (ForeignStubs, OrdList Binding)
-> DsM (ForeignStubs, OrdList Binding)
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> SDoc -> ForeignStubs
ForeignStubs
             ([SDoc] -> SDoc
vcat [SDoc]
hs)
             ([SDoc] -> SDoc
vcat [SDoc]
cs SDoc -> SDoc -> SDoc
$$ [SDoc] -> SDoc
vcat [SDoc]
fe_init_code),
            ([Binding] -> OrdList Binding -> OrdList Binding)
-> OrdList Binding -> [[Binding]] -> OrdList Binding
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (OrdList Binding -> OrdList Binding -> OrdList Binding
forall a. OrdList a -> OrdList a -> OrdList a
appOL (OrdList Binding -> OrdList Binding -> OrdList Binding)
-> ([Binding] -> OrdList Binding)
-> [Binding]
-> OrdList Binding
-> OrdList Binding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Binding] -> OrdList Binding
forall a. [a] -> OrdList a
toOL) OrdList Binding
forall a. OrdList a
nilOL [[Binding]]
bindss)
  where
   do_ldecl :: a -> IOEnv (Env DsGblEnv DsLclEnv) (SDoc, SDoc, [Var], [Binding])
do_ldecl (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess a
decl) = SrcSpan
-> IOEnv (Env DsGblEnv DsLclEnv) (SDoc, SDoc, [Var], [Binding])
-> IOEnv (Env DsGblEnv DsLclEnv) (SDoc, SDoc, [Var], [Binding])
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
loc (ForeignDecl pass
-> IOEnv (Env DsGblEnv DsLclEnv) (SDoc, SDoc, [Var], [Binding])
forall pass.
(Outputable (IdP pass), XForeignImport pass ~ Coercion,
 IdP pass ~ Var, XForeignExport pass ~ Coercion,
 XXForeignDecl pass ~ NoExtCon) =>
ForeignDecl pass
-> IOEnv (Env DsGblEnv DsLclEnv) (SDoc, SDoc, [Var], [Binding])
do_decl SrcSpanLess a
ForeignDecl pass
decl)

   do_decl :: ForeignDecl pass
-> IOEnv (Env DsGblEnv DsLclEnv) (SDoc, SDoc, [Var], [Binding])
do_decl (ForeignImport { fd_name :: forall pass. ForeignDecl pass -> Located (IdP pass)
fd_name = Located (IdP pass)
id, fd_i_ext :: forall pass. ForeignDecl pass -> XForeignImport pass
fd_i_ext = XForeignImport pass
co, fd_fi :: forall pass. ForeignDecl pass -> ForeignImport
fd_fi = ForeignImport
spec }) = do
      SDoc -> TcRnIf DsGblEnv DsLclEnv ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (String -> SDoc
text String
"fi start" SDoc -> SDoc -> SDoc
<+> Located (IdP pass) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located (IdP pass)
id)
      let id' :: SrcSpanLess (Located (IdP pass))
id' = Located (IdP pass) -> SrcSpanLess (Located (IdP pass))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (IdP pass)
id
      ([Binding]
bs, SDoc
h, SDoc
c) <- Var -> Coercion -> ForeignImport -> DsM ([Binding], SDoc, SDoc)
dsFImport SrcSpanLess (Located (IdP pass))
Var
id' Coercion
XForeignImport pass
co ForeignImport
spec
      SDoc -> TcRnIf DsGblEnv DsLclEnv ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (String -> SDoc
text String
"fi end" SDoc -> SDoc -> SDoc
<+> Located (IdP pass) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located (IdP pass)
id)
      (SDoc, SDoc, [Var], [Binding])
-> IOEnv (Env DsGblEnv DsLclEnv) (SDoc, SDoc, [Var], [Binding])
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc
h, SDoc
c, [], [Binding]
bs)

   do_decl (ForeignExport { fd_name :: forall pass. ForeignDecl pass -> Located (IdP pass)
fd_name = (Located (IdP pass) -> Located (SrcSpanLess (Located (IdP pass)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located (IdP pass))
id)
                          , fd_e_ext :: forall pass. ForeignDecl pass -> XForeignExport pass
fd_e_ext = XForeignExport pass
co
                          , fd_fe :: forall pass. ForeignDecl pass -> ForeignExport
fd_fe = CExport
                              (Located CExportSpec -> Located (SrcSpanLess (Located CExportSpec))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (CExportStatic _ ext_nm cconv)) Located SourceText
_ }) = do
      (SDoc
h, SDoc
c, String
_, Int
_) <- Var
-> Coercion
-> CLabelString
-> CCallConv
-> Bool
-> DsM (SDoc, SDoc, String, Int)
dsFExport SrcSpanLess (Located (IdP pass))
Var
id Coercion
XForeignExport pass
co CLabelString
ext_nm CCallConv
cconv Bool
False
      (SDoc, SDoc, [Var], [Binding])
-> IOEnv (Env DsGblEnv DsLclEnv) (SDoc, SDoc, [Var], [Binding])
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc
h, SDoc
c, [SrcSpanLess (Located (IdP pass))
Var
id], [])
   do_decl (XForeignDecl XXForeignDecl pass
nec) = NoExtCon
-> IOEnv (Env DsGblEnv DsLclEnv) (SDoc, SDoc, [Var], [Binding])
forall a. NoExtCon -> a
noExtCon XXForeignDecl pass
NoExtCon
nec

{-
************************************************************************
*                                                                      *
\subsection{Foreign import}
*                                                                      *
************************************************************************

Desugaring foreign imports is just the matter of creating a binding
that on its RHS unboxes its arguments, performs the external call
(using the @CCallOp@ primop), before boxing the result up and returning it.

However, we create a worker/wrapper pair, thus:

        foreign import f :: Int -> IO Int
==>
        f x = IO ( \s -> case x of { I# x# ->
                         case fw s x# of { (# s1, y# #) ->
                         (# s1, I# y# #)}})

        fw s x# = ccall f s x#

The strictness/CPR analyser won't do this automatically because it doesn't look
inside returned tuples; but inlining this wrapper is a Really Good Idea
because it exposes the boxing to the call site.
-}

dsFImport :: Id
          -> Coercion
          -> ForeignImport
          -> DsM ([Binding], SDoc, SDoc)
dsFImport :: Var -> Coercion -> ForeignImport -> DsM ([Binding], SDoc, SDoc)
dsFImport Var
id Coercion
co (CImport Located CCallConv
cconv Located Safety
safety Maybe Header
mHeader CImportSpec
spec Located SourceText
_) =
    Var
-> Coercion
-> CImportSpec
-> CCallConv
-> Safety
-> Maybe Header
-> DsM ([Binding], SDoc, SDoc)
dsCImport Var
id Coercion
co CImportSpec
spec (Located CCallConv -> SrcSpanLess (Located CCallConv)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located CCallConv
cconv) (Located Safety -> SrcSpanLess (Located Safety)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located Safety
safety) Maybe Header
mHeader

dsCImport :: Id
          -> Coercion
          -> CImportSpec
          -> CCallConv
          -> Safety
          -> Maybe Header
          -> DsM ([Binding], SDoc, SDoc)
dsCImport :: Var
-> Coercion
-> CImportSpec
-> CCallConv
-> Safety
-> Maybe Header
-> DsM ([Binding], SDoc, SDoc)
dsCImport Var
id Coercion
co (CLabel CLabelString
cid) CCallConv
cconv Safety
_ Maybe Header
_ = do
   DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
   let ty :: Type
ty  = Pair Type -> Type
forall a. Pair a -> a
pFst (Pair Type -> Type) -> Pair Type -> Type
forall a b. (a -> b) -> a -> b
$ Coercion -> Pair Type
coercionKind Coercion
co
       fod :: FunctionOrData
fod = case Type -> Maybe TyCon
tyConAppTyCon_maybe (Type -> Type
dropForAlls Type
ty) of
             Just TyCon
tycon
              | TyCon -> Unique
tyConUnique TyCon
tycon Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
funPtrTyConKey ->
                 FunctionOrData
IsFunction
             Maybe TyCon
_ -> FunctionOrData
IsData
   (Maybe Type
resTy, CoreExpr -> CoreExpr
foRhs) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
resultWrapper Type
ty
   ASSERT(fromJust resTy `eqType` addrPrimTy)    -- typechecker ensures this
    let
        rhs :: CoreExpr
rhs = CoreExpr -> CoreExpr
foRhs (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (CLabelString -> Maybe Int -> FunctionOrData -> Literal
LitLabel CLabelString
cid Maybe Int
stdcall_info FunctionOrData
fod))
        rhs' :: CoreExpr
rhs' = CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
rhs Coercion
co
        stdcall_info :: Maybe Int
stdcall_info = DynFlags -> CCallConv -> Type -> Maybe Int
fun_type_arg_stdcall_info DynFlags
dflags CCallConv
cconv Type
ty
    in
    ([Binding], SDoc, SDoc) -> DsM ([Binding], SDoc, SDoc)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Var
id, CoreExpr
rhs')], SDoc
empty, SDoc
empty)

dsCImport Var
id Coercion
co (CFunction CCallTarget
target) cconv :: CCallConv
cconv@CCallConv
PrimCallConv Safety
safety Maybe Header
_
  = Var -> Coercion -> ForeignCall -> DsM ([Binding], SDoc, SDoc)
dsPrimCall Var
id Coercion
co (CCallSpec -> ForeignCall
CCall (CCallTarget -> CCallConv -> Safety -> CCallSpec
CCallSpec CCallTarget
target CCallConv
cconv Safety
safety))
dsCImport Var
id Coercion
co (CFunction CCallTarget
target) CCallConv
cconv Safety
safety Maybe Header
mHeader
  = Var
-> Coercion
-> ForeignCall
-> Maybe Header
-> DsM ([Binding], SDoc, SDoc)
dsFCall Var
id Coercion
co (CCallSpec -> ForeignCall
CCall (CCallTarget -> CCallConv -> Safety -> CCallSpec
CCallSpec CCallTarget
target CCallConv
cconv Safety
safety)) Maybe Header
mHeader
dsCImport Var
id Coercion
co CImportSpec
CWrapper CCallConv
cconv Safety
_ Maybe Header
_
  = Var -> Coercion -> CCallConv -> DsM ([Binding], SDoc, SDoc)
dsFExportDynamic Var
id Coercion
co CCallConv
cconv

-- For stdcall labels, if the type was a FunPtr or newtype thereof,
-- then we need to calculate the size of the arguments in order to add
-- the @n suffix to the label.
fun_type_arg_stdcall_info :: DynFlags -> CCallConv -> Type -> Maybe Int
fun_type_arg_stdcall_info :: DynFlags -> CCallConv -> Type -> Maybe Int
fun_type_arg_stdcall_info DynFlags
dflags CCallConv
StdCallConv Type
ty
  | Just (TyCon
tc,[Type
arg_ty]) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty,
    TyCon -> Unique
tyConUnique TyCon
tc Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
funPtrTyConKey
  = let
       ([TyBinder]
bndrs, Type
_) = Type -> ([TyBinder], Type)
tcSplitPiTys Type
arg_ty
       fe_arg_tys :: [Type]
fe_arg_tys = (TyBinder -> Maybe Type) -> [TyBinder] -> [Type]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TyBinder -> Maybe Type
binderRelevantType_maybe [TyBinder]
bndrs
    in Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Type -> Int) -> [Type] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Width -> Int
widthInBytes (Width -> Int) -> (Type -> Width) -> Type -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmType -> Width
typeWidth (CmmType -> Width) -> (Type -> CmmType) -> Type -> Width
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> Type -> CmmType
typeCmmType DynFlags
dflags (Type -> CmmType) -> (Type -> Type) -> Type -> CmmType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
getPrimTyOf) [Type]
fe_arg_tys)
fun_type_arg_stdcall_info DynFlags
_ CCallConv
_other_conv Type
_
  = Maybe Int
forall a. Maybe a
Nothing

{-
************************************************************************
*                                                                      *
\subsection{Foreign calls}
*                                                                      *
************************************************************************
-}

dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header
        -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
dsFCall :: Var
-> Coercion
-> ForeignCall
-> Maybe Header
-> DsM ([Binding], SDoc, SDoc)
dsFCall Var
fn_id Coercion
co ForeignCall
fcall Maybe Header
mDeclHeader = do
    let
        ty :: Type
ty                   = Pair Type -> Type
forall a. Pair a -> a
pFst (Pair Type -> Type) -> Pair Type -> Type
forall a b. (a -> b) -> a -> b
$ Coercion -> Pair Type
coercionKind Coercion
co
        ([TyVarBinder]
tv_bndrs, Type
rho)      = Type -> ([TyVarBinder], Type)
tcSplitForAllVarBndrs Type
ty
        ([Type]
arg_tys, Type
io_res_ty) = Type -> ([Type], Type)
tcSplitFunTys Type
rho

    [Var]
args <- [Type] -> DsM [Var]
newSysLocalsDs [Type]
arg_tys  -- no FFI levity-polymorphism
    ([CoreExpr]
val_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 ((Var -> CoreExpr) -> [Var] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Var -> CoreExpr
forall b. Var -> Expr b
Var [Var]
args)

    let
        work_arg_ids :: [Var]
work_arg_ids  = [Var
v | Var Var
v <- [CoreExpr]
val_args] -- All guaranteed to be vars

    (Type
ccall_result_ty, CoreExpr -> CoreExpr
res_wrapper) <- Type -> DsM (Type, CoreExpr -> CoreExpr)
boxResult Type
io_res_ty

    Unique
ccall_uniq <- TcRnIf DsGblEnv DsLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
    Unique
work_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
    (ForeignCall
fcall', SDoc
cDoc) <-
              case ForeignCall
fcall of
              CCall (CCallSpec (StaticTarget SourceText
_ CLabelString
cName Maybe UnitId
mUnitId Bool
isFun)
                               CCallConv
CApiConv Safety
safety) ->
               do CLabelString
wrapperName <- String -> String -> IOEnv (Env DsGblEnv DsLclEnv) CLabelString
forall (m :: * -> *).
(MonadIO m, HasDynFlags m, HasModule m) =>
String -> String -> m CLabelString
mkWrapperName String
"ghc_wrapper" (CLabelString -> String
unpackFS CLabelString
cName)
                  let fcall' :: ForeignCall
fcall' = CCallSpec -> ForeignCall
CCall (CCallTarget -> CCallConv -> Safety -> CCallSpec
CCallSpec
                                      (SourceText -> CLabelString -> Maybe UnitId -> Bool -> CCallTarget
StaticTarget SourceText
NoSourceText
                                                    CLabelString
wrapperName Maybe UnitId
mUnitId
                                                    Bool
True)
                                      CCallConv
CApiConv Safety
safety)
                      c :: SDoc
c = SDoc
includes
                       SDoc -> SDoc -> SDoc
$$ SDoc
fun_proto SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
braces (SDoc
cRet SDoc -> SDoc -> SDoc
<> SDoc
semi)
                      includes :: SDoc
includes = [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"#include \"" SDoc -> SDoc -> SDoc
<> CLabelString -> SDoc
ftext CLabelString
h
                                        SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"\""
                                      | Header SourceText
_ CLabelString
h <- [Header] -> [Header]
forall a. Eq a => [a] -> [a]
nub [Header]
headers ]
                      fun_proto :: SDoc
fun_proto = SDoc
cResType SDoc -> SDoc -> SDoc
<+> SDoc
pprCconv SDoc -> SDoc -> SDoc
<+> CLabelString -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabelString
wrapperName SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens SDoc
argTypes
                      cRet :: SDoc
cRet
                       | Bool
isVoidRes =                   SDoc
cCall
                       | Bool
otherwise = String -> SDoc
text String
"return" SDoc -> SDoc -> SDoc
<+> SDoc
cCall
                      cCall :: SDoc
cCall = if Bool
isFun
                              then CLabelString -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabelString
cName SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens SDoc
argVals
                              else if [Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
arg_tys
                                    then CLabelString -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabelString
cName
                                    else String -> SDoc
forall a. String -> a
panic String
"dsFCall: Unexpected arguments to FFI value import"
                      raw_res_ty :: Type
raw_res_ty = case Type -> Maybe (TyCon, Type)
tcSplitIOType_maybe Type
io_res_ty of
                                   Just (TyCon
_ioTyCon, Type
res_ty) -> Type
res_ty
                                   Maybe (TyCon, Type)
Nothing                 -> Type
io_res_ty
                      isVoidRes :: Bool
isVoidRes = Type
raw_res_ty Type -> Type -> Bool
`eqType` Type
unitTy
                      (Maybe Header
mHeader, SDoc
cResType)
                       | Bool
isVoidRes = (Maybe Header
forall a. Maybe a
Nothing, String -> SDoc
text String
"void")
                       | Bool
otherwise = Type -> (Maybe Header, SDoc)
toCType Type
raw_res_ty
                      pprCconv :: SDoc
pprCconv = CCallConv -> SDoc
ccallConvAttribute CCallConv
CApiConv
                      mHeadersArgTypeList :: [(Maybe Header, SDoc)]
mHeadersArgTypeList
                          = [ (Maybe Header
header, SDoc
cType SDoc -> SDoc -> SDoc
<+> Char -> SDoc
char Char
'a' SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
n)
                            | (Type
t, Int
n) <- [Type] -> [Int] -> [(Type, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
arg_tys [Int
1..]
                            , let (Maybe Header
header, SDoc
cType) = Type -> (Maybe Header, SDoc)
toCType Type
t ]
                      ([Maybe Header]
mHeaders, [SDoc]
argTypeList) = [(Maybe Header, SDoc)] -> ([Maybe Header], [SDoc])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Maybe Header, SDoc)]
mHeadersArgTypeList
                      argTypes :: SDoc
argTypes = if [SDoc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SDoc]
argTypeList
                                 then String -> SDoc
text String
"void"
                                 else [SDoc] -> SDoc
hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma [SDoc]
argTypeList
                      mHeaders' :: [Maybe Header]
mHeaders' = Maybe Header
mDeclHeader Maybe Header -> [Maybe Header] -> [Maybe Header]
forall a. a -> [a] -> [a]
: Maybe Header
mHeader Maybe Header -> [Maybe Header] -> [Maybe Header]
forall a. a -> [a] -> [a]
: [Maybe Header]
mHeaders
                      headers :: [Header]
headers = [Maybe Header] -> [Header]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Header]
mHeaders'
                      argVals :: SDoc
argVals = [SDoc] -> SDoc
hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma
                                    [ Char -> SDoc
char Char
'a' SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
n
                                    | (Type
_, Int
n) <- [Type] -> [Int] -> [(Type, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
arg_tys [Int
1..] ]
                  (ForeignCall, SDoc)
-> IOEnv (Env DsGblEnv DsLclEnv) (ForeignCall, SDoc)
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignCall
fcall', SDoc
c)
              ForeignCall
_ ->
                  (ForeignCall, SDoc)
-> IOEnv (Env DsGblEnv DsLclEnv) (ForeignCall, SDoc)
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignCall
fcall, SDoc
empty)
    let
        -- Build the worker
        worker_ty :: Type
worker_ty     = [TyVarBinder] -> Type -> Type
mkForAllTys [TyVarBinder]
tv_bndrs ([Type] -> Type -> Type
mkVisFunTys ((Var -> Type) -> [Var] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Type
idType [Var]
work_arg_ids) Type
ccall_result_ty)
        tvs :: [Var]
tvs           = (TyVarBinder -> Var) -> [TyVarBinder] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBinder -> Var
forall tv argf. VarBndr tv argf -> tv
binderVar [TyVarBinder]
tv_bndrs
        the_ccall_app :: CoreExpr
the_ccall_app = DynFlags -> Unique -> ForeignCall -> [CoreExpr] -> Type -> CoreExpr
mkFCall DynFlags
dflags Unique
ccall_uniq ForeignCall
fcall' [CoreExpr]
val_args Type
ccall_result_ty
        work_rhs :: CoreExpr
work_rhs      = [Var] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Var]
tvs ([Var] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Var]
work_arg_ids CoreExpr
the_ccall_app)
        work_id :: Var
work_id       = CLabelString -> Unique -> Type -> Var
mkSysLocal (String -> CLabelString
fsLit String
"$wccall") Unique
work_uniq Type
worker_ty

        -- Build the wrapper
        work_app :: CoreExpr
work_app     = 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
work_id) [Var]
tvs) [CoreExpr]
val_args
        wrapper_body :: CoreExpr
wrapper_body = ((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
work_app) [CoreExpr -> CoreExpr]
arg_wrappers
        wrap_rhs :: CoreExpr
wrap_rhs     = [Var] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams ([Var]
tvs [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ [Var]
args) CoreExpr
wrapper_body
        wrap_rhs' :: CoreExpr
wrap_rhs'    = CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
wrap_rhs Coercion
co
        fn_id_w_inl :: Var
fn_id_w_inl  = Var
fn_id Var -> Unfolding -> Var
`setIdUnfolding` Int -> CoreExpr -> Unfolding
mkInlineUnfoldingWithArity
                                                ([Var] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Var]
args) CoreExpr
wrap_rhs'

    ([Binding], SDoc, SDoc) -> DsM ([Binding], SDoc, SDoc)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Var
work_id, CoreExpr
work_rhs), (Var
fn_id_w_inl, CoreExpr
wrap_rhs')], SDoc
empty, SDoc
cDoc)

{-
************************************************************************
*                                                                      *
\subsection{Primitive calls}
*                                                                      *
************************************************************************

This is for `@foreign import prim@' declarations.

Currently, at the core level we pretend that these primitive calls are
foreign calls. It may make more sense in future to have them as a distinct
kind of Id, or perhaps to bundle them with PrimOps since semantically and
for calling convention they are really prim ops.
-}

dsPrimCall :: Id -> Coercion -> ForeignCall
           -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
dsPrimCall :: Var -> Coercion -> ForeignCall -> DsM ([Binding], SDoc, SDoc)
dsPrimCall Var
fn_id Coercion
co ForeignCall
fcall = do
    let
        ty :: Type
ty                   = Pair Type -> Type
forall a. Pair a -> a
pFst (Pair Type -> Type) -> Pair Type -> Type
forall a b. (a -> b) -> a -> b
$ Coercion -> Pair Type
coercionKind Coercion
co
        ([Var]
tvs, Type
fun_ty)        = Type -> ([Var], Type)
tcSplitForAllTys Type
ty
        ([Type]
arg_tys, Type
io_res_ty) = Type -> ([Type], Type)
tcSplitFunTys Type
fun_ty

    [Var]
args <- [Type] -> DsM [Var]
newSysLocalsDs [Type]
arg_tys  -- no FFI levity-polymorphism

    Unique
ccall_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
        call_app :: CoreExpr
call_app = DynFlags -> Unique -> ForeignCall -> [CoreExpr] -> Type -> CoreExpr
mkFCall DynFlags
dflags Unique
ccall_uniq ForeignCall
fcall ((Var -> CoreExpr) -> [Var] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Var -> CoreExpr
forall b. Var -> Expr b
Var [Var]
args) Type
io_res_ty
        rhs :: CoreExpr
rhs      = [Var] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Var]
tvs ([Var] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Var]
args CoreExpr
call_app)
        rhs' :: CoreExpr
rhs'     = CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
rhs Coercion
co
    ([Binding], SDoc, SDoc) -> DsM ([Binding], SDoc, SDoc)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Var
fn_id, CoreExpr
rhs')], SDoc
empty, SDoc
empty)

{-
************************************************************************
*                                                                      *
\subsection{Foreign export}
*                                                                      *
************************************************************************

The function that does most of the work for `@foreign export@' declarations.
(see below for the boilerplate code a `@foreign export@' declaration expands
 into.)

For each `@foreign export foo@' in a module M we generate:
\begin{itemize}
\item a C function `@foo@', which calls
\item a Haskell stub `@M.\$ffoo@', which calls
\end{itemize}
the user-written Haskell function `@M.foo@'.
-}

dsFExport :: Id                 -- Either the exported Id,
                                -- or the foreign-export-dynamic constructor
          -> Coercion           -- Coercion between the Haskell type callable
                                -- from C, and its representation type
          -> CLabelString       -- The name to export to C land
          -> CCallConv
          -> Bool               -- True => foreign export dynamic
                                --         so invoke IO action that's hanging off
                                --         the first argument's stable pointer
          -> DsM ( SDoc         -- contents of Module_stub.h
                 , SDoc         -- contents of Module_stub.c
                 , String       -- string describing type to pass to createAdj.
                 , Int          -- size of args to stub function
                 )

dsFExport :: Var
-> Coercion
-> CLabelString
-> CCallConv
-> Bool
-> DsM (SDoc, SDoc, String, Int)
dsFExport Var
fn_id Coercion
co CLabelString
ext_name CCallConv
cconv Bool
isDyn = do
    let
       ty :: Type
ty                     = Pair Type -> Type
forall a. Pair a -> a
pSnd (Pair Type -> Type) -> Pair Type -> Type
forall a b. (a -> b) -> a -> b
$ Coercion -> Pair Type
coercionKind Coercion
co
       ([TyBinder]
bndrs, Type
orig_res_ty)   = Type -> ([TyBinder], Type)
tcSplitPiTys Type
ty
       fe_arg_tys' :: [Type]
fe_arg_tys'            = (TyBinder -> Maybe Type) -> [TyBinder] -> [Type]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TyBinder -> Maybe Type
binderRelevantType_maybe [TyBinder]
bndrs
       -- We must use tcSplits here, because we want to see
       -- the (IO t) in the corner of the type!
       fe_arg_tys :: [Type]
fe_arg_tys | Bool
isDyn     = [Type] -> [Type]
forall a. [a] -> [a]
tail [Type]
fe_arg_tys'
                  | Bool
otherwise = [Type]
fe_arg_tys'

       -- Look at the result type of the exported function, orig_res_ty
       -- If it's IO t, return         (t, True)
       -- If it's plain t, return      (t, False)
       (Type
res_ty, Bool
is_IO_res_ty) = case Type -> Maybe (TyCon, Type)
tcSplitIOType_maybe Type
orig_res_ty of
                                -- The function already returns IO t
                                Just (TyCon
_ioTyCon, Type
res_ty) -> (Type
res_ty, Bool
True)
                                -- The function returns t
                                Maybe (TyCon, Type)
Nothing                 -> (Type
orig_res_ty, Bool
False)

    DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    (SDoc, SDoc, String, Int) -> DsM (SDoc, SDoc, String, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return ((SDoc, SDoc, String, Int) -> DsM (SDoc, SDoc, String, Int))
-> (SDoc, SDoc, String, Int) -> DsM (SDoc, SDoc, String, Int)
forall a b. (a -> b) -> a -> b
$
      DynFlags
-> CLabelString
-> Maybe Var
-> [Type]
-> Type
-> Bool
-> CCallConv
-> (SDoc, SDoc, String, Int)
mkFExportCBits DynFlags
dflags CLabelString
ext_name
                     (if Bool
isDyn then Maybe Var
forall a. Maybe a
Nothing else Var -> Maybe Var
forall a. a -> Maybe a
Just Var
fn_id)
                     [Type]
fe_arg_tys Type
res_ty Bool
is_IO_res_ty CCallConv
cconv

{-
@foreign import "wrapper"@ (previously "foreign export dynamic") lets
you dress up Haskell IO actions of some fixed type behind an
externally callable interface (i.e., as a C function pointer). Useful
for callbacks and stuff.

\begin{verbatim}
type Fun = Bool -> Int -> IO Int
foreign import "wrapper" f :: Fun -> IO (FunPtr Fun)

-- Haskell-visible constructor, which is generated from the above:
-- SUP: No check for NULL from createAdjustor anymore???

f :: Fun -> IO (FunPtr Fun)
f cback =
   bindIO (newStablePtr cback)
          (\StablePtr sp# -> IO (\s1# ->
              case _ccall_ createAdjustor cconv sp# ``f_helper'' <arg info> s1# of
                 (# s2#, a# #) -> (# s2#, A# a# #)))

foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun)

-- and the helper in C: (approximately; see `mkFExportCBits` below)

f_helper(StablePtr s, HsBool b, HsInt i)
{
        Capability *cap;
        cap = rts_lock();
        rts_evalIO(&cap,
                   rts_apply(rts_apply(deRefStablePtr(s),
                                       rts_mkBool(b)), rts_mkInt(i)));
        rts_unlock(cap);
}
\end{verbatim}
-}

dsFExportDynamic :: Id
                 -> Coercion
                 -> CCallConv
                 -> DsM ([Binding], SDoc, SDoc)
dsFExportDynamic :: Var -> Coercion -> CCallConv -> DsM ([Binding], SDoc, SDoc)
dsFExportDynamic Var
id Coercion
co0 CCallConv
cconv = do
    Module
mod <- IOEnv (Env DsGblEnv DsLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
    DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let fe_nm :: CLabelString
fe_nm = String -> CLabelString
mkFastString (String -> CLabelString) -> String -> CLabelString
forall a b. (a -> b) -> a -> b
$ String -> String
zEncodeString
            (Module -> String
moduleStableString Module
mod String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"$" String -> String -> String
forall a. [a] -> [a] -> [a]
++ DynFlags -> Var -> String
toCName DynFlags
dflags Var
id)
        -- Construct the label based on the passed id, don't use names
        -- depending on Unique. See #13807 and Note [Unique Determinism].
    Var
cback <- Type -> DsM Var
newSysLocalDs Type
arg_ty
    Var
newStablePtrId <- Name -> DsM Var
dsLookupGlobalId Name
newStablePtrName
    TyCon
stable_ptr_tycon <- Name -> DsM TyCon
dsLookupTyCon Name
stablePtrTyConName
    let
        stable_ptr_ty :: Type
stable_ptr_ty = TyCon -> [Type] -> Type
mkTyConApp TyCon
stable_ptr_tycon [Type
arg_ty]
        export_ty :: Type
export_ty     = Type -> Type -> Type
mkVisFunTy Type
stable_ptr_ty Type
arg_ty
    Var
bindIOId <- Name -> DsM Var
dsLookupGlobalId Name
bindIOName
    Var
stbl_value <- Type -> DsM Var
newSysLocalDs Type
stable_ptr_ty
    (SDoc
h_code, SDoc
c_code, String
typestring, Int
args_size) <- Var
-> Coercion
-> CLabelString
-> CCallConv
-> Bool
-> DsM (SDoc, SDoc, String, Int)
dsFExport Var
id (Type -> Coercion
mkRepReflCo Type
export_ty) CLabelString
fe_nm CCallConv
cconv Bool
True
    let
         {-
          The arguments to the external function which will
          create a little bit of (template) code on the fly
          for allowing the (stable pointed) Haskell closure
          to be entered using an external calling convention
          (stdcall, ccall).
         -}
        adj_args :: [CoreExpr]
adj_args      = [ DynFlags -> Int -> CoreExpr
forall b. DynFlags -> Int -> Expr b
mkIntLitInt DynFlags
dflags (CCallConv -> Int
ccallConvToInt CCallConv
cconv)
                        , Var -> CoreExpr
forall b. Var -> Expr b
Var Var
stbl_value
                        , Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (CLabelString -> Maybe Int -> FunctionOrData -> Literal
LitLabel CLabelString
fe_nm Maybe Int
mb_sz_args FunctionOrData
IsFunction)
                        , Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (String -> Literal
mkLitString String
typestring)
                        ]
          -- name of external entry point providing these services.
          -- (probably in the RTS.)
        adjustor :: CLabelString
adjustor   = String -> CLabelString
fsLit String
"createAdjustor"

          -- Determine the number of bytes of arguments to the stub function,
          -- so that we can attach the '@N' suffix to its label if it is a
          -- stdcall on Windows.
        mb_sz_args :: Maybe Int
mb_sz_args = case CCallConv
cconv of
                        CCallConv
StdCallConv -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
args_size
                        CCallConv
_           -> Maybe Int
forall a. Maybe a
Nothing

    CoreExpr
ccall_adj <- CLabelString -> [CoreExpr] -> Safety -> Type -> DsM CoreExpr
dsCCall CLabelString
adjustor [CoreExpr]
adj_args Safety
PlayRisky (TyCon -> [Type] -> Type
mkTyConApp TyCon
io_tc [Type
res_ty])
        -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback

    let io_app :: CoreExpr
io_app = [Var] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Var]
tvs                  (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
                 Var -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Var
cback                   (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
                 CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
bindIOId)
                        [ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
stable_ptr_ty
                        , Type -> CoreExpr
forall b. Type -> Expr b
Type Type
res_ty
                        , CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
newStablePtrId) [ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
arg_ty, Var -> CoreExpr
forall b. Var -> Expr b
Var Var
cback ]
                        , Var -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Var
stbl_value CoreExpr
ccall_adj
                        ]

        fed :: Binding
fed = (Var
id Var -> Activation -> Var
`setInlineActivation` Activation
NeverActive, CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
io_app Coercion
co0)
               -- Never inline the f.e.d. function, because the litlit
               -- might not be in scope in other modules.

    ([Binding], SDoc, SDoc) -> DsM ([Binding], SDoc, SDoc)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Binding
fed], SDoc
h_code, SDoc
c_code)

 where
  ty :: Type
ty                       = Pair Type -> Type
forall a. Pair a -> a
pFst (Coercion -> Pair Type
coercionKind Coercion
co0)
  ([Var]
tvs,Type
sans_foralls)       = Type -> ([Var], Type)
tcSplitForAllTys Type
ty
  ([Type
arg_ty], Type
fn_res_ty)    = Type -> ([Type], Type)
tcSplitFunTys Type
sans_foralls
  Just (TyCon
io_tc, Type
res_ty)     = Type -> Maybe (TyCon, Type)
tcSplitIOType_maybe Type
fn_res_ty
        -- Must have an IO type; hence Just


toCName :: DynFlags -> Id -> String
toCName :: DynFlags -> Var -> String
toCName DynFlags
dflags Var
i = DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (CodeStyle -> SDoc -> SDoc
pprCode CodeStyle
CStyle (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Name
idName Var
i)))

{-
*

\subsection{Generating @foreign export@ stubs}

*

For each @foreign export@ function, a C stub function is generated.
The C stub constructs the application of the exported Haskell function
using the hugs/ghc rts invocation API.
-}

mkFExportCBits :: DynFlags
               -> FastString
               -> Maybe Id      -- Just==static, Nothing==dynamic
               -> [Type]
               -> Type
               -> Bool          -- True <=> returns an IO type
               -> CCallConv
               -> (SDoc,
                   SDoc,
                   String,      -- the argument reps
                   Int          -- total size of arguments
                  )
mkFExportCBits :: DynFlags
-> CLabelString
-> Maybe Var
-> [Type]
-> Type
-> Bool
-> CCallConv
-> (SDoc, SDoc, String, Int)
mkFExportCBits DynFlags
dflags CLabelString
c_nm Maybe Var
maybe_target [Type]
arg_htys Type
res_hty Bool
is_IO_res_ty CCallConv
cc
 = (SDoc
header_bits, SDoc
c_bits, String
type_string,
    [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ Width -> Int
widthInBytes (CmmType -> Width
typeWidth CmmType
rep) | (SDoc
_,SDoc
_,Type
_,CmmType
rep) <- [(SDoc, SDoc, Type, CmmType)]
aug_arg_info] -- all the args
         -- NB. the calculation here isn't strictly speaking correct.
         -- We have a primitive Haskell type (eg. Int#, Double#), and
         -- we want to know the size, when passed on the C stack, of
         -- the associated C type (eg. HsInt, HsDouble).  We don't have
         -- this information to hand, but we know what GHC's conventions
         -- are for passing around the primitive Haskell types, so we
         -- use that instead.  I hope the two coincide --SDM
    )
 where
  -- list the arguments to the C function
  arg_info :: [(SDoc,           -- arg name
                SDoc,           -- C type
                Type,           -- Haskell type
                CmmType)]       -- the CmmType
  arg_info :: [(SDoc, SDoc, Type, CmmType)]
arg_info  = [ let stg_type :: SDoc
stg_type = Type -> SDoc
showStgType Type
ty in
                (Int -> SDoc -> SDoc
arg_cname Int
n SDoc
stg_type,
                 SDoc
stg_type,
                 Type
ty,
                 DynFlags -> Type -> CmmType
typeCmmType DynFlags
dflags (Type -> Type
getPrimTyOf Type
ty))
              | (Type
ty,Int
n) <- [Type] -> [Int] -> [(Type, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
arg_htys [Int
1::Int ..] ]

  arg_cname :: Int -> SDoc -> SDoc
arg_cname Int
n SDoc
stg_ty
        | Bool
libffi    = Char -> SDoc
char Char
'*' SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (SDoc
stg_ty SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'*') SDoc -> SDoc -> SDoc
<>
                      String -> SDoc
text String
"args" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
brackets (Int -> SDoc
int (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1))
        | Bool
otherwise = String -> SDoc
text (Char
'a'Char -> String -> String
forall a. a -> [a] -> [a]
:Int -> String
forall a. Show a => a -> String
show Int
n)

  -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled
  libffi :: Bool
libffi = PlatformMisc -> Bool
platformMisc_libFFI (DynFlags -> PlatformMisc
platformMisc DynFlags
dflags) Bool -> Bool -> Bool
&& Maybe Var -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Var
maybe_target

  type_string :: String
type_string
      -- libffi needs to know the result type too:
      | Bool
libffi    = DynFlags -> Type -> Char
primTyDescChar DynFlags
dflags Type
res_hty Char -> String -> String
forall a. a -> [a] -> [a]
: String
arg_type_string
      | Bool
otherwise = String
arg_type_string

  arg_type_string :: String
arg_type_string = [DynFlags -> Type -> Char
primTyDescChar DynFlags
dflags Type
ty | (SDoc
_,SDoc
_,Type
ty,CmmType
_) <- [(SDoc, SDoc, Type, CmmType)]
arg_info]
                -- just the real args

  -- add some auxiliary args; the stable ptr in the wrapper case, and
  -- a slot for the dummy return address in the wrapper + ccall case
  aug_arg_info :: [(SDoc, SDoc, Type, CmmType)]
aug_arg_info
    | Maybe Var -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Var
maybe_target = (SDoc, SDoc, Type, CmmType)
stable_ptr_arg (SDoc, SDoc, Type, CmmType)
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
forall a. a -> [a] -> [a]
: DynFlags
-> CCallConv
-> [(SDoc, SDoc, Type, CmmType)]
-> [(SDoc, SDoc, Type, CmmType)]
insertRetAddr DynFlags
dflags CCallConv
cc [(SDoc, SDoc, Type, CmmType)]
arg_info
    | Bool
otherwise              = [(SDoc, SDoc, Type, CmmType)]
arg_info

  stable_ptr_arg :: (SDoc, SDoc, Type, CmmType)
stable_ptr_arg =
        (String -> SDoc
text String
"the_stableptr", String -> SDoc
text String
"StgStablePtr", Type
forall a. HasCallStack => a
undefined,
         DynFlags -> Type -> CmmType
typeCmmType DynFlags
dflags (Type -> Type
mkStablePtrPrimTy Type
alphaTy))

  -- stuff to do with the return type of the C function
  res_hty_is_unit :: Bool
res_hty_is_unit = Type
res_hty Type -> Type -> Bool
`eqType` Type
unitTy     -- Look through any newtypes

  cResType :: SDoc
cResType | Bool
res_hty_is_unit = String -> SDoc
text String
"void"
           | Bool
otherwise       = Type -> SDoc
showStgType Type
res_hty

  -- when the return type is integral and word-sized or smaller, it
  -- must be assigned as type ffi_arg (#3516).  To see what type
  -- libffi is expecting here, take a look in its own testsuite, e.g.
  -- libffi/testsuite/libffi.call/cls_align_ulonglong.c
  ffi_cResType :: SDoc
ffi_cResType
     | Bool
is_ffi_arg_type = String -> SDoc
text String
"ffi_arg"
     | Bool
otherwise       = SDoc
cResType
     where
       res_ty_key :: Unique
res_ty_key = Name -> Unique
forall a. Uniquable a => a -> Unique
getUnique (TyCon -> Name
forall a. NamedThing a => a -> Name
getName (Type -> TyCon
typeTyCon Type
res_hty))
       is_ffi_arg_type :: Bool
is_ffi_arg_type = Unique
res_ty_key Unique -> [Unique] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem`
              [Unique
floatTyConKey, Unique
doubleTyConKey,
               Unique
int64TyConKey, Unique
word64TyConKey]

  -- Now we can cook up the prototype for the exported function.
  pprCconv :: SDoc
pprCconv = CCallConv -> SDoc
ccallConvAttribute CCallConv
cc

  header_bits :: SDoc
header_bits = String -> SDoc
text String
"extern" SDoc -> SDoc -> SDoc
<+> SDoc
fun_proto SDoc -> SDoc -> SDoc
<> SDoc
semi

  fun_args :: SDoc
fun_args
    | [(SDoc, SDoc, Type, CmmType)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(SDoc, SDoc, Type, CmmType)]
aug_arg_info = String -> SDoc
text String
"void"
    | Bool
otherwise         = [SDoc] -> SDoc
hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma
                               ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ ((SDoc, SDoc, Type, CmmType) -> SDoc)
-> [(SDoc, SDoc, Type, CmmType)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\(SDoc
nm,SDoc
ty,Type
_,CmmType
_) -> SDoc
ty SDoc -> SDoc -> SDoc
<+> SDoc
nm) [(SDoc, SDoc, Type, CmmType)]
aug_arg_info

  fun_proto :: SDoc
fun_proto
    | Bool
libffi
      = String -> SDoc
text String
"void" SDoc -> SDoc -> SDoc
<+> CLabelString -> SDoc
ftext CLabelString
c_nm SDoc -> SDoc -> SDoc
<>
          SDoc -> SDoc
parens (String -> SDoc
text String
"void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr")
    | Bool
otherwise
      = SDoc
cResType SDoc -> SDoc -> SDoc
<+> SDoc
pprCconv SDoc -> SDoc -> SDoc
<+> CLabelString -> SDoc
ftext CLabelString
c_nm SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens SDoc
fun_args

  -- the target which will form the root of what we ask rts_evalIO to run
  the_cfun :: SDoc
the_cfun
     = case Maybe Var
maybe_target of
          Maybe Var
Nothing    -> String -> SDoc
text String
"(StgClosure*)deRefStablePtr(the_stableptr)"
          Just Var
hs_fn -> Char -> SDoc
char Char
'&' SDoc -> SDoc -> SDoc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
hs_fn SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"_closure"

  cap :: SDoc
cap = String -> SDoc
text String
"cap" SDoc -> SDoc -> SDoc
<> SDoc
comma

  -- the expression we give to rts_evalIO
  expr_to_run :: SDoc
expr_to_run
     = (SDoc -> (SDoc, SDoc, Type, CmmType) -> SDoc)
-> SDoc -> [(SDoc, SDoc, Type, CmmType)] -> SDoc
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SDoc -> (SDoc, SDoc, Type, CmmType) -> SDoc
forall b d. SDoc -> (SDoc, b, Type, d) -> SDoc
appArg SDoc
the_cfun [(SDoc, SDoc, Type, CmmType)]
arg_info -- NOT aug_arg_info
       where
          appArg :: SDoc -> (SDoc, b, Type, d) -> SDoc
appArg SDoc
acc (SDoc
arg_cname, b
_, Type
arg_hty, d
_)
             = String -> SDoc
text String
"rts_apply"
               SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (SDoc
cap SDoc -> SDoc -> SDoc
<> SDoc
acc SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<> Type -> SDoc
mkHObj Type
arg_hty SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (SDoc
cap SDoc -> SDoc -> SDoc
<> SDoc
arg_cname))

  -- various other bits for inside the fn
  declareResult :: SDoc
declareResult = String -> SDoc
text String
"HaskellObj ret;"
  declareCResult :: SDoc
declareCResult | Bool
res_hty_is_unit = SDoc
empty
                 | Bool
otherwise       = SDoc
cResType SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"cret;"

  assignCResult :: SDoc
assignCResult | Bool
res_hty_is_unit = SDoc
empty
                | Bool
otherwise       =
                        String -> SDoc
text String
"cret=" SDoc -> SDoc -> SDoc
<> Type -> SDoc
unpackHObj Type
res_hty SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (String -> SDoc
text String
"ret") SDoc -> SDoc -> SDoc
<> SDoc
semi

  -- an extern decl for the fn being called
  extern_decl :: SDoc
extern_decl
     = case Maybe Var
maybe_target of
          Maybe Var
Nothing -> SDoc
empty
          Just Var
hs_fn -> String -> SDoc
text String
"extern StgClosure " SDoc -> SDoc -> SDoc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
hs_fn SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"_closure" SDoc -> SDoc -> SDoc
<> SDoc
semi


  -- finally, the whole darn thing
  c_bits :: SDoc
c_bits =
    SDoc
space SDoc -> SDoc -> SDoc
$$
    SDoc
extern_decl SDoc -> SDoc -> SDoc
$$
    SDoc
fun_proto  SDoc -> SDoc -> SDoc
$$
    [SDoc] -> SDoc
vcat
     [ SDoc
lbrace
     ,   String -> SDoc
text String
"Capability *cap;"
     ,   SDoc
declareResult
     ,   SDoc
declareCResult
     ,   String -> SDoc
text String
"cap = rts_lock();"
          -- create the application + perform it.
     ,   String -> SDoc
text String
"rts_evalIO" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (
                Char -> SDoc
char Char
'&' SDoc -> SDoc -> SDoc
<> SDoc
cap SDoc -> SDoc -> SDoc
<>
                String -> SDoc
text String
"rts_apply" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (
                    SDoc
cap SDoc -> SDoc -> SDoc
<>
                    String -> SDoc
text String
"(HaskellObj)"
                 SDoc -> SDoc -> SDoc
<> PtrString -> SDoc
ptext (if Bool
is_IO_res_ty
                                then (String -> PtrString
sLit String
"runIO_closure")
                                else (String -> PtrString
sLit String
"runNonIO_closure"))
                 SDoc -> SDoc -> SDoc
<> SDoc
comma
                 SDoc -> SDoc -> SDoc
<> SDoc
expr_to_run
                ) SDoc -> SDoc -> SDoc
<+> SDoc
comma
               SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"&ret"
             ) SDoc -> SDoc -> SDoc
<> SDoc
semi
     ,   String -> SDoc
text String
"rts_checkSchedStatus" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (SDoc -> SDoc
doubleQuotes (CLabelString -> SDoc
ftext CLabelString
c_nm)
                                                SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"cap") SDoc -> SDoc -> SDoc
<> SDoc
semi
     ,   SDoc
assignCResult
     ,   String -> SDoc
text String
"rts_unlock(cap);"
     ,   Bool -> SDoc -> SDoc
ppUnless Bool
res_hty_is_unit (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
         if Bool
libffi
                  then Char -> SDoc
char Char
'*' SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (SDoc
ffi_cResType SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'*') SDoc -> SDoc -> SDoc
<>
                       String -> SDoc
text String
"resp = cret;"
                  else String -> SDoc
text String
"return cret;"
     , SDoc
rbrace
     ]


foreignExportInitialiser :: Id -> SDoc
foreignExportInitialiser :: Var -> SDoc
foreignExportInitialiser Var
hs_fn =
   -- Initialise foreign exports by registering a stable pointer from an
   -- __attribute__((constructor)) function.
   -- The alternative is to do this from stginit functions generated in
   -- codeGen/CodeGen.hs; however, stginit functions have a negative impact
   -- on binary sizes and link times because the static linker will think that
   -- all modules that are imported directly or indirectly are actually used by
   -- the program.
   -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)
   [SDoc] -> SDoc
vcat
    [ String -> SDoc
text String
"static void stginit_export_" SDoc -> SDoc -> SDoc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
hs_fn
         SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"() __attribute__((constructor));"
    , String -> SDoc
text String
"static void stginit_export_" SDoc -> SDoc -> SDoc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
hs_fn SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"()"
    , SDoc -> SDoc
braces (String -> SDoc
text String
"foreignExportStablePtr"
       SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (String -> SDoc
text String
"(StgPtr) &" SDoc -> SDoc -> SDoc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
hs_fn SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"_closure")
       SDoc -> SDoc -> SDoc
<> SDoc
semi)
    ]


mkHObj :: Type -> SDoc
mkHObj :: Type -> SDoc
mkHObj Type
t = String -> SDoc
text String
"rts_mk" SDoc -> SDoc -> SDoc
<> String -> SDoc
text (Type -> String
showFFIType Type
t)

unpackHObj :: Type -> SDoc
unpackHObj :: Type -> SDoc
unpackHObj Type
t = String -> SDoc
text String
"rts_get" SDoc -> SDoc -> SDoc
<> String -> SDoc
text (Type -> String
showFFIType Type
t)

showStgType :: Type -> SDoc
showStgType :: Type -> SDoc
showStgType Type
t = String -> SDoc
text String
"Hs" SDoc -> SDoc -> SDoc
<> String -> SDoc
text (Type -> String
showFFIType Type
t)

showFFIType :: Type -> String
showFFIType :: Type -> String
showFFIType Type
t = Name -> String
forall a. NamedThing a => a -> String
getOccString (TyCon -> Name
forall a. NamedThing a => a -> Name
getName (Type -> TyCon
typeTyCon Type
t))

toCType :: Type -> (Maybe Header, SDoc)
toCType :: Type -> (Maybe Header, SDoc)
toCType = Bool -> Type -> (Maybe Header, SDoc)
f Bool
False
    where f :: Bool -> Type -> (Maybe Header, SDoc)
f Bool
voidOK Type
t
           -- First, if we have (Ptr t) of (FunPtr t), then we need to
           -- convert t to a C type and put a * after it. If we don't
           -- know a type for t, then "void" is fine, though.
           | Just (TyCon
ptr, [Type
t']) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
t
           , TyCon -> Name
tyConName TyCon
ptr Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name
ptrTyConName, Name
funPtrTyConName]
              = case Bool -> Type -> (Maybe Header, SDoc)
f Bool
True Type
t' of
                (Maybe Header
mh, SDoc
cType') ->
                    (Maybe Header
mh, SDoc
cType' SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'*')
           -- Otherwise, if we have a type constructor application, then
           -- see if there is a C type associated with that constructor.
           -- Note that we aren't looking through type synonyms or
           -- anything, as it may be the synonym that is annotated.
           | Just TyCon
tycon <- Type -> Maybe TyCon
tyConAppTyConPicky_maybe Type
t
           , Just (CType SourceText
_ Maybe Header
mHeader (SourceText
_,CLabelString
cType)) <- TyCon -> Maybe CType
tyConCType_maybe TyCon
tycon
              = (Maybe Header
mHeader, CLabelString -> SDoc
ftext CLabelString
cType)
           -- If we don't know a C type for this type, then try looking
           -- through one layer of type synonym etc.
           | Just Type
t' <- Type -> Maybe Type
coreView Type
t
              = Bool -> Type -> (Maybe Header, SDoc)
f Bool
voidOK Type
t'
           -- This may be an 'UnliftedFFITypes'-style ByteArray# argument
           -- (which is marshalled like a Ptr)
           | TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
byteArrayPrimTyCon        Maybe TyCon -> Maybe TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== Type -> Maybe TyCon
tyConAppTyConPicky_maybe Type
t
              = (Maybe Header
forall a. Maybe a
Nothing, String -> SDoc
text String
"const void*")
           | TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
mutableByteArrayPrimTyCon Maybe TyCon -> Maybe TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== Type -> Maybe TyCon
tyConAppTyConPicky_maybe Type
t
              = (Maybe Header
forall a. Maybe a
Nothing, String -> SDoc
text String
"void*")
           -- Otherwise we don't know the C type. If we are allowing
           -- void then return that; otherwise something has gone wrong.
           | Bool
voidOK = (Maybe Header
forall a. Maybe a
Nothing, String -> SDoc
text String
"void")
           | Bool
otherwise
              = String -> SDoc -> (Maybe Header, SDoc)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"toCType" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
t)

typeTyCon :: Type -> TyCon
typeTyCon :: Type -> TyCon
typeTyCon Type
ty
  | Just (TyCon
tc, [Type]
_) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe (Type -> Type
unwrapType Type
ty)
  = TyCon
tc
  | Bool
otherwise
  = String -> SDoc -> TyCon
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"DsForeign.typeTyCon" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)

insertRetAddr :: DynFlags -> CCallConv
              -> [(SDoc, SDoc, Type, CmmType)]
              -> [(SDoc, SDoc, Type, CmmType)]
insertRetAddr :: DynFlags
-> CCallConv
-> [(SDoc, SDoc, Type, CmmType)]
-> [(SDoc, SDoc, Type, CmmType)]
insertRetAddr DynFlags
dflags CCallConv
CCallConv [(SDoc, SDoc, Type, CmmType)]
args
    = case Platform -> Arch
platformArch Platform
platform of
      Arch
ArchX86_64
       | Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32 ->
          -- On other Windows x86_64 we insert the return address
          -- after the 4th argument, because this is the point
          -- at which we need to flush a register argument to the stack
          -- (See rts/Adjustor.c for details).
          let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
                        -> [(SDoc, SDoc, Type, CmmType)]
              go :: Int
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
go Int
4 [(SDoc, SDoc, Type, CmmType)]
args = DynFlags -> (SDoc, SDoc, Type, CmmType)
ret_addr_arg DynFlags
dflags (SDoc, SDoc, Type, CmmType)
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
forall a. a -> [a] -> [a]
: [(SDoc, SDoc, Type, CmmType)]
args
              go Int
n ((SDoc, SDoc, Type, CmmType)
arg:[(SDoc, SDoc, Type, CmmType)]
args) = (SDoc, SDoc, Type, CmmType)
arg (SDoc, SDoc, Type, CmmType)
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
forall a. a -> [a] -> [a]
: Int
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [(SDoc, SDoc, Type, CmmType)]
args
              go Int
_ [] = []
          in Int
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
go Int
0 [(SDoc, SDoc, Type, CmmType)]
args
       | Bool
otherwise ->
          -- On other x86_64 platforms we insert the return address
          -- after the 6th integer argument, because this is the point
          -- at which we need to flush a register argument to the stack
          -- (See rts/Adjustor.c for details).
          let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
                        -> [(SDoc, SDoc, Type, CmmType)]
              go :: Int
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
go Int
6 [(SDoc, SDoc, Type, CmmType)]
args = DynFlags -> (SDoc, SDoc, Type, CmmType)
ret_addr_arg DynFlags
dflags (SDoc, SDoc, Type, CmmType)
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
forall a. a -> [a] -> [a]
: [(SDoc, SDoc, Type, CmmType)]
args
              go Int
n (arg :: (SDoc, SDoc, Type, CmmType)
arg@(SDoc
_,SDoc
_,Type
_,CmmType
rep):[(SDoc, SDoc, Type, CmmType)]
args)
               | CmmType -> CmmType -> Bool
cmmEqType_ignoring_ptrhood CmmType
rep CmmType
b64 = (SDoc, SDoc, Type, CmmType)
arg (SDoc, SDoc, Type, CmmType)
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
forall a. a -> [a] -> [a]
: Int
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [(SDoc, SDoc, Type, CmmType)]
args
               | Bool
otherwise  = (SDoc, SDoc, Type, CmmType)
arg (SDoc, SDoc, Type, CmmType)
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
forall a. a -> [a] -> [a]
: Int
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
go Int
n     [(SDoc, SDoc, Type, CmmType)]
args
              go Int
_ [] = []
          in Int
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
go Int
0 [(SDoc, SDoc, Type, CmmType)]
args
      Arch
_ ->
          DynFlags -> (SDoc, SDoc, Type, CmmType)
ret_addr_arg DynFlags
dflags (SDoc, SDoc, Type, CmmType)
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
forall a. a -> [a] -> [a]
: [(SDoc, SDoc, Type, CmmType)]
args
    where platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
insertRetAddr DynFlags
_ CCallConv
_ [(SDoc, SDoc, Type, CmmType)]
args = [(SDoc, SDoc, Type, CmmType)]
args

ret_addr_arg :: DynFlags -> (SDoc, SDoc, Type, CmmType)
ret_addr_arg :: DynFlags -> (SDoc, SDoc, Type, CmmType)
ret_addr_arg DynFlags
dflags = (String -> SDoc
text String
"original_return_addr", String -> SDoc
text String
"void*", Type
forall a. HasCallStack => a
undefined,
                       DynFlags -> Type -> CmmType
typeCmmType DynFlags
dflags Type
addrPrimTy)

-- This function returns the primitive type associated with the boxed
-- type argument to a foreign export (eg. Int ==> Int#).
getPrimTyOf :: Type -> UnaryType
getPrimTyOf :: Type -> Type
getPrimTyOf Type
ty
  | Type -> Bool
isBoolTy Type
rep_ty = Type
intPrimTy
  -- Except for Bool, the types we are interested in have a single constructor
  -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
  | Bool
otherwise =
  case Type -> Maybe (TyCon, [Type], DataCon, [Type])
splitDataProductType_maybe Type
rep_ty of
     Just (TyCon
_, [Type]
_, DataCon
data_con, [Type
prim_ty]) ->
        ASSERT(dataConSourceArity data_con == 1)
        ASSERT2(isUnliftedType prim_ty, ppr prim_ty)
        Type
prim_ty
     Maybe (TyCon, [Type], DataCon, [Type])
_other -> String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"DsForeign.getPrimTyOf" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)
  where
        rep_ty :: Type
rep_ty = Type -> Type
unwrapType Type
ty

-- represent a primitive type as a Char, for building a string that
-- described the foreign function type.  The types are size-dependent,
-- e.g. 'W' is a signed 32-bit integer.
primTyDescChar :: DynFlags -> Type -> Char
primTyDescChar :: DynFlags -> Type -> Char
primTyDescChar DynFlags
dflags Type
ty
 | Type
ty Type -> Type -> Bool
`eqType` Type
unitTy = Char
'v'
 | Bool
otherwise
 = case HasDebugCallStack => Type -> PrimRep
Type -> PrimRep
typePrimRep1 (Type -> Type
getPrimTyOf Type
ty) of
     PrimRep
IntRep      -> Char
signed_word
     PrimRep
WordRep     -> Char
unsigned_word
     PrimRep
Int64Rep    -> Char
'L'
     PrimRep
Word64Rep   -> Char
'l'
     PrimRep
AddrRep     -> Char
'p'
     PrimRep
FloatRep    -> Char
'f'
     PrimRep
DoubleRep   -> Char
'd'
     PrimRep
_           -> String -> SDoc -> Char
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"primTyDescChar" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)
  where
    (Char
signed_word, Char
unsigned_word)
       | DynFlags -> Int
wORD_SIZE DynFlags
dflags Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4  = (Char
'W',Char
'w')
       | DynFlags -> Int
wORD_SIZE DynFlags
dflags Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8  = (Char
'L',Char
'l')
       | Bool
otherwise              = String -> (Char, Char)
forall a. String -> a
panic String
"primTyDescChar"