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