2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[Foreign]{Foreign calls}
8 -- The above warning supression flag is a temporary kludge.
9 -- While working on this module you are encouraged to remove it and fix
10 -- any warnings in the module. See
11 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
18 CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
20 CCallTarget(..), isDynamicTarget,
21 CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,
33 %************************************************************************
35 \subsubsection{Data types}
37 %************************************************************************
40 newtype ForeignCall = CCall CCallSpec
42 {-! derive: Binary !-}
44 -- We may need more clues to distinguish foreign calls
45 -- but this simple printer will do for now
46 instance Outputable ForeignCall where
47 ppr (CCall cc) = ppr cc
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.
60 Bool -- Indicates the deprecated "threadsafe" annotation
61 -- which is now an alias for "safe". This information
62 -- is never used except to emit a deprecation warning.
64 | PlayRisky -- None of the above can happen; the call will return
65 -- without interacting with the runtime system at all
67 -- Show used just for Show Lex.Token, I think
68 {-! derive: Binary !-}
70 instance Outputable Safety where
71 ppr (PlaySafe False) = ptext (sLit "safe")
72 ppr (PlaySafe True) = ptext (sLit "threadsafe")
73 ppr PlayRisky = ptext (sLit "unsafe")
75 playSafe :: Safety -> Bool
76 playSafe PlaySafe{} = True
77 playSafe PlayRisky = False
81 %************************************************************************
83 \subsubsection{Calling C}
85 %************************************************************************
89 = CExportStatic -- foreign export ccall foo :: ty
90 CLabelString -- C Name of exported function
92 {-! derive: Binary !-}
95 = CCallSpec CCallTarget -- What to call
96 CCallConv -- Calling convention to use.
99 {-! derive: Binary !-}
106 -- | How to call a particular function in C land.
108 -- An "unboxed" ccall# to named function
109 = StaticTarget CLabelString
111 -- The first argument of the import is the name of a function pointer (an Addr#).
112 -- Used when importing a label as "foreign import ccall "dynamic" ..."
115 -- An "unboxed" ccall# to a named function from a particular package.
116 | PackageTarget CLabelString (Maybe PackageId)
119 {-! derive: Binary !-}
121 isDynamicTarget :: CCallTarget -> Bool
122 isDynamicTarget DynamicTarget = True
123 isDynamicTarget _ = False
127 Stuff to do with calling convention:
129 ccall: Caller allocates parameters, *and* deallocates them.
131 stdcall: Caller allocates parameters, callee deallocates.
132 Function name has @N after it, where N is number of arg bytes
135 ToDo: The stdcall calling convention is x86 (win32) specific,
136 so perhaps we should emit a warning if it's being used on other
139 See: http://www.programmersheaven.com/2/Calling-conventions
142 data CCallConv = CCallConv | StdCallConv | CmmCallConv | PrimCallConv
144 {-! derive: Binary !-}
146 instance Outputable CCallConv where
147 ppr StdCallConv = ptext (sLit "stdcall")
148 ppr CCallConv = ptext (sLit "ccall")
149 ppr CmmCallConv = ptext (sLit "C--")
150 ppr PrimCallConv = ptext (sLit "prim")
152 defaultCCallConv :: CCallConv
153 defaultCCallConv = CCallConv
155 ccallConvToInt :: CCallConv -> Int
156 ccallConvToInt StdCallConv = 0
157 ccallConvToInt CCallConv = 1
160 Generate the gcc attribute corresponding to the given
161 calling convention (used by PprAbsC):
164 ccallConvAttribute :: CCallConv -> String
165 ccallConvAttribute StdCallConv = "__attribute__((__stdcall__))"
166 ccallConvAttribute CCallConv = ""
170 type CLabelString = FastString -- A C label, completely unencoded
172 pprCLabelString :: CLabelString -> SDoc
173 pprCLabelString lbl = ftext lbl
175 isCLabelString :: CLabelString -> Bool -- Checks to see if this is a valid C label
177 = all ok (unpackFS lbl)
179 ok c = isAlphaNum c || c == '_' || c == '.'
180 -- The '.' appears in e.g. "foo.so" in the
181 -- module part of a ExtName. Maybe it should be separate
185 Printing into C files:
188 instance Outputable CExportSpec where
189 ppr (CExportStatic str _) = pprCLabelString str
191 instance Outputable CCallSpec where
192 ppr (CCallSpec fun cconv safety)
193 = hcat [ ifPprDebug callconv, ppr_fun fun ]
195 callconv = text "{-" <> ppr cconv <> text "-}"
197 gc_suf | playSafe safety = text "_GC"
200 ppr_fun DynamicTarget
201 = text "__dyn_ccall" <> gc_suf <+> text "\"\""
203 ppr_fun (PackageTarget fn Nothing)
204 = text "__pkg_ccall" <> gc_suf <+> pprCLabelString fn
206 ppr_fun (PackageTarget fn (Just pkgId))
207 = text "__pkg_ccall" <> gc_suf <+> ppr pkgId <+> pprCLabelString fn
209 ppr_fun (StaticTarget fn)
210 = text "__ccall" <> gc_suf <+> pprCLabelString fn
214 %************************************************************************
218 %************************************************************************
221 {-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
222 instance Binary ForeignCall where
223 put_ bh (CCall aa) = put_ bh aa
224 get bh = do aa <- get bh; return (CCall aa)
226 instance Binary Safety where
227 put_ bh (PlaySafe aa) = do
230 put_ bh PlayRisky = do
237 _ -> do return PlayRisky
239 instance Binary CExportSpec where
240 put_ bh (CExportStatic aa ab) = do
246 return (CExportStatic aa ab)
248 instance Binary CCallSpec where
249 put_ bh (CCallSpec aa ab ac) = do
257 return (CCallSpec aa ab ac)
259 instance Binary CCallTarget where
260 put_ bh (StaticTarget aa) = do
263 put_ bh DynamicTarget = do
265 put_ bh (PackageTarget aa ab) = do
273 return (StaticTarget aa)
274 1 -> do return DynamicTarget
277 return (PackageTarget aa ab)
279 instance Binary CCallConv where
280 put_ bh CCallConv = do
282 put_ bh StdCallConv = do
284 put_ bh PrimCallConv = do
289 0 -> do return CCallConv
290 1 -> do return StdCallConv
291 _ -> do return PrimCallConv