{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}

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

-- | Desugaring foreign declarations
module GHC.HsToCore.Foreign.Decl
  ( dsForeigns
  )
where

import GHC.Prelude
import GHC.Data.FastString

import GHC.Tc.Utils.Monad        -- temp

import GHC.HsToCore.Foreign.C
import GHC.HsToCore.Foreign.JavaScript
import GHC.HsToCore.Foreign.Utils
import GHC.HsToCore.Monad

import GHC.Hs
import GHC.Types.Id
import GHC.Types.ForeignStubs
import GHC.Unit.Module
import GHC.Core.Coercion

import GHC.Cmm.CLabel
import GHC.Types.ForeignCall
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Driver.Session
import GHC.Platform
import GHC.Data.OrdList
import GHC.Driver.Hooks

import Data.List (unzip4)

{-
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 @GHC.HsToCore.Foreign.Call@ to deal with these.
-}

dsForeigns :: [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding)
dsForeigns :: [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding)
dsForeigns [LForeignDecl GhcTc]
fos = do
    Hooks
hooks <- forall (m :: * -> *). HasHooks m => m Hooks
getHooks
    case Hooks -> Maybe DsForeignsHook
dsForeignsHook Hooks
hooks of
        Maybe DsForeignsHook
Nothing -> [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding)
dsForeigns' [LForeignDecl GhcTc]
fos
        Just DsForeignsHook
h  -> DsForeignsHook
h [LForeignDecl GhcTc]
fos

dsForeigns' :: [LForeignDecl GhcTc]
            -> DsM (ForeignStubs, OrdList Binding)
dsForeigns' :: [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding)
dsForeigns' []
  = forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignStubs
NoStubs, forall a. OrdList a
nilOL)
dsForeigns' [LForeignDecl GhcTc]
fos = do
    Module
mod <- forall (m :: * -> *). HasModule m => m Module
getModule
    Platform
platform <- DynFlags -> Platform
targetPlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    [(CHeader, CStub, [Id], [Binding])]
fives <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {a}.
GenLocated (SrcSpanAnn' a) (ForeignDecl GhcTc)
-> DsM (CHeader, CStub, [Id], [Binding])
do_ldecl [LForeignDecl GhcTc]
fos
    let
        ([CHeader]
hs, [CStub]
cs, [[Id]]
idss, [[Binding]]
bindss) = forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 [(CHeader, CStub, [Id], [Binding])]
fives
        fe_ids :: [Id]
fe_ids = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Id]]
idss
        fe_init_code :: CStub
fe_init_code = Platform -> Module -> [Id] -> CStub
foreignExportsInitialiser Platform
platform Module
mod [Id]
fe_ids
    --
    forall (m :: * -> *) a. Monad m => a -> m a
return (CHeader -> CStub -> ForeignStubs
ForeignStubs
             (forall a. Monoid a => [a] -> a
mconcat [CHeader]
hs)
             (forall a. Monoid a => [a] -> a
mconcat [CStub]
cs forall a. Monoid a => a -> a -> a
`mappend` CStub
fe_init_code),
            forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a. OrdList a -> OrdList a -> OrdList a
appOL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> OrdList a
toOL) forall a. OrdList a
nilOL [[Binding]]
bindss)
  where
   do_ldecl :: GenLocated (SrcSpanAnn' a) (ForeignDecl GhcTc)
-> DsM (CHeader, CStub, [Id], [Binding])
do_ldecl (L SrcSpanAnn' a
loc ForeignDecl GhcTc
decl) = forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' a
loc) (ForeignDecl GhcTc -> DsM (CHeader, CStub, [Id], [Binding])
do_decl ForeignDecl GhcTc
decl)

   do_decl :: ForeignDecl GhcTc -> DsM (CHeader, CStub, [Id], [Binding])
   do_decl :: ForeignDecl GhcTc -> DsM (CHeader, CStub, [Id], [Binding])
do_decl (ForeignImport { fd_name :: forall pass. ForeignDecl pass -> LIdP pass
fd_name = LIdP GhcTc
id, fd_i_ext :: forall pass. ForeignDecl pass -> XForeignImport pass
fd_i_ext = XForeignImport GhcTc
co, fd_fi :: forall pass. ForeignDecl pass -> ForeignImport pass
fd_fi = ForeignImport GhcTc
spec }) = do
      forall m n. SDoc -> TcRnIf m n ()
traceIf (forall doc. IsLine doc => String -> doc
text String
"fi start" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr LIdP GhcTc
id)
      let id' :: Id
id' = forall l e. GenLocated l e -> e
unLoc LIdP GhcTc
id
      ([Binding]
bs, CHeader
h, CStub
c) <- forall (p :: Pass).
Id
-> Coercion
-> ForeignImport (GhcPass p)
-> DsM ([Binding], CHeader, CStub)
dsFImport Id
id' XForeignImport GhcTc
co ForeignImport GhcTc
spec
      forall m n. SDoc -> TcRnIf m n ()
traceIf (forall doc. IsLine doc => String -> doc
text String
"fi end" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr LIdP GhcTc
id)
      forall (m :: * -> *) a. Monad m => a -> m a
return (CHeader
h, CStub
c, [], [Binding]
bs)

   do_decl (ForeignExport { fd_name :: forall pass. ForeignDecl pass -> LIdP pass
fd_name = L SrcSpanAnnN
_ Id
id
                          , fd_e_ext :: forall pass. ForeignDecl pass -> XForeignExport pass
fd_e_ext = XForeignExport GhcTc
co
                          , fd_fe :: forall pass. ForeignDecl pass -> ForeignExport pass
fd_fe = CExport XCExport GhcTc
_
                              (L SrcSpan
_ (CExportStatic SourceText
_ CLabelString
ext_nm CCallConv
cconv)) }) = do
      (CHeader
h, CStub
c, String
_, Int
_) <- Id
-> Coercion
-> CLabelString
-> CCallConv
-> Bool
-> DsM (CHeader, CStub, String, Int)
dsFExport Id
id XForeignExport GhcTc
co CLabelString
ext_nm CCallConv
cconv Bool
False
      forall (m :: * -> *) a. Monad m => a -> m a
return (CHeader
h, CStub
c, [Id
id], [])

{-
************************************************************************
*                                                                      *
\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 (GhcPass p)
          -> DsM ([Binding], CHeader, CStub)
dsFImport :: forall (p :: Pass).
Id
-> Coercion
-> ForeignImport (GhcPass p)
-> DsM ([Binding], CHeader, CStub)
dsFImport Id
id Coercion
co (CImport XCImport (GhcPass p)
_ XRec (GhcPass p) CCallConv
cconv XRec (GhcPass p) Safety
safety Maybe Header
mHeader CImportSpec
spec) = do
  Platform
platform <- forall a b. TcRnIf a b Platform
getPlatform
  case Platform -> Arch
platformArch Platform
platform of
    Arch
ArchJavaScript -> Id
-> Coercion
-> CImportSpec
-> CCallConv
-> Safety
-> Maybe Header
-> DsM ([Binding], CHeader, CStub)
dsJsImport Id
id Coercion
co CImportSpec
spec (forall l e. GenLocated l e -> e
unLoc XRec (GhcPass p) CCallConv
cconv) (forall l e. GenLocated l e -> e
unLoc XRec (GhcPass p) Safety
safety) Maybe Header
mHeader
    Arch
_              -> Id
-> Coercion
-> CImportSpec
-> CCallConv
-> Safety
-> Maybe Header
-> DsM ([Binding], CHeader, CStub)
dsCImport  Id
id Coercion
co CImportSpec
spec (forall l e. GenLocated l e -> e
unLoc XRec (GhcPass p) CCallConv
cconv) (forall l e. GenLocated l e -> e
unLoc XRec (GhcPass p) Safety
safety) Maybe Header
mHeader

{-
************************************************************************
*                                                                      *
\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 ( CHeader      -- contents of Module_stub.h
                 , CStub        -- contents of Module_stub.c
                 , String       -- string describing type to pass to createAdj.
                 , Int          -- size of args to stub function
                 )
dsFExport :: Id
-> Coercion
-> CLabelString
-> CCallConv
-> Bool
-> DsM (CHeader, CStub, String, Int)
dsFExport Id
fn_id Coercion
co CLabelString
ext_name CCallConv
cconv Bool
is_dyn = do
  Platform
platform <- forall a b. TcRnIf a b Platform
getPlatform
  case Platform -> Arch
platformArch Platform
platform of
    Arch
ArchJavaScript -> Id
-> Coercion
-> CLabelString
-> CCallConv
-> Bool
-> DsM (CHeader, CStub, String, Int)
dsJsFExport Id
fn_id Coercion
co CLabelString
ext_name CCallConv
cconv Bool
is_dyn
    Arch
_              -> Id
-> Coercion
-> CLabelString
-> CCallConv
-> Bool
-> DsM (CHeader, CStub, String, Int)
dsCFExport  Id
fn_id Coercion
co CLabelString
ext_name CCallConv
cconv Bool
is_dyn


foreignExportsInitialiser :: Platform -> Module -> [Id] -> CStub
foreignExportsInitialiser :: Platform -> Module -> [Id] -> CStub
foreignExportsInitialiser Platform
_        Module
_   []     = forall a. Monoid a => a
mempty
foreignExportsInitialiser Platform
platform Module
mod [Id]
hs_fns =
   -- 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)
   --
   -- See Note [Tracking foreign exports] in rts/ForeignExports.c
   Platform -> CLabel -> SDoc -> SDoc -> CStub
initializerCStub Platform
platform CLabel
fn_nm SDoc
list_decl SDoc
fn_body
  where
    fn_nm :: CLabel
fn_nm       = Module -> CLabelString -> CLabel
mkInitializerStubLabel Module
mod (String -> CLabelString
fsLit String
"fexports")
    mod_str :: SDoc
mod_str     = forall doc. IsLine doc => ModuleName -> doc
pprModuleName (forall unit. GenModule unit -> ModuleName
moduleName Module
mod)
    fn_body :: SDoc
fn_body     = forall doc. IsLine doc => String -> doc
text String
"registerForeignExports" forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc -> doc
parens (forall doc. IsLine doc => Char -> doc
char Char
'&' forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
list_symbol) forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
semi
    list_symbol :: SDoc
list_symbol = forall doc. IsLine doc => String -> doc
text String
"stg_exports_" forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
mod_str
    list_decl :: SDoc
list_decl   = forall doc. IsLine doc => String -> doc
text String
"static struct ForeignExportsList" forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
list_symbol forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => doc
equals
         forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => doc -> doc
braces (
           forall doc. IsLine doc => String -> doc
text String
".exports = " forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
export_list forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
comma forall doc. IsLine doc => doc -> doc -> doc
<+>
           forall doc. IsLine doc => String -> doc
text String
".n_entries = " forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
hs_fns))
         forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
semi

    export_list :: SDoc
export_list = forall doc. IsLine doc => doc -> doc
braces forall a b. (a -> b) -> a -> b
$ forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas Id -> SDoc
closure_ptr [Id]
hs_fns

    closure_ptr :: Id -> SDoc
    closure_ptr :: Id -> SDoc
closure_ptr Id
fn = forall doc. IsLine doc => String -> doc
text String
"(StgPtr) &" forall doc. IsLine doc => doc -> doc -> doc
<> forall a. Outputable a => a -> SDoc
ppr Id
fn forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => String -> doc
text String
"_closure"