never executed always true always false
    1 {-
    2 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
    3 
    4 \section[Foreign]{Foreign calls}
    5 -}
    6 
    7 {-# LANGUAGE DeriveDataTypeable #-}
    8 
    9 module GHC.Types.ForeignCall (
   10         ForeignCall(..), isSafeForeignCall,
   11         Safety(..), playSafe, playInterruptible,
   12 
   13         CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
   14         CCallSpec(..),
   15         CCallTarget(..), isDynamicTarget,
   16         CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,
   17 
   18         Header(..), CType(..),
   19     ) where
   20 
   21 import GHC.Prelude
   22 
   23 import GHC.Data.FastString
   24 import GHC.Utils.Binary
   25 import GHC.Utils.Outputable
   26 import GHC.Utils.Panic
   27 import GHC.Unit.Module
   28 import GHC.Types.SourceText ( SourceText, pprWithSourceText )
   29 
   30 import Data.Char
   31 import Data.Data
   32 
   33 {-
   34 ************************************************************************
   35 *                                                                      *
   36 \subsubsection{Data types}
   37 *                                                                      *
   38 ************************************************************************
   39 -}
   40 
   41 newtype ForeignCall = CCall CCallSpec
   42   deriving Eq
   43 
   44 isSafeForeignCall :: ForeignCall -> Bool
   45 isSafeForeignCall (CCall (CCallSpec _ _ safe)) = playSafe safe
   46 
   47 -- We may need more clues to distinguish foreign calls
   48 -- but this simple printer will do for now
   49 instance Outputable ForeignCall where
   50   ppr (CCall cc)  = ppr cc
   51 
   52 data Safety
   53   = PlaySafe          -- ^ Might invoke Haskell GC, or do a call back, or
   54                       --   switch threads, etc.  So make sure things are
   55                       --   tidy before the call. Additionally, in the threaded
   56                       --   RTS we arrange for the external call to be executed
   57                       --   by a separate OS thread, i.e., _concurrently_ to the
   58                       --   execution of other Haskell threads.
   59 
   60   | PlayInterruptible -- ^ Like PlaySafe, but additionally
   61                       --   the worker thread running this foreign call may
   62                       --   be unceremoniously killed, so it must be scheduled
   63                       --   on an unbound thread.
   64 
   65   | PlayRisky         -- ^ None of the above can happen; the call will return
   66                       --   without interacting with the runtime system at all.
   67                       --   Specifically:
   68                       --
   69                       --     * No GC
   70                       --     * No call backs
   71                       --     * No blocking
   72                       --     * No precise exceptions
   73                       --
   74   deriving ( Eq, Show, Data )
   75         -- Show used just for Show Lex.Token, I think
   76 
   77 instance Outputable Safety where
   78   ppr PlaySafe = text "safe"
   79   ppr PlayInterruptible = text "interruptible"
   80   ppr PlayRisky = text "unsafe"
   81 
   82 playSafe :: Safety -> Bool
   83 playSafe PlaySafe = True
   84 playSafe PlayInterruptible = True
   85 playSafe PlayRisky = False
   86 
   87 playInterruptible :: Safety -> Bool
   88 playInterruptible PlayInterruptible = True
   89 playInterruptible _ = False
   90 
   91 {-
   92 ************************************************************************
   93 *                                                                      *
   94 \subsubsection{Calling C}
   95 *                                                                      *
   96 ************************************************************************
   97 -}
   98 
   99 data CExportSpec
  100   = CExportStatic               -- foreign export ccall foo :: ty
  101         SourceText              -- of the CLabelString.
  102                                 -- See note [Pragma source text] in GHC.Types.SourceText
  103         CLabelString            -- C Name of exported function
  104         CCallConv
  105   deriving Data
  106 
  107 data CCallSpec
  108   =  CCallSpec  CCallTarget     -- What to call
  109                 CCallConv       -- Calling convention to use.
  110                 Safety
  111   deriving( Eq )
  112 
  113 -- The call target:
  114 
  115 -- | How to call a particular function in C-land.
  116 data CCallTarget
  117   -- An "unboxed" ccall# to named function in a particular package.
  118   = StaticTarget
  119         SourceText                -- of the CLabelString.
  120                                   -- See note [Pragma source text] in GHC.Types.SourceText
  121         CLabelString                    -- C-land name of label.
  122 
  123         (Maybe Unit)                    -- What package the function is in.
  124                                         -- If Nothing, then it's taken to be in the current package.
  125                                         -- Note: This information is only used for PrimCalls on Windows.
  126                                         --       See CLabel.labelDynamic and CoreToStg.coreToStgApp
  127                                         --       for the difference in representation between PrimCalls
  128                                         --       and ForeignCalls. If the CCallTarget is representing
  129                                         --       a regular ForeignCall then it's safe to set this to Nothing.
  130 
  131   -- The first argument of the import is the name of a function pointer (an Addr#).
  132   --    Used when importing a label as "foreign import ccall "dynamic" ..."
  133         Bool                            -- True => really a function
  134                                         -- False => a value; only
  135                                         -- allowed in CAPI imports
  136   | DynamicTarget
  137 
  138   deriving( Eq, Data )
  139 
  140 isDynamicTarget :: CCallTarget -> Bool
  141 isDynamicTarget DynamicTarget = True
  142 isDynamicTarget _             = False
  143 
  144 {-
  145 Stuff to do with calling convention:
  146 
  147 ccall:          Caller allocates parameters, *and* deallocates them.
  148 
  149 stdcall:        Caller allocates parameters, callee deallocates.
  150                 Function name has @N after it, where N is number of arg bytes
  151                 e.g.  _Foo@8. This convention is x86 (win32) specific.
  152 
  153 See: http://www.programmersheaven.com/2/Calling-conventions
  154 -}
  155 
  156 -- any changes here should be replicated in  the CallConv type in template haskell
  157 data CCallConv = CCallConv | CApiConv | StdCallConv | PrimCallConv | JavaScriptCallConv
  158   deriving (Eq, Data)
  159 
  160 instance Outputable CCallConv where
  161   ppr StdCallConv = text "stdcall"
  162   ppr CCallConv   = text "ccall"
  163   ppr CApiConv    = text "capi"
  164   ppr PrimCallConv = text "prim"
  165   ppr JavaScriptCallConv = text "javascript"
  166 
  167 defaultCCallConv :: CCallConv
  168 defaultCCallConv = CCallConv
  169 
  170 ccallConvToInt :: CCallConv -> Int
  171 ccallConvToInt StdCallConv = 0
  172 ccallConvToInt CCallConv   = 1
  173 ccallConvToInt CApiConv    = panic "ccallConvToInt CApiConv"
  174 ccallConvToInt (PrimCallConv {}) = panic "ccallConvToInt PrimCallConv"
  175 ccallConvToInt JavaScriptCallConv = panic "ccallConvToInt JavaScriptCallConv"
  176 
  177 {-
  178 Generate the gcc attribute corresponding to the given
  179 calling convention (used by PprAbsC):
  180 -}
  181 
  182 ccallConvAttribute :: CCallConv -> SDoc
  183 ccallConvAttribute StdCallConv       = text "__attribute__((__stdcall__))"
  184 ccallConvAttribute CCallConv         = empty
  185 ccallConvAttribute CApiConv          = empty
  186 ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv"
  187 ccallConvAttribute JavaScriptCallConv = panic "ccallConvAttribute JavaScriptCallConv"
  188 
  189 type CLabelString = FastString          -- A C label, completely unencoded
  190 
  191 pprCLabelString :: CLabelString -> SDoc
  192 pprCLabelString lbl = ftext lbl
  193 
  194 isCLabelString :: CLabelString -> Bool  -- Checks to see if this is a valid C label
  195 isCLabelString lbl
  196   = all ok (unpackFS lbl)
  197   where
  198     ok c = isAlphaNum c || c == '_' || c == '.'
  199         -- The '.' appears in e.g. "foo.so" in the
  200         -- module part of a ExtName.  Maybe it should be separate
  201 
  202 -- Printing into C files:
  203 
  204 instance Outputable CExportSpec where
  205   ppr (CExportStatic _ str _) = pprCLabelString str
  206 
  207 instance Outputable CCallSpec where
  208   ppr (CCallSpec fun cconv safety)
  209     = hcat [ whenPprDebug callconv, ppr_fun fun, text " ::" ]
  210     where
  211       callconv = text "{-" <> ppr cconv <> text "-}"
  212 
  213       gc_suf | playSafe safety = text "_safe"
  214              | otherwise       = text "_unsafe"
  215 
  216       ppr_fun (StaticTarget st lbl mPkgId isFun)
  217         = text (if isFun then "__ffi_static_ccall"
  218                          else "__ffi_static_ccall_value")
  219        <> gc_suf
  220        <+> (case mPkgId of
  221             Nothing -> empty
  222             Just pkgId -> ppr pkgId)
  223        <> text ":"
  224        <> ppr lbl
  225        <+> (pprWithSourceText st empty)
  226 
  227       ppr_fun DynamicTarget
  228         = text "__ffi_dyn_ccall" <> gc_suf <+> text "\"\""
  229 
  230 -- The filename for a C header file
  231 -- Note [Pragma source text] in GHC.Types.SourceText
  232 data Header = Header SourceText FastString
  233     deriving (Eq, Data)
  234 
  235 instance Outputable Header where
  236     ppr (Header st h) = pprWithSourceText st (doubleQuotes $ ppr h)
  237 
  238 -- | A C type, used in CAPI FFI calls
  239 --
  240 --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'{-\# CTYPE'@,
  241 --        'GHC.Parser.Annotation.AnnHeader','GHC.Parser.Annotation.AnnVal',
  242 --        'GHC.Parser.Annotation.AnnClose' @'\#-}'@,
  243 
  244 -- For details on above see note [exact print annotations] in "GHC.Parser.Annotation"
  245 data CType = CType SourceText -- Note [Pragma source text] in GHC.Types.SourceText
  246                    (Maybe Header) -- header to include for this type
  247                    (SourceText,FastString) -- the type itself
  248     deriving (Eq, Data)
  249 
  250 instance Outputable CType where
  251     ppr (CType stp mh (stct,ct))
  252       = pprWithSourceText stp (text "{-# CTYPE") <+> hDoc
  253         <+> pprWithSourceText stct (doubleQuotes (ftext ct)) <+> text "#-}"
  254         where hDoc = case mh of
  255                      Nothing -> empty
  256                      Just h -> ppr h
  257 
  258 {-
  259 ************************************************************************
  260 *                                                                      *
  261 \subsubsection{Misc}
  262 *                                                                      *
  263 ************************************************************************
  264 -}
  265 
  266 instance Binary ForeignCall where
  267     put_ bh (CCall aa) = put_ bh aa
  268     get bh = do aa <- get bh; return (CCall aa)
  269 
  270 instance Binary Safety where
  271     put_ bh PlaySafe =
  272             putByte bh 0
  273     put_ bh PlayInterruptible =
  274             putByte bh 1
  275     put_ bh PlayRisky =
  276             putByte bh 2
  277     get bh = do
  278             h <- getByte bh
  279             case h of
  280               0 -> return PlaySafe
  281               1 -> return PlayInterruptible
  282               _ -> return PlayRisky
  283 
  284 instance Binary CExportSpec where
  285     put_ bh (CExportStatic ss aa ab) = do
  286             put_ bh ss
  287             put_ bh aa
  288             put_ bh ab
  289     get bh = do
  290           ss <- get bh
  291           aa <- get bh
  292           ab <- get bh
  293           return (CExportStatic ss aa ab)
  294 
  295 instance Binary CCallSpec where
  296     put_ bh (CCallSpec aa ab ac) = do
  297             put_ bh aa
  298             put_ bh ab
  299             put_ bh ac
  300     get bh = do
  301           aa <- get bh
  302           ab <- get bh
  303           ac <- get bh
  304           return (CCallSpec aa ab ac)
  305 
  306 instance Binary CCallTarget where
  307     put_ bh (StaticTarget ss aa ab ac) = do
  308             putByte bh 0
  309             put_ bh ss
  310             put_ bh aa
  311             put_ bh ab
  312             put_ bh ac
  313     put_ bh DynamicTarget =
  314             putByte bh 1
  315     get bh = do
  316             h <- getByte bh
  317             case h of
  318               0 -> do ss <- get bh
  319                       aa <- get bh
  320                       ab <- get bh
  321                       ac <- get bh
  322                       return (StaticTarget ss aa ab ac)
  323               _ -> return DynamicTarget
  324 
  325 instance Binary CCallConv where
  326     put_ bh CCallConv =
  327             putByte bh 0
  328     put_ bh StdCallConv =
  329             putByte bh 1
  330     put_ bh PrimCallConv =
  331             putByte bh 2
  332     put_ bh CApiConv =
  333             putByte bh 3
  334     put_ bh JavaScriptCallConv =
  335             putByte bh 4
  336     get bh = do
  337             h <- getByte bh
  338             case h of
  339               0 -> return CCallConv
  340               1 -> return StdCallConv
  341               2 -> return PrimCallConv
  342               3 -> return CApiConv
  343               _ -> return JavaScriptCallConv
  344 
  345 instance Binary CType where
  346     put_ bh (CType s mh fs) = do put_ bh s
  347                                  put_ bh mh
  348                                  put_ bh fs
  349     get bh = do s  <- get bh
  350                 mh <- get bh
  351                 fs <- get bh
  352                 return (CType s mh fs)
  353 
  354 instance Binary Header where
  355     put_ bh (Header s h) = put_ bh s >> put_ bh h
  356     get bh = do s <- get bh
  357                 h <- get bh
  358                 return (Header s h)