X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fprelude%2FForeignCall.lhs;h=12b85b1c03f8d7c7d71455ddf02997d47c7506e3;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=f469fa3336c86b7a52012aceaa6335a08324a384;hpb=f16228e47dbaf4c5eb710bf507b3b61bc5ad7122;p=ghc-hetmet.git diff --git a/ghc/compiler/prelude/ForeignCall.lhs b/ghc/compiler/prelude/ForeignCall.lhs index f469fa3..12b85b1 100644 --- a/ghc/compiler/prelude/ForeignCall.lhs +++ b/ghc/compiler/prelude/ForeignCall.lhs @@ -6,18 +6,22 @@ \begin{code} module ForeignCall ( ForeignCall(..), - Safety(..), playSafe, + Safety(..), playSafe, playThreadSafe, - CCallSpec(..), ccallIsCasm, - CCallTarget(..), dynamicTarget, isDynamicTarget, + CExportSpec(..), CLabelString, isCLabelString, pprCLabelString, + CCallSpec(..), + CCallTarget(..), isDynamicTarget, CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute, - DotNetCallSpec(..) + DNCallSpec(..), DNKind(..), DNType(..), + withDNTypes ) where #include "HsVersions.h" -import CStrings ( CLabelString, pprCLabelString ) +import FastString ( FastString, unpackFS ) +import Char ( isAlphaNum ) +import Binary import Outputable \end{code} @@ -31,15 +35,16 @@ import Outputable \begin{code} data ForeignCall = CCall CCallSpec - | DotNetCall DotNetCallSpec + | DNCall DNCallSpec deriving( Eq ) -- We compare them when seeing if an interface -- has changed (for versioning purposes) + {-! derive: Binary !-} -- We may need more clues to distinguish foreign calls -- but this simple printer will do for now instance Outputable ForeignCall where - ppr (CCall cc) = ppr cc - ppr (DotNetCall dn) = ppr dn + ppr (CCall cc) = ppr cc + ppr (DNCall dn) = ppr dn \end{code} @@ -48,18 +53,29 @@ data Safety = PlaySafe -- Might invoke Haskell GC, or do a call back, or -- switch threads, etc. So make sure things are -- tidy before the call + Bool -- => True, external function is also re-entrant. + -- [if supported, RTS arranges for the external call + -- to be executed by a separate OS thread, i.e., + -- _concurrently_ to the execution of other Haskell threads.] | PlayRisky -- None of the above can happen; the call will return -- without interacting with the runtime system at all deriving( Eq, Show ) -- Show used just for Show Lex.Token, I think + {-! derive: Binary !-} instance Outputable Safety where - ppr PlaySafe = empty + ppr (PlaySafe False) = ptext SLIT("safe") + ppr (PlaySafe True) = ptext SLIT("threadsafe") ppr PlayRisky = ptext SLIT("unsafe") -playSafe PlaySafe = True -playSafe PlayRisky = False +playSafe :: Safety -> Bool +playSafe PlaySafe{} = True +playSafe PlayRisky = False + +playThreadSafe :: Safety -> Bool +playThreadSafe (PlaySafe x) = x +playThreadSafe _ = False \end{code} @@ -70,16 +86,18 @@ playSafe PlayRisky = False %************************************************************************ \begin{code} +data CExportSpec + = CExportStatic -- foreign export ccall foo :: ty + CLabelString -- C Name of exported function + CCallConv + {-! derive: Binary !-} + data CCallSpec = CCallSpec CCallTarget -- What to call CCallConv -- Calling convention to use. Safety - Bool -- True <=> really a "casm" deriving( Eq ) - - -ccallIsCasm :: CCallSpec -> Bool -ccallIsCasm (CCallSpec _ _ _ c_asm) = c_asm + {-! derive: Binary !-} \end{code} The call target: @@ -89,24 +107,34 @@ data CCallTarget = StaticTarget CLabelString -- An "unboxed" ccall# to `fn'. | DynamicTarget -- First argument (an Addr#) is the function pointer deriving( Eq ) + {-! derive: Binary !-} -isDynamicTarget DynamicTarget = True -isDynamicTarget (StaticTarget _) = False - -dynamicTarget :: CCallTarget -dynamicTarget = DynamicTarget +isDynamicTarget :: CCallTarget -> Bool +isDynamicTarget DynamicTarget = True +isDynamicTarget other = False \end{code} -Stuff to do with calling convention +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. \begin{code} data CCallConv = CCallConv | StdCallConv - deriving( Eq ) + deriving (Eq) + {-! derive: Binary !-} instance Outputable CCallConv where - ppr StdCallConv = ptext SLIT("__stdcall") - ppr CCallConv = ptext SLIT("_ccall") + ppr StdCallConv = ptext SLIT("stdcall") + ppr CCallConv = ptext SLIT("ccall") defaultCCallConv :: CCallConv defaultCCallConv = CCallConv @@ -119,58 +147,277 @@ ccallConvToInt CCallConv = 1 Generate the gcc attribute corresponding to the given calling convention (used by PprAbsC): -ToDo: The stdcall calling convention is x86 (win32) specific, -so perhaps we should emit a warning if it's being used on other -platforms. - \begin{code} ccallConvAttribute :: CCallConv -> String 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} +instance Outputable CExportSpec where + ppr (CExportStatic str _) = pprCLabelString str + instance Outputable CCallSpec where - ppr (CCallSpec fun cconv safety is_casm) - = hcat [ ifPprDebug callconv - , text "__", ppr_dyn - , text before , ppr_fun , after] + ppr (CCallSpec fun cconv safety) + = hcat [ ifPprDebug callconv, ppr_fun fun ] where - callconv = text "{-" <> ppr cconv <> text "-}" - play_safe = playSafe safety - - before - | is_casm && play_safe = "casm_GC ``" - | is_casm = "casm ``" - | play_safe = "ccall_GC " - | otherwise = "ccall " - - after - | is_casm = text "''" - | otherwise = empty - - ppr_dyn = case fun of - DynamicTarget -> text "dyn_" - _ -> empty - - ppr_fun = case fun of - DynamicTarget -> text "\"\"" - StaticTarget fn -> pprCLabelString fn + callconv = text "{-" <> ppr cconv <> text "-}" + + gc_suf | playSafe safety = text "_GC" + | otherwise = empty + + ppr_fun DynamicTarget = text "__dyn_ccall" <> gc_suf <+> text "\"\"" + ppr_fun (StaticTarget fn) = text "__ccall" <> gc_suf <+> pprCLabelString fn +\end{code} + + +%************************************************************************ +%* * +\subsubsection{.NET interop} +%* * +%************************************************************************ + +\begin{code} +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 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} + %************************************************************************ %* * -\subsubsection{.NET stuff} +\subsubsection{Misc} %* * %************************************************************************ \begin{code} -data DotNetCallSpec = DotNetCallSpec - deriving( Eq ) +{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-} +instance Binary ForeignCall where + put_ bh (CCall aa) = do + putByte bh 0 + put_ bh aa + put_ bh (DNCall ab) = do + putByte bh 1 + put_ bh ab + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (CCall aa) + _ -> do ab <- get bh + return (DNCall ab) + +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 + put_ bh (StaticTarget aa) = do + putByte bh 0 + put_ bh aa + put_ bh DynamicTarget = do + putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (StaticTarget aa) + _ -> do return DynamicTarget + +instance Binary CCallConv where + put_ bh CCallConv = do + putByte bh 0 + put_ bh StdCallConv = do + putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> do return CCallConv + _ -> do return StdCallConv + +instance Binary DNCallSpec where + put_ bh (DNCallSpec isStatic kind ass nm _ _) = do + put_ bh isStatic + put_ bh kind + put_ bh ass + put_ bh nm + get bh = do + 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 :- -instance Outputable DotNetCallSpec where - ppr DotNetCallSpec = text "DotNet!" \end{code}