ForeignCall.lhs 8.49 KB
Newer Older
1 2 3 4 5 6
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[Foreign]{Foreign calls}

\begin{code}
7
{-# OPTIONS -w #-}
8 9 10
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
Ian Lynagh's avatar
Ian Lynagh committed
11
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
12
-- for details
13
{-# LANGUAGE DeriveDataTypeable #-}
14

15 16
module ForeignCall (
	ForeignCall(..),
17
	Safety(..), playSafe, playInterruptible,
18

19
	CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
20
	CCallSpec(..), 
21
	CCallTarget(..), isDynamicTarget,
22 23 24
	CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,
    ) where

25
import FastString
26
import Binary
27
import Outputable
28
import Module
Ian Lynagh's avatar
Ian Lynagh committed
29 30

import Data.Char
31
import Data.Data
32 33 34 35 36 37 38 39 40 41
\end{code}


%************************************************************************
%*									*
\subsubsection{Data types}
%*									*
%************************************************************************

\begin{code}
42 43
newtype ForeignCall = CCall CCallSpec
  deriving Eq
44
  {-! derive: Binary !-}
45 46 47 48

-- We may need more clues to distinguish foreign calls
-- but this simple printer will do for now
instance Outputable ForeignCall where
chak's avatar
chak committed
49
  ppr (CCall cc)  = ppr cc		
50 51 52 53 54 55 56
\end{code}

  
\begin{code}
data Safety
  = PlaySafe		-- Might invoke Haskell GC, or do a call back, or
			-- switch threads, etc.  So make sure things are
57 58 59 60 61 62 63 64
			-- tidy before the call. Additionally, in the threaded
			-- RTS we arrange for the external call to be executed
			-- by a separate OS thread, i.e., _concurrently_ to the
			-- execution of other Haskell threads.

      Bool              -- Indicates the deprecated "threadsafe" annotation
                        -- which is now an alias for "safe". This information
                        -- is never used except to emit a deprecation warning.
65

66 67 68 69 70
  | PlayInterruptible   -- Like PlaySafe, but additionally
                        -- the worker thread running this foreign call may
                        -- be unceremoniously killed, so it must be scheduled
                        -- on an unbound thread.

71 72
  | PlayRisky		-- None of the above can happen; the call will return
			-- without interacting with the runtime system at all
73
  deriving ( Eq, Show, Data, Typeable )
74
	-- Show used just for Show Lex.Token, I think
75
  {-! derive: Binary !-}
76 77

instance Outputable Safety where
Ian Lynagh's avatar
Ian Lynagh committed
78 79
  ppr (PlaySafe False) = ptext (sLit "safe")
  ppr (PlaySafe True)  = ptext (sLit "threadsafe")
80
  ppr PlayInterruptible = ptext (sLit "interruptible")
Ian Lynagh's avatar
Ian Lynagh committed
81
  ppr PlayRisky = ptext (sLit "unsafe")
82

sof's avatar
sof committed
83 84
playSafe :: Safety -> Bool
playSafe PlaySafe{} = True
85
playSafe PlayInterruptible = True
sof's avatar
sof committed
86
playSafe PlayRisky  = False
87 88 89 90

playInterruptible :: Safety -> Bool
playInterruptible PlayInterruptible = True
playInterruptible _ = False
91 92 93 94 95 96 97 98 99 100
\end{code}


%************************************************************************
%*									*
\subsubsection{Calling C}
%*									*
%************************************************************************

\begin{code}
101 102 103 104
data CExportSpec
  = CExportStatic		-- foreign export ccall foo :: ty
	CLabelString		-- C Name of exported function
	CCallConv
105
  deriving (Data, Typeable)
106
  {-! derive: Binary !-}
107

108 109 110 111 112
data CCallSpec
  =  CCallSpec	CCallTarget	-- What to call
		CCallConv	-- Calling convention to use.
		Safety
  deriving( Eq )
113
  {-! derive: Binary !-}
114 115 116 117 118
\end{code}

The call target:

\begin{code}
119

120
-- | How to call a particular function in C-land.
121
data CCallTarget
122 123 124 125 126 127 128 129 130 131 132
  -- An "unboxed" ccall# to named function in a particular package.
  = StaticTarget  
	CLabelString  			-- C-land name of label.

	(Maybe PackageId)		-- What package the function is in.
					-- If Nothing, then it's taken to be in the current package.
					-- Note: This information is only used for PrimCalls on Windows.
					--	 See CLabel.labelDynamic and CoreToStg.coreToStgApp 
					--	 for the difference in representation between PrimCalls
					--	 and ForeignCalls. If the CCallTarget is representing
					--	 a regular ForeignCall then it's safe to set this to Nothing.
133 134 135 136 137

  -- The first argument of the import is the name of a function pointer (an Addr#).
  --	Used when importing a label as "foreign import ccall "dynamic" ..."
  | DynamicTarget
  
138
  deriving( Eq, Data, Typeable )
139
  {-! derive: Binary !-}
140

141
isDynamicTarget :: CCallTarget -> Bool
142
isDynamicTarget DynamicTarget = True
Ian Lynagh's avatar
Ian Lynagh committed
143
isDynamicTarget _             = False
144 145 146
\end{code}


147 148 149 150 151 152 153 154 155 156 157
Stuff to do with calling convention:

ccall:		Caller allocates parameters, *and* deallocates them.

stdcall: 	Caller allocates parameters, callee deallocates.
		Function name has @N after it, where N is number of arg bytes
		e.g.  _Foo@8

ToDo: The stdcall calling convention is x86 (win32) specific,
so perhaps we should emit a warning if it's being used on other
platforms.
158 159
 
See: http://www.programmersheaven.com/2/Calling-conventions
160 161

\begin{code}
162
data CCallConv = CCallConv | StdCallConv | CmmCallConv | PrimCallConv
163
  deriving (Eq, Data, Typeable)
164
  {-! derive: Binary !-}
165 166

instance Outputable CCallConv where
Ian Lynagh's avatar
Ian Lynagh committed
167 168 169
  ppr StdCallConv = ptext (sLit "stdcall")
  ppr CCallConv   = ptext (sLit "ccall")
  ppr CmmCallConv = ptext (sLit "C--")
170
  ppr PrimCallConv = ptext (sLit "prim")
171 172 173 174 175 176 177 178 179 180 181 182 183 184

defaultCCallConv :: CCallConv
defaultCCallConv = CCallConv

ccallConvToInt :: CCallConv -> Int
ccallConvToInt StdCallConv = 0
ccallConvToInt CCallConv   = 1
\end{code}

Generate the gcc attribute corresponding to the given
calling convention (used by PprAbsC):

\begin{code}
ccallConvAttribute :: CCallConv -> String
185
ccallConvAttribute StdCallConv = "__attribute__((__stdcall__))"
186 187 188
ccallConvAttribute CCallConv   = ""
\end{code}

189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204
\begin{code}
type CLabelString = FastString		-- A C label, completely unencoded

pprCLabelString :: CLabelString -> SDoc
pprCLabelString lbl = ftext lbl

isCLabelString :: CLabelString -> Bool	-- Checks to see if this is a valid C label
isCLabelString lbl 
  = all ok (unpackFS lbl)
  where
    ok c = isAlphaNum c || c == '_' || c == '.'
	-- The '.' appears in e.g. "foo.so" in the 
	-- module part of a ExtName.  Maybe it should be separate
\end{code}


205 206 207
Printing into C files:

\begin{code}
208 209 210
instance Outputable CExportSpec where
  ppr (CExportStatic str _) = pprCLabelString str

211
instance Outputable CCallSpec where
212 213
  ppr (CCallSpec fun cconv safety)
    = hcat [ ifPprDebug callconv, ppr_fun fun ]
214
    where
215 216 217 218 219
      callconv = text "{-" <> ppr cconv <> text "-}"

      gc_suf | playSafe safety = text "_GC"
	     | otherwise       = empty

220
      ppr_fun (StaticTarget fn Nothing)
221 222
     	= text "__pkg_ccall" <> gc_suf <+> pprCLabelString fn

223
      ppr_fun (StaticTarget fn (Just pkgId))
224 225
     	= text "__pkg_ccall" <> gc_suf <+> ppr pkgId <+> pprCLabelString fn

226 227
      ppr_fun DynamicTarget     
        = text "__dyn_ccall" <> gc_suf <+> text "\"\""
228 229 230
\end{code}


231 232 233 234 235 236
%************************************************************************
%*									*
\subsubsection{Misc}
%*									*
%************************************************************************

237 238 239
\begin{code}
{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
instance Binary ForeignCall where
240 241
    put_ bh (CCall aa) = put_ bh aa
    get bh = do aa <- get bh; return (CCall aa)
242 243 244 245 246

instance Binary Safety where
    put_ bh (PlaySafe aa) = do
	    putByte bh 0
	    put_ bh aa
247
    put_ bh PlayInterruptible = do
248
	    putByte bh 1
249 250
    put_ bh PlayRisky = do
	    putByte bh 2
251 252 253 254 255
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do aa <- get bh
		      return (PlaySafe aa)
256
	      1 -> do return PlayInterruptible
257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279
	      _ -> do return PlayRisky

instance Binary CExportSpec where
    put_ bh (CExportStatic aa ab) = do
	    put_ bh aa
	    put_ bh ab
    get bh = do
	  aa <- get bh
	  ab <- get bh
	  return (CExportStatic aa ab)

instance Binary CCallSpec where
    put_ bh (CCallSpec aa ab ac) = do
	    put_ bh aa
	    put_ bh ab
	    put_ bh ac
    get bh = do
	  aa <- get bh
	  ab <- get bh
	  ac <- get bh
	  return (CCallSpec aa ab ac)

instance Binary CCallTarget where
280
    put_ bh (StaticTarget aa ab) = do
281 282
	    putByte bh 0
	    put_ bh aa
283
            put_ bh ab
284 285 286 287 288 289
    put_ bh DynamicTarget = do
	    putByte bh 1
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do aa <- get bh
290 291 292
                      ab <- get bh
		      return (StaticTarget aa ab)
	      _ -> do return DynamicTarget
293 294 295 296 297 298

instance Binary CCallConv where
    put_ bh CCallConv = do
	    putByte bh 0
    put_ bh StdCallConv = do
	    putByte bh 1
299 300
    put_ bh PrimCallConv = do
	    putByte bh 2
301 302 303 304
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do return CCallConv
305 306
	      1 -> do return StdCallConv
	      _ -> do return PrimCallConv
307
\end{code}