X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Fprelude%2FForeignCall.lhs;h=12b85b1c03f8d7c7d71455ddf02997d47c7506e3;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=81d57052e21aebda01d879c5a93ad29e919be89b;hpb=b085ee40c7f265a5977ea6ec1c415e573be5ff8c;p=ghc-hetmet.git diff --git a/ghc/compiler/prelude/ForeignCall.lhs b/ghc/compiler/prelude/ForeignCall.lhs index 81d5705..12b85b1 100644 --- a/ghc/compiler/prelude/ForeignCall.lhs +++ b/ghc/compiler/prelude/ForeignCall.lhs @@ -1,5 +1,3 @@ -{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-} -{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-} % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % @@ -10,20 +8,19 @@ module ForeignCall ( ForeignCall(..), Safety(..), playSafe, playThreadSafe, - CExportSpec(..), + CExportSpec(..), CLabelString, isCLabelString, pprCLabelString, CCallSpec(..), - CCallTarget(..), isDynamicTarget, isCasmTarget, + CCallTarget(..), isDynamicTarget, CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute, - DNCallSpec(..), - - okToExposeFCall + DNCallSpec(..), DNKind(..), DNType(..), + withDNTypes ) where #include "HsVersions.h" -import CStrings ( CLabelString, pprCLabelString ) -import FastString ( FastString ) +import FastString ( FastString, unpackFS ) +import Char ( isAlphaNum ) import Binary import Outputable \end{code} @@ -109,16 +106,12 @@ The call target: data CCallTarget = StaticTarget CLabelString -- An "unboxed" ccall# to `fn'. | DynamicTarget -- First argument (an Addr#) is the function pointer - | CasmTarget CLabelString -- Inline C code (now seriously deprecated) deriving( Eq ) {-! derive: Binary !-} -isDynamicTarget, isCasmTarget :: CCallTarget -> Bool +isDynamicTarget :: CCallTarget -> Bool isDynamicTarget DynamicTarget = True isDynamicTarget other = False - -isCasmTarget (CasmTarget _) = True -isCasmTarget other = False \end{code} @@ -160,6 +153,22 @@ ccallConvAttribute StdCallConv = "__stdcall" ccallConvAttribute CCallConv = "" \end{code} +\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} + + Printing into C files: \begin{code} @@ -177,23 +186,67 @@ instance Outputable CCallSpec where ppr_fun DynamicTarget = text "__dyn_ccall" <> gc_suf <+> text "\"\"" ppr_fun (StaticTarget fn) = text "__ccall" <> gc_suf <+> pprCLabelString fn - ppr_fun (CasmTarget fn) = text "__casm" <> gc_suf <+> text "``" <> pprCLabelString fn <> text "''" \end{code} %************************************************************************ %* * -\subsubsection{.NET stuff} +\subsubsection{.NET interop} %* * %************************************************************************ \begin{code} -data DNCallSpec = DNCallSpec FastString - deriving (Eq) +data DNCallSpec = + DNCallSpec Bool -- True => static method/field + DNKind -- what type of access + String -- assembly + String -- fully qualified method/field name. + [DNType] -- argument types. + DNType -- result type. + deriving ( Eq ) + {-! derive: Binary !-} + +data DNKind + = DNMethod + | DNField + | DNConstructor + deriving ( Eq ) {-! derive: Binary !-} +data DNType + = DNByte + | DNBool + | DNChar + | DNDouble + | DNFloat + | DNInt + | DNInt8 + | DNInt16 + | DNInt32 + | DNInt64 + | DNWord8 + | DNWord16 + | DNWord32 + | DNWord64 + | DNPtr + | DNUnit + | DNObject + | DNString + deriving ( Eq ) + {-! derive: Binary !-} + +withDNTypes :: DNCallSpec -> [DNType] -> DNType -> DNCallSpec +withDNTypes (DNCallSpec isStatic k assem nm _ _) argTys resTy + = DNCallSpec isStatic k assem nm argTys resTy + instance Outputable DNCallSpec where - ppr (DNCallSpec s) = char '"' <> ftext s <> char '"' + ppr (DNCallSpec isStatic kind ass nm _ _ ) + = char '"' <> + (if isStatic then text "static" else empty) <+> + (text (case kind of { DNMethod -> "method" ; DNField -> "field"; DNConstructor -> "ctor" })) <+> + (if null ass then char ' ' else char '[' <> text ass <> char ']') <> + text nm <> + char '"' \end{code} @@ -205,13 +258,6 @@ instance Outputable DNCallSpec where %************************************************************************ \begin{code} -okToExposeFCall :: ForeignCall -> Bool --- OK to unfold a Foreign Call in an interface file --- Yes, unless it's a _casm_ -okToExposeFCall (CCall (CCallSpec target _ _)) = not (isCasmTarget target) -okToExposeFCall other = True -\end{code} -\begin{code} {-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-} instance Binary ForeignCall where put_ bh (CCall aa) = do @@ -267,17 +313,12 @@ instance Binary CCallTarget where put_ bh aa put_ bh DynamicTarget = do putByte bh 1 - put_ bh (CasmTarget ab) = do - putByte bh 2 - put_ bh ab get bh = do h <- getByte bh case h of 0 -> do aa <- get bh return (StaticTarget aa) - 1 -> do return DynamicTarget - _ -> do ab <- get bh - return (CasmTarget ab) + _ -> do return DynamicTarget instance Binary CCallConv where put_ bh CCallConv = do @@ -291,11 +332,91 @@ instance Binary CCallConv where _ -> do return StdCallConv instance Binary DNCallSpec where - put_ bh (DNCallSpec aa) = do - put_ bh aa + put_ bh (DNCallSpec isStatic kind ass nm _ _) = do + put_ bh isStatic + put_ bh kind + put_ bh ass + put_ bh nm get bh = do - aa <- get bh - return (DNCallSpec aa) + isStatic <- get bh + kind <- get bh + ass <- get bh + nm <- get bh + return (DNCallSpec isStatic kind ass nm [] undefined) + +instance Binary DNKind where + put_ bh DNMethod = do + putByte bh 0 + put_ bh DNField = do + putByte bh 1 + put_ bh DNConstructor = do + putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> do return DNMethod + 1 -> do return DNField + _ -> do return DNConstructor + +instance Binary DNType where + put_ bh DNByte = do + putByte bh 0 + put_ bh DNBool = do + putByte bh 1 + put_ bh DNChar = do + putByte bh 2 + put_ bh DNDouble = do + putByte bh 3 + put_ bh DNFloat = do + putByte bh 4 + put_ bh DNInt = do + putByte bh 5 + put_ bh DNInt8 = do + putByte bh 6 + put_ bh DNInt16 = do + putByte bh 7 + put_ bh DNInt32 = do + putByte bh 8 + put_ bh DNInt64 = do + putByte bh 9 + put_ bh DNWord8 = do + putByte bh 10 + put_ bh DNWord16 = do + putByte bh 11 + put_ bh DNWord32 = do + putByte bh 12 + put_ bh DNWord64 = do + putByte bh 13 + put_ bh DNPtr = do + putByte bh 14 + put_ bh DNUnit = do + putByte bh 15 + put_ bh DNObject = do + putByte bh 16 + put_ bh DNString = do + putByte bh 17 + + get bh = do + h <- getByte bh + case h of + 0 -> return DNByte + 1 -> return DNBool + 2 -> return DNChar + 3 -> return DNDouble + 4 -> return DNFloat + 5 -> return DNInt + 6 -> return DNInt8 + 7 -> return DNInt16 + 8 -> return DNInt32 + 9 -> return DNInt64 + 10 -> return DNWord8 + 11 -> return DNWord16 + 12 -> return DNWord32 + 13 -> return DNWord64 + 14 -> return DNPtr + 15 -> return DNUnit + 16 -> return DNObject + 17 -> return DNString -- Imported from other files :-