ForeignCall.lhs 7.93 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,
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

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

instance Outputable Safety where
Ian Lynagh's avatar
Ian Lynagh committed
73 74 75
  ppr (PlaySafe False) = ptext (sLit "safe")
  ppr (PlaySafe True)  = ptext (sLit "threadsafe")
  ppr PlayRisky = ptext (sLit "unsafe")
76

sof's avatar
sof committed
77 78 79
playSafe :: Safety -> Bool
playSafe PlaySafe{} = True
playSafe PlayRisky  = False
80 81 82 83 84 85 86 87 88 89
\end{code}


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

\begin{code}
90 91 92 93
data CExportSpec
  = CExportStatic		-- foreign export ccall foo :: ty
	CLabelString		-- C Name of exported function
	CCallConv
94
  deriving (Data, Typeable)
95
  {-! derive: Binary !-}
96

97 98 99 100 101
data CCallSpec
  =  CCallSpec	CCallTarget	-- What to call
		CCallConv	-- Calling convention to use.
		Safety
  deriving( Eq )
102
  {-! derive: Binary !-}
103 104 105 106 107
\end{code}

The call target:

\begin{code}
108

109
-- | How to call a particular function in C-land.
110
data CCallTarget
111 112 113 114 115 116 117 118 119 120 121
  -- 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.
122 123 124 125 126

  -- 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
  
127
  deriving( Eq, Data, Typeable )
128
  {-! derive: Binary !-}
129

130
isDynamicTarget :: CCallTarget -> Bool
131
isDynamicTarget DynamicTarget = True
Ian Lynagh's avatar
Ian Lynagh committed
132
isDynamicTarget _             = False
133 134 135
\end{code}


136 137 138 139 140 141 142 143 144 145 146
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.
147 148
 
See: http://www.programmersheaven.com/2/Calling-conventions
149 150

\begin{code}
151
data CCallConv = CCallConv | StdCallConv | CmmCallConv | PrimCallConv
152
  deriving (Eq, Data, Typeable)
153
  {-! derive: Binary !-}
154 155

instance Outputable CCallConv where
Ian Lynagh's avatar
Ian Lynagh committed
156 157 158
  ppr StdCallConv = ptext (sLit "stdcall")
  ppr CCallConv   = ptext (sLit "ccall")
  ppr CmmCallConv = ptext (sLit "C--")
159
  ppr PrimCallConv = ptext (sLit "prim")
160 161 162 163 164 165 166 167 168 169 170 171 172 173

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
174
ccallConvAttribute StdCallConv = "__attribute__((__stdcall__))"
175 176 177
ccallConvAttribute CCallConv   = ""
\end{code}

178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193
\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}


194 195 196
Printing into C files:

\begin{code}
197 198 199
instance Outputable CExportSpec where
  ppr (CExportStatic str _) = pprCLabelString str

200
instance Outputable CCallSpec where
201 202
  ppr (CCallSpec fun cconv safety)
    = hcat [ ifPprDebug callconv, ppr_fun fun ]
203
    where
204 205 206 207 208
      callconv = text "{-" <> ppr cconv <> text "-}"

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

209
      ppr_fun (StaticTarget fn Nothing)
210 211
     	= text "__pkg_ccall" <> gc_suf <+> pprCLabelString fn

212
      ppr_fun (StaticTarget fn (Just pkgId))
213 214
     	= text "__pkg_ccall" <> gc_suf <+> ppr pkgId <+> pprCLabelString fn

215 216
      ppr_fun DynamicTarget     
        = text "__dyn_ccall" <> gc_suf <+> text "\"\""
217 218 219
\end{code}


220 221 222 223 224 225
%************************************************************************
%*									*
\subsubsection{Misc}
%*									*
%************************************************************************

226 227 228
\begin{code}
{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
instance Binary ForeignCall where
229 230
    put_ bh (CCall aa) = put_ bh aa
    get bh = do aa <- get bh; return (CCall aa)
231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265

instance Binary Safety where
    put_ bh (PlaySafe aa) = do
	    putByte bh 0
	    put_ bh aa
    put_ bh PlayRisky = do
	    putByte bh 1
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do aa <- get bh
		      return (PlaySafe aa)
	      _ -> 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
266
    put_ bh (StaticTarget aa ab) = do
267 268
	    putByte bh 0
	    put_ bh aa
269
            put_ bh ab
270 271 272 273 274 275
    put_ bh DynamicTarget = do
	    putByte bh 1
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do aa <- get bh
276 277 278
                      ab <- get bh
		      return (StaticTarget aa ab)
	      _ -> do return DynamicTarget
279 280 281 282 283 284

instance Binary CCallConv where
    put_ bh CCallConv = do
	    putByte bh 0
    put_ bh StdCallConv = do
	    putByte bh 1
285 286
    put_ bh PrimCallConv = do
	    putByte bh 2
287 288 289 290
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do return CCallConv
291 292
	      1 -> do return StdCallConv
	      _ -> do return PrimCallConv
293
\end{code}