never executed always true always false
    1 
    2 {-# LANGUAGE FlexibleContexts #-}
    3 {-# LANGUAGE TypeFamilies #-}
    4 
    5 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
    6 
    7 {-
    8 (c) The University of Glasgow 2006
    9 (c) The AQUA Project, Glasgow University, 1998
   10 
   11 
   12 Desugaring foreign declarations (see also GHC.HsToCore.Foreign.Call).
   13 -}
   14 
   15 module GHC.HsToCore.Foreign.Decl ( dsForeigns ) where
   16 
   17 import GHC.Prelude
   18 
   19 import GHC.Tc.Utils.Monad        -- temp
   20 
   21 import GHC.Core
   22 
   23 import GHC.HsToCore.Foreign.Call
   24 import GHC.HsToCore.Monad
   25 import GHC.HsToCore.Types (ds_next_wrapper_num)
   26 
   27 import GHC.Hs
   28 import GHC.Core.DataCon
   29 import GHC.Core.Unfold.Make
   30 import GHC.Types.Id
   31 import GHC.Types.Literal
   32 import GHC.Types.ForeignStubs
   33 import GHC.Types.SourceText
   34 import GHC.Unit.Module
   35 import GHC.Types.Name
   36 import GHC.Core.Type
   37 import GHC.Types.RepType
   38 import GHC.Core.TyCon
   39 import GHC.Core.Coercion
   40 import GHC.Core.Multiplicity
   41 import GHC.Tc.Utils.Env
   42 import GHC.Tc.Utils.TcType
   43 
   44 import GHC.Cmm.Expr
   45 import GHC.Cmm.Utils
   46 import GHC.Driver.Ppr
   47 import GHC.Types.ForeignCall
   48 import GHC.Builtin.Types
   49 import GHC.Builtin.Types.Prim
   50 import GHC.Builtin.Names
   51 import GHC.Types.Basic
   52 import GHC.Types.SrcLoc
   53 import GHC.Utils.Outputable
   54 import GHC.Data.FastString
   55 import GHC.Driver.Session
   56 import GHC.Driver.Config
   57 import GHC.Platform
   58 import GHC.Data.OrdList
   59 import GHC.Utils.Panic
   60 import GHC.Utils.Panic.Plain
   61 import GHC.Driver.Hooks
   62 import GHC.Utils.Encoding
   63 
   64 import Data.Maybe
   65 import Data.List (unzip4, nub)
   66 
   67 {-
   68 Desugaring of @foreign@ declarations is naturally split up into
   69 parts, an @import@ and an @export@  part. A @foreign import@
   70 declaration
   71 \begin{verbatim}
   72   foreign import cc nm f :: prim_args -> IO prim_res
   73 \end{verbatim}
   74 is the same as
   75 \begin{verbatim}
   76   f :: prim_args -> IO prim_res
   77   f a1 ... an = _ccall_ nm cc a1 ... an
   78 \end{verbatim}
   79 so we reuse the desugaring code in @GHC.HsToCore.Foreign.Call@ to deal with these.
   80 -}
   81 
   82 type Binding = (Id, CoreExpr) -- No rec/nonrec structure;
   83                               -- the occurrence analyser will sort it all out
   84 
   85 dsForeigns :: [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding)
   86 dsForeigns fos = do
   87     hooks <- getHooks
   88     case dsForeignsHook hooks of
   89         Nothing -> dsForeigns' fos
   90         Just h  -> h fos
   91 
   92 dsForeigns' :: [LForeignDecl GhcTc]
   93             -> DsM (ForeignStubs, OrdList Binding)
   94 dsForeigns' []
   95   = return (NoStubs, nilOL)
   96 dsForeigns' fos = do
   97     mod <- getModule
   98     fives <- mapM do_ldecl fos
   99     let
  100         (hs, cs, idss, bindss) = unzip4 fives
  101         fe_ids = concat idss
  102         fe_init_code = foreignExportsInitialiser mod fe_ids
  103     --
  104     return (ForeignStubs
  105              (mconcat hs)
  106              (mconcat cs `mappend` fe_init_code),
  107             foldr (appOL . toOL) nilOL bindss)
  108   where
  109    do_ldecl (L loc decl) = putSrcSpanDs (locA loc) (do_decl decl)
  110 
  111    do_decl :: ForeignDecl GhcTc -> DsM (CHeader, CStub, [Id], [Binding])
  112    do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do
  113       traceIf (text "fi start" <+> ppr id)
  114       let id' = unLoc id
  115       (bs, h, c) <- dsFImport id' co spec
  116       traceIf (text "fi end" <+> ppr id)
  117       return (h, c, [], bs)
  118 
  119    do_decl (ForeignExport { fd_name = L _ id
  120                           , fd_e_ext = co
  121                           , fd_fe = CExport
  122                               (L _ (CExportStatic _ ext_nm cconv)) _ }) = do
  123       (h, c, _, _) <- dsFExport id co ext_nm cconv False
  124       return (h, c, [id], [])
  125 
  126 {-
  127 ************************************************************************
  128 *                                                                      *
  129 \subsection{Foreign import}
  130 *                                                                      *
  131 ************************************************************************
  132 
  133 Desugaring foreign imports is just the matter of creating a binding
  134 that on its RHS unboxes its arguments, performs the external call
  135 (using the @CCallOp@ primop), before boxing the result up and returning it.
  136 
  137 However, we create a worker/wrapper pair, thus:
  138 
  139         foreign import f :: Int -> IO Int
  140 ==>
  141         f x = IO ( \s -> case x of { I# x# ->
  142                          case fw s x# of { (# s1, y# #) ->
  143                          (# s1, I# y# #)}})
  144 
  145         fw s x# = ccall f s x#
  146 
  147 The strictness/CPR analyser won't do this automatically because it doesn't look
  148 inside returned tuples; but inlining this wrapper is a Really Good Idea
  149 because it exposes the boxing to the call site.
  150 -}
  151 
  152 dsFImport :: Id
  153           -> Coercion
  154           -> ForeignImport
  155           -> DsM ([Binding], CHeader, CStub)
  156 dsFImport id co (CImport cconv safety mHeader spec _) =
  157     dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader
  158 
  159 dsCImport :: Id
  160           -> Coercion
  161           -> CImportSpec
  162           -> CCallConv
  163           -> Safety
  164           -> Maybe Header
  165           -> DsM ([Binding], CHeader, CStub)
  166 dsCImport id co (CLabel cid) cconv _ _ = do
  167    dflags <- getDynFlags
  168    let ty  = coercionLKind co
  169        platform = targetPlatform dflags
  170        fod = case tyConAppTyCon_maybe (dropForAlls ty) of
  171              Just tycon
  172               | tyConUnique tycon == funPtrTyConKey ->
  173                  IsFunction
  174              _ -> IsData
  175    (resTy, foRhs) <- resultWrapper ty
  176    assert (fromJust resTy `eqType` addrPrimTy) $    -- typechecker ensures this
  177     let
  178         rhs = foRhs (Lit (LitLabel cid stdcall_info fod))
  179         rhs' = Cast rhs co
  180         stdcall_info = fun_type_arg_stdcall_info platform cconv ty
  181     in
  182     return ([(id, rhs')], mempty, mempty)
  183 
  184 dsCImport id co (CFunction target) cconv@PrimCallConv safety _
  185   = dsPrimCall id co (CCall (CCallSpec target cconv safety))
  186 dsCImport id co (CFunction target) cconv safety mHeader
  187   = dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader
  188 dsCImport id co CWrapper cconv _ _
  189   = dsFExportDynamic id co cconv
  190 
  191 -- For stdcall labels, if the type was a FunPtr or newtype thereof,
  192 -- then we need to calculate the size of the arguments in order to add
  193 -- the @n suffix to the label.
  194 fun_type_arg_stdcall_info :: Platform -> CCallConv -> Type -> Maybe Int
  195 fun_type_arg_stdcall_info platform StdCallConv ty
  196   | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty,
  197     tyConUnique tc == funPtrTyConKey
  198   = let
  199        (bndrs, _) = tcSplitPiTys arg_ty
  200        fe_arg_tys = mapMaybe binderRelevantType_maybe bndrs
  201     in Just $ sum (map (widthInBytes . typeWidth . typeCmmType platform . getPrimTyOf) fe_arg_tys)
  202 fun_type_arg_stdcall_info _ _other_conv _
  203   = Nothing
  204 
  205 {-
  206 ************************************************************************
  207 *                                                                      *
  208 \subsection{Foreign calls}
  209 *                                                                      *
  210 ************************************************************************
  211 -}
  212 
  213 dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header
  214         -> DsM ([(Id, Expr TyVar)], CHeader, CStub)
  215 dsFCall fn_id co fcall mDeclHeader = do
  216     let
  217         ty                   = coercionLKind co
  218         (tv_bndrs, rho)      = tcSplitForAllTyVarBinders ty
  219         (arg_tys, io_res_ty) = tcSplitFunTys rho
  220 
  221     args <- newSysLocalsDs arg_tys  -- no FFI representation polymorphism
  222     (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)
  223 
  224     let
  225         work_arg_ids  = [v | Var v <- val_args] -- All guaranteed to be vars
  226 
  227     (ccall_result_ty, res_wrapper) <- boxResult io_res_ty
  228 
  229     ccall_uniq <- newUnique
  230     work_uniq  <- newUnique
  231 
  232     (fcall', cDoc) <-
  233               case fcall of
  234               CCall (CCallSpec (StaticTarget _ cName mUnitId isFun)
  235                                CApiConv safety) ->
  236                do nextWrapperNum <- ds_next_wrapper_num <$> getGblEnv
  237                   wrapperName <- mkWrapperName nextWrapperNum "ghc_wrapper" (unpackFS cName)
  238                   let fcall' = CCall (CCallSpec
  239                                       (StaticTarget NoSourceText
  240                                                     wrapperName mUnitId
  241                                                     True)
  242                                       CApiConv safety)
  243                       c = includes
  244                        $$ fun_proto <+> braces (cRet <> semi)
  245                       includes = vcat [ text "#include \"" <> ftext h
  246                                         <> text "\""
  247                                       | Header _ h <- nub headers ]
  248                       fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes
  249                       cRet
  250                        | isVoidRes =                   cCall
  251                        | otherwise = text "return" <+> cCall
  252                       cCall = if isFun
  253                               then ppr cName <> parens argVals
  254                               else if null arg_tys
  255                                     then ppr cName
  256                                     else panic "dsFCall: Unexpected arguments to FFI value import"
  257                       raw_res_ty = case tcSplitIOType_maybe io_res_ty of
  258                                    Just (_ioTyCon, res_ty) -> res_ty
  259                                    Nothing                 -> io_res_ty
  260                       isVoidRes = raw_res_ty `eqType` unitTy
  261                       (mHeader, cResType)
  262                        | isVoidRes = (Nothing, text "void")
  263                        | otherwise = toCType raw_res_ty
  264                       pprCconv = ccallConvAttribute CApiConv
  265                       mHeadersArgTypeList
  266                           = [ (header, cType <+> char 'a' <> int n)
  267                             | (t, n) <- zip arg_tys [1..]
  268                             , let (header, cType) = toCType (scaledThing t) ]
  269                       (mHeaders, argTypeList) = unzip mHeadersArgTypeList
  270                       argTypes = if null argTypeList
  271                                  then text "void"
  272                                  else hsep $ punctuate comma argTypeList
  273                       mHeaders' = mDeclHeader : mHeader : mHeaders
  274                       headers = catMaybes mHeaders'
  275                       argVals = hsep $ punctuate comma
  276                                     [ char 'a' <> int n
  277                                     | (_, n) <- zip arg_tys [1..] ]
  278                   return (fcall', c)
  279               _ ->
  280                   return (fcall, empty)
  281     dflags <- getDynFlags
  282     let
  283         -- Build the worker
  284         worker_ty     = mkForAllTys tv_bndrs (mkVisFunTysMany (map idType work_arg_ids) ccall_result_ty)
  285         tvs           = map binderVar tv_bndrs
  286         the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty
  287         work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)
  288         work_id       = mkSysLocal (fsLit "$wccall") work_uniq Many worker_ty
  289 
  290         -- Build the wrapper
  291         work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
  292         wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
  293         wrap_rhs     = mkLams (tvs ++ args) wrapper_body
  294         wrap_rhs'    = Cast wrap_rhs co
  295         simpl_opts   = initSimpleOpts dflags
  296         fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity
  297                                                 (length args)
  298                                                 simpl_opts
  299                                                 wrap_rhs'
  300 
  301     return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, CStub cDoc)
  302 
  303 {-
  304 ************************************************************************
  305 *                                                                      *
  306 \subsection{Primitive calls}
  307 *                                                                      *
  308 ************************************************************************
  309 
  310 This is for `@foreign import prim@' declarations.
  311 
  312 Currently, at the core level we pretend that these primitive calls are
  313 foreign calls. It may make more sense in future to have them as a distinct
  314 kind of Id, or perhaps to bundle them with PrimOps since semantically and
  315 for calling convention they are really prim ops.
  316 -}
  317 
  318 dsPrimCall :: Id -> Coercion -> ForeignCall
  319            -> DsM ([(Id, Expr TyVar)], CHeader, CStub)
  320 dsPrimCall fn_id co fcall = do
  321     let
  322         ty                   = coercionLKind co
  323         (tvs, fun_ty)        = tcSplitForAllInvisTyVars ty
  324         (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
  325 
  326     args <- newSysLocalsDs arg_tys  -- no FFI representation polymorphism
  327 
  328     ccall_uniq <- newUnique
  329     dflags <- getDynFlags
  330     let
  331         call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty
  332         rhs      = mkLams tvs (mkLams args call_app)
  333         rhs'     = Cast rhs co
  334     return ([(fn_id, rhs')], mempty, mempty)
  335 
  336 {-
  337 ************************************************************************
  338 *                                                                      *
  339 \subsection{Foreign export}
  340 *                                                                      *
  341 ************************************************************************
  342 
  343 The function that does most of the work for `@foreign export@' declarations.
  344 (see below for the boilerplate code a `@foreign export@' declaration expands
  345  into.)
  346 
  347 For each `@foreign export foo@' in a module M we generate:
  348 \begin{itemize}
  349 \item a C function `@foo@', which calls
  350 \item a Haskell stub `@M.\$ffoo@', which calls
  351 \end{itemize}
  352 the user-written Haskell function `@M.foo@'.
  353 -}
  354 
  355 dsFExport :: Id                 -- Either the exported Id,
  356                                 -- or the foreign-export-dynamic constructor
  357           -> Coercion           -- Coercion between the Haskell type callable
  358                                 -- from C, and its representation type
  359           -> CLabelString       -- The name to export to C land
  360           -> CCallConv
  361           -> Bool               -- True => foreign export dynamic
  362                                 --         so invoke IO action that's hanging off
  363                                 --         the first argument's stable pointer
  364           -> DsM ( CHeader      -- contents of Module_stub.h
  365                  , CStub        -- contents of Module_stub.c
  366                  , String       -- string describing type to pass to createAdj.
  367                  , Int          -- size of args to stub function
  368                  )
  369 
  370 dsFExport fn_id co ext_name cconv isDyn = do
  371     let
  372        ty                     = coercionRKind co
  373        (bndrs, orig_res_ty)   = tcSplitPiTys ty
  374        fe_arg_tys'            = mapMaybe binderRelevantType_maybe bndrs
  375        -- We must use tcSplits here, because we want to see
  376        -- the (IO t) in the corner of the type!
  377        fe_arg_tys | isDyn     = tail fe_arg_tys'
  378                   | otherwise = fe_arg_tys'
  379 
  380        -- Look at the result type of the exported function, orig_res_ty
  381        -- If it's IO t, return         (t, True)
  382        -- If it's plain t, return      (t, False)
  383        (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of
  384                                 -- The function already returns IO t
  385                                 Just (_ioTyCon, res_ty) -> (res_ty, True)
  386                                 -- The function returns t
  387                                 Nothing                 -> (orig_res_ty, False)
  388 
  389     dflags <- getDynFlags
  390     return $
  391       mkFExportCBits dflags ext_name
  392                      (if isDyn then Nothing else Just fn_id)
  393                      fe_arg_tys res_ty is_IO_res_ty cconv
  394 
  395 {-
  396 @foreign import "wrapper"@ (previously "foreign export dynamic") lets
  397 you dress up Haskell IO actions of some fixed type behind an
  398 externally callable interface (i.e., as a C function pointer). Useful
  399 for callbacks and stuff.
  400 
  401 \begin{verbatim}
  402 type Fun = Bool -> Int -> IO Int
  403 foreign import "wrapper" f :: Fun -> IO (FunPtr Fun)
  404 
  405 -- Haskell-visible constructor, which is generated from the above:
  406 -- SUP: No check for NULL from createAdjustor anymore???
  407 
  408 f :: Fun -> IO (FunPtr Fun)
  409 f cback =
  410    bindIO (newStablePtr cback)
  411           (\StablePtr sp# -> IO (\s1# ->
  412               case _ccall_ createAdjustor cconv sp# ``f_helper'' <arg info> s1# of
  413                  (# s2#, a# #) -> (# s2#, A# a# #)))
  414 
  415 foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun)
  416 
  417 -- and the helper in C: (approximately; see `mkFExportCBits` below)
  418 
  419 f_helper(StablePtr s, HsBool b, HsInt i)
  420 {
  421         Capability *cap;
  422         cap = rts_lock();
  423         rts_inCall(&cap,
  424                    rts_apply(rts_apply(deRefStablePtr(s),
  425                                        rts_mkBool(b)), rts_mkInt(i)));
  426         rts_unlock(cap);
  427 }
  428 \end{verbatim}
  429 -}
  430 
  431 dsFExportDynamic :: Id
  432                  -> Coercion
  433                  -> CCallConv
  434                  -> DsM ([Binding], CHeader, CStub)
  435 dsFExportDynamic id co0 cconv = do
  436     mod <- getModule
  437     dflags <- getDynFlags
  438     let platform = targetPlatform dflags
  439     let fe_nm = mkFastString $ zEncodeString
  440             (moduleStableString mod ++ "$" ++ toCName dflags id)
  441         -- Construct the label based on the passed id, don't use names
  442         -- depending on Unique. See #13807 and Note [Unique Determinism].
  443     cback <- newSysLocalDs arg_mult arg_ty
  444     newStablePtrId <- dsLookupGlobalId newStablePtrName
  445     stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName
  446     let
  447         stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]
  448         export_ty     = mkVisFunTyMany stable_ptr_ty arg_ty
  449     bindIOId <- dsLookupGlobalId bindIOName
  450     stbl_value <- newSysLocalDs Many stable_ptr_ty
  451     (h_code, c_code, typestring, args_size) <- dsFExport id (mkRepReflCo export_ty) fe_nm cconv True
  452     let
  453          {-
  454           The arguments to the external function which will
  455           create a little bit of (template) code on the fly
  456           for allowing the (stable pointed) Haskell closure
  457           to be entered using an external calling convention
  458           (stdcall, ccall).
  459          -}
  460         adj_args      = [ mkIntLit platform (fromIntegral (ccallConvToInt cconv))
  461                         , Var stbl_value
  462                         , Lit (LitLabel fe_nm mb_sz_args IsFunction)
  463                         , Lit (mkLitString typestring)
  464                         ]
  465           -- name of external entry point providing these services.
  466           -- (probably in the RTS.)
  467         adjustor   = fsLit "createAdjustor"
  468 
  469           -- Determine the number of bytes of arguments to the stub function,
  470           -- so that we can attach the '@N' suffix to its label if it is a
  471           -- stdcall on Windows.
  472         mb_sz_args = case cconv of
  473                         StdCallConv -> Just args_size
  474                         _           -> Nothing
  475 
  476     ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])
  477         -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
  478 
  479     let io_app = mkLams tvs                  $
  480                  Lam cback                   $
  481                  mkApps (Var bindIOId)
  482                         [ Type stable_ptr_ty
  483                         , Type res_ty
  484                         , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
  485                         , Lam stbl_value ccall_adj
  486                         ]
  487 
  488         fed = (id `setInlineActivation` NeverActive, Cast io_app co0)
  489                -- Never inline the f.e.d. function, because the litlit
  490                -- might not be in scope in other modules.
  491 
  492     return ([fed], h_code, c_code)
  493 
  494  where
  495   ty                       = coercionLKind co0
  496   (tvs,sans_foralls)       = tcSplitForAllInvisTyVars ty
  497   ([Scaled arg_mult arg_ty], fn_res_ty)    = tcSplitFunTys sans_foralls
  498   Just (io_tc, res_ty)     = tcSplitIOType_maybe fn_res_ty
  499         -- Must have an IO type; hence Just
  500 
  501 
  502 toCName :: DynFlags -> Id -> String
  503 toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i)))
  504 
  505 {-
  506 *
  507 
  508 \subsection{Generating @foreign export@ stubs}
  509 
  510 *
  511 
  512 For each @foreign export@ function, a C stub function is generated.
  513 The C stub constructs the application of the exported Haskell function
  514 using the hugs/ghc rts invocation API.
  515 -}
  516 
  517 mkFExportCBits :: DynFlags
  518                -> FastString
  519                -> Maybe Id      -- Just==static, Nothing==dynamic
  520                -> [Type]
  521                -> Type
  522                -> Bool          -- True <=> returns an IO type
  523                -> CCallConv
  524                -> (CHeader,
  525                    CStub,
  526                    String,      -- the argument reps
  527                    Int          -- total size of arguments
  528                   )
  529 mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
  530  = (header_bits, c_bits, type_string,
  531     sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args
  532          -- NB. the calculation here isn't strictly speaking correct.
  533          -- We have a primitive Haskell type (eg. Int#, Double#), and
  534          -- we want to know the size, when passed on the C stack, of
  535          -- the associated C type (eg. HsInt, HsDouble).  We don't have
  536          -- this information to hand, but we know what GHC's conventions
  537          -- are for passing around the primitive Haskell types, so we
  538          -- use that instead.  I hope the two coincide --SDM
  539     )
  540  where
  541   platform = targetPlatform dflags
  542 
  543   -- list the arguments to the C function
  544   arg_info :: [(SDoc,           -- arg name
  545                 SDoc,           -- C type
  546                 Type,           -- Haskell type
  547                 CmmType)]       -- the CmmType
  548   arg_info  = [ let stg_type = showStgType ty in
  549                 (arg_cname n stg_type,
  550                  stg_type,
  551                  ty,
  552                 typeCmmType platform (getPrimTyOf ty))
  553               | (ty,n) <- zip arg_htys [1::Int ..] ]
  554 
  555   arg_cname n stg_ty
  556         | libffi    = char '*' <> parens (stg_ty <> char '*') <>
  557                       text "args" <> brackets (int (n-1))
  558         | otherwise = text ('a':show n)
  559 
  560   -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled
  561   libffi = platformMisc_libFFI (platformMisc dflags) && isNothing maybe_target
  562 
  563   type_string
  564       -- libffi needs to know the result type too:
  565       | libffi    = primTyDescChar platform res_hty : arg_type_string
  566       | otherwise = arg_type_string
  567 
  568   arg_type_string = [primTyDescChar platform ty | (_,_,ty,_) <- arg_info]
  569                 -- just the real args
  570 
  571   -- add some auxiliary args; the stable ptr in the wrapper case, and
  572   -- a slot for the dummy return address in the wrapper + ccall case
  573   aug_arg_info
  574     | isNothing maybe_target = stable_ptr_arg : insertRetAddr platform cc arg_info
  575     | otherwise              = arg_info
  576 
  577   stable_ptr_arg =
  578         (text "the_stableptr", text "StgStablePtr", undefined,
  579          typeCmmType platform (mkStablePtrPrimTy alphaTy))
  580 
  581   -- stuff to do with the return type of the C function
  582   res_hty_is_unit = res_hty `eqType` unitTy     -- Look through any newtypes
  583 
  584   cResType | res_hty_is_unit = text "void"
  585            | otherwise       = showStgType res_hty
  586 
  587   -- when the return type is integral and word-sized or smaller, it
  588   -- must be assigned as type ffi_arg (#3516).  To see what type
  589   -- libffi is expecting here, take a look in its own testsuite, e.g.
  590   -- libffi/testsuite/libffi.call/cls_align_ulonglong.c
  591   ffi_cResType
  592      | is_ffi_arg_type = text "ffi_arg"
  593      | otherwise       = cResType
  594      where
  595        res_ty_key = getUnique (getName (typeTyCon res_hty))
  596        is_ffi_arg_type = res_ty_key `notElem`
  597               [floatTyConKey, doubleTyConKey,
  598                int64TyConKey, word64TyConKey]
  599 
  600   -- Now we can cook up the prototype for the exported function.
  601   pprCconv = ccallConvAttribute cc
  602 
  603   header_bits = CHeader (text "extern" <+> fun_proto <> semi)
  604 
  605   fun_args
  606     | null aug_arg_info = text "void"
  607     | otherwise         = hsep $ punctuate comma
  608                                $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info
  609 
  610   fun_proto
  611     | libffi
  612       = text "void" <+> ftext c_nm <>
  613           parens (text "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr")
  614     | otherwise
  615       = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args
  616 
  617   -- the target which will form the root of what we ask rts_inCall to run
  618   the_cfun
  619      = case maybe_target of
  620           Nothing    -> text "(StgClosure*)deRefStablePtr(the_stableptr)"
  621           Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"
  622 
  623   cap = text "cap" <> comma
  624 
  625   -- the expression we give to rts_inCall
  626   expr_to_run
  627      = foldl' appArg the_cfun arg_info -- NOT aug_arg_info
  628        where
  629           appArg acc (arg_cname, _, arg_hty, _)
  630              = text "rts_apply"
  631                <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))
  632 
  633   -- various other bits for inside the fn
  634   declareResult = text "HaskellObj ret;"
  635   declareCResult | res_hty_is_unit = empty
  636                  | otherwise       = cResType <+> text "cret;"
  637 
  638   assignCResult | res_hty_is_unit = empty
  639                 | otherwise       =
  640                         text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi
  641 
  642   -- an extern decl for the fn being called
  643   extern_decl
  644      = case maybe_target of
  645           Nothing -> empty
  646           Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi
  647 
  648 
  649   -- finally, the whole darn thing
  650   c_bits = CStub $
  651     space $$
  652     extern_decl $$
  653     fun_proto  $$
  654     vcat
  655      [ lbrace
  656      ,   text "Capability *cap;"
  657      ,   declareResult
  658      ,   declareCResult
  659      ,   text "cap = rts_lock();"
  660           -- create the application + perform it.
  661      ,   text "rts_inCall" <> parens (
  662                 char '&' <> cap <>
  663                 text "rts_apply" <> parens (
  664                     cap <>
  665                     text "(HaskellObj)"
  666                  <> (if is_IO_res_ty
  667                       then text "runIO_closure"
  668                       else text "runNonIO_closure")
  669                  <> comma
  670                  <> expr_to_run
  671                 ) <+> comma
  672                <> text "&ret"
  673              ) <> semi
  674      ,   text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm)
  675                                                 <> comma <> text "cap") <> semi
  676      ,   assignCResult
  677      ,   text "rts_unlock(cap);"
  678      ,   ppUnless res_hty_is_unit $
  679          if libffi
  680                   then char '*' <> parens (ffi_cResType <> char '*') <>
  681                        text "resp = cret;"
  682                   else text "return cret;"
  683      , rbrace
  684      ]
  685 
  686 
  687 foreignExportsInitialiser :: Module -> [Id] -> CStub
  688 foreignExportsInitialiser mod hs_fns =
  689    -- Initialise foreign exports by registering a stable pointer from an
  690    -- __attribute__((constructor)) function.
  691    -- The alternative is to do this from stginit functions generated in
  692    -- codeGen/CodeGen.hs; however, stginit functions have a negative impact
  693    -- on binary sizes and link times because the static linker will think that
  694    -- all modules that are imported directly or indirectly are actually used by
  695    -- the program.
  696    -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)
  697    --
  698    -- See Note [Tracking foreign exports] in rts/ForeignExports.c
  699    CStub $ vcat
  700     [ text "static struct ForeignExportsList" <+> list_symbol <+> equals
  701          <+> braces (
  702            text ".exports = " <+> export_list <> comma <+>
  703            text ".n_entries = " <+> ppr (length hs_fns))
  704          <> semi
  705     , text "static void " <> ctor_symbol <> text "(void)"
  706          <+> text " __attribute__((constructor));"
  707     , text "static void " <> ctor_symbol <> text "()"
  708     , braces (text "registerForeignExports" <> parens (char '&' <> list_symbol) <> semi)
  709     ]
  710   where
  711     mod_str = pprModuleName (moduleName mod)
  712     ctor_symbol = text "stginit_export_" <> mod_str
  713     list_symbol = text "stg_exports_" <> mod_str
  714     export_list = braces $ pprWithCommas closure_ptr hs_fns
  715 
  716     closure_ptr :: Id -> SDoc
  717     closure_ptr fn = text "(StgPtr) &" <> ppr fn <> text "_closure"
  718 
  719 
  720 mkHObj :: Type -> SDoc
  721 mkHObj t = text "rts_mk" <> text (showFFIType t)
  722 
  723 unpackHObj :: Type -> SDoc
  724 unpackHObj t = text "rts_get" <> text (showFFIType t)
  725 
  726 showStgType :: Type -> SDoc
  727 showStgType t = text "Hs" <> text (showFFIType t)
  728 
  729 showFFIType :: Type -> String
  730 showFFIType t = getOccString (getName (typeTyCon t))
  731 
  732 toCType :: Type -> (Maybe Header, SDoc)
  733 toCType = f False
  734     where f voidOK t
  735            -- First, if we have (Ptr t) of (FunPtr t), then we need to
  736            -- convert t to a C type and put a * after it. If we don't
  737            -- know a type for t, then "void" is fine, though.
  738            | Just (ptr, [t']) <- splitTyConApp_maybe t
  739            , tyConName ptr `elem` [ptrTyConName, funPtrTyConName]
  740               = case f True t' of
  741                 (mh, cType') ->
  742                     (mh, cType' <> char '*')
  743            -- Otherwise, if we have a type constructor application, then
  744            -- see if there is a C type associated with that constructor.
  745            -- Note that we aren't looking through type synonyms or
  746            -- anything, as it may be the synonym that is annotated.
  747            | Just tycon <- tyConAppTyConPicky_maybe t
  748            , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon
  749               = (mHeader, ftext cType)
  750            -- If we don't know a C type for this type, then try looking
  751            -- through one layer of type synonym etc.
  752            | Just t' <- coreView t
  753               = f voidOK t'
  754            -- This may be an 'UnliftedFFITypes'-style ByteArray# argument
  755            -- (which is marshalled like a Ptr)
  756            | Just byteArrayPrimTyCon        == tyConAppTyConPicky_maybe t
  757               = (Nothing, text "const void*")
  758            | Just mutableByteArrayPrimTyCon == tyConAppTyConPicky_maybe t
  759               = (Nothing, text "void*")
  760            -- Otherwise we don't know the C type. If we are allowing
  761            -- void then return that; otherwise something has gone wrong.
  762            | voidOK = (Nothing, text "void")
  763            | otherwise
  764               = pprPanic "toCType" (ppr t)
  765 
  766 typeTyCon :: Type -> TyCon
  767 typeTyCon ty
  768   | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty)
  769   = tc
  770   | otherwise
  771   = pprPanic "GHC.HsToCore.Foreign.Decl.typeTyCon" (ppr ty)
  772 
  773 insertRetAddr :: Platform -> CCallConv
  774               -> [(SDoc, SDoc, Type, CmmType)]
  775               -> [(SDoc, SDoc, Type, CmmType)]
  776 insertRetAddr platform CCallConv args
  777     = case platformArch platform of
  778       ArchX86_64
  779        | platformOS platform == OSMinGW32 ->
  780           -- On other Windows x86_64 we insert the return address
  781           -- after the 4th argument, because this is the point
  782           -- at which we need to flush a register argument to the stack
  783           -- (See rts/Adjustor.c for details).
  784           let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
  785                         -> [(SDoc, SDoc, Type, CmmType)]
  786               go 4 args = ret_addr_arg platform : args
  787               go n (arg:args) = arg : go (n+1) args
  788               go _ [] = []
  789           in go 0 args
  790        | otherwise ->
  791           -- On other x86_64 platforms we insert the return address
  792           -- after the 6th integer argument, because this is the point
  793           -- at which we need to flush a register argument to the stack
  794           -- (See rts/Adjustor.c for details).
  795           let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
  796                         -> [(SDoc, SDoc, Type, CmmType)]
  797               go 6 args = ret_addr_arg platform : args
  798               go n (arg@(_,_,_,rep):args)
  799                | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args
  800                | otherwise  = arg : go n     args
  801               go _ [] = []
  802           in go 0 args
  803       _ ->
  804           ret_addr_arg platform : args
  805 insertRetAddr _ _ args = args
  806 
  807 ret_addr_arg :: Platform -> (SDoc, SDoc, Type, CmmType)
  808 ret_addr_arg platform = (text "original_return_addr", text "void*", undefined,
  809                          typeCmmType platform addrPrimTy)
  810 
  811 -- This function returns the primitive type associated with the boxed
  812 -- type argument to a foreign export (eg. Int ==> Int#).
  813 getPrimTyOf :: Type -> UnaryType
  814 getPrimTyOf ty
  815   | isBoolTy rep_ty = intPrimTy
  816   -- Except for Bool, the types we are interested in have a single constructor
  817   -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
  818   | otherwise =
  819   case splitDataProductType_maybe rep_ty of
  820      Just (_, _, data_con, [Scaled _ prim_ty]) ->
  821         assert (dataConSourceArity data_con == 1) $
  822         assertPpr (isUnliftedType prim_ty) (ppr prim_ty)
  823         prim_ty
  824      _other -> pprPanic "GHC.HsToCore.Foreign.Decl.getPrimTyOf" (ppr ty)
  825   where
  826         rep_ty = unwrapType ty
  827 
  828 -- represent a primitive type as a Char, for building a string that
  829 -- described the foreign function type.  The types are size-dependent,
  830 -- e.g. 'W' is a signed 32-bit integer.
  831 primTyDescChar :: Platform -> Type -> Char
  832 primTyDescChar platform ty
  833  | ty `eqType` unitTy = 'v'
  834  | otherwise
  835  = case typePrimRep1 (getPrimTyOf ty) of
  836      IntRep      -> signed_word
  837      WordRep     -> unsigned_word
  838      Int8Rep     -> 'B'
  839      Word8Rep    -> 'b'
  840      Int16Rep    -> 'S'
  841      Word16Rep   -> 's'
  842      Int32Rep    -> 'W'
  843      Word32Rep   -> 'w'
  844      Int64Rep    -> 'L'
  845      Word64Rep   -> 'l'
  846      AddrRep     -> 'p'
  847      FloatRep    -> 'f'
  848      DoubleRep   -> 'd'
  849      _           -> pprPanic "primTyDescChar" (ppr ty)
  850   where
  851     (signed_word, unsigned_word) = case platformWordSize platform of
  852       PW4 -> ('W','w')
  853       PW8 -> ('L','l')