Commit 1fede4bc authored by Simon Marlow's avatar Simon Marlow
Browse files

Remove old 'foreign import dotnet' code

It still lives in darcs, if anyone wants to revive it sometime.
parent dd849158
......@@ -94,9 +94,6 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
-- ToDo: this might not be correct for 64-bit API
arg_size rep = max (widthInBytes (typeWidth rep)) wORD_SIZE
emitForeignCall _ (DNCall _) _ _
= panic "emitForeignCall: DNCall"
-- alternative entry point, used by CmmParse
emitForeignCall'
......
......@@ -320,7 +320,6 @@ isSimpleScrut _ _ = False
isSimpleOp :: StgOp -> Bool
-- True iff the op cannot block or allocate
isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) = not (playSafe safe)
isSimpleOp (StgFCallOp (DNCall _) _) = False -- Safe!
isSimpleOp (StgPrimOp op) = not (primOpOutOfLine op)
isSimpleOp (StgPrimCallOp _) = False
......
......@@ -82,9 +82,6 @@ cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_a
-- ToDo: this might not be correct for 64-bit API
arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType arg) wORD_SIZE
cgForeignCall _ _ (DNCall _) _
= panic "cgForeignCall: DNCall"
emitCCall :: [(CmmFormal,ForeignHint)]
-> CmmExpr
-> [(CmmActual,ForeignHint)]
......
......@@ -88,7 +88,7 @@ dsCCall :: CLabelString -- C routine to invoke
dsCCall lbl args may_gc result_ty
= do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args
(ccall_result_ty, res_wrapper) <- boxResult id Nothing result_ty
(ccall_result_ty, res_wrapper) <- boxResult result_ty
uniq <- newUnique
let
target = StaticTarget lbl
......@@ -231,10 +231,7 @@ unboxArg arg
\begin{code}
boxResult :: ((Maybe Type, CoreExpr -> CoreExpr)
-> (Maybe Type, CoreExpr -> CoreExpr))
-> Maybe Id
-> Type
boxResult :: Type
-> DsM (Type, CoreExpr -> CoreExpr)
-- Takes the result of the user-level ccall:
......@@ -247,11 +244,8 @@ boxResult :: ((Maybe Type, CoreExpr -> CoreExpr)
-- where t' is the unwrapped form of t. If t is simply (), then
-- the result type will be
-- State# RealWorld -> (# State# RealWorld #)
--
-- The gruesome 'augment' and 'mbTopCon' are to do with .NET foreign calls
-- It looks a mess: I wonder if it could be refactored.
boxResult augment mbTopCon result_ty
boxResult result_ty
| Just (io_tycon, io_res_ty, co) <- tcSplitIOType_maybe result_ty
-- isIOType_maybe handles the case where the type is a
-- simple wrapping of IO. E.g.
......@@ -261,9 +255,8 @@ boxResult augment mbTopCon result_ty
-- another case, and a coercion.)
-- The result is IO t, so wrap the result in an IO constructor
= do { res <- resultWrapper io_res_ty
; let aug_res = augment res
extra_result_tys
= case aug_res of
; let extra_result_tys
= case res of
(Just ty,_)
| isUnboxedTupleType ty
-> let (Just (_, ls)) = splitTyConApp_maybe ty in tail ls
......@@ -274,11 +267,11 @@ boxResult augment mbTopCon result_ty
(map Type (realWorldStatePrimTy : io_res_ty : extra_result_tys)
++ (state : anss))
; (ccall_res_ty, the_alt) <- mk_alt return_result aug_res
; (ccall_res_ty, the_alt) <- mk_alt return_result res
; state_id <- newSysLocalDs realWorldStatePrimTy
; let io_data_con = head (tyConDataCons io_tycon)
toIOCon = mbTopCon `orElse` dataConWrapId io_data_con
toIOCon = dataConWrapId io_data_con
wrap the_call = mkCoerceI (mkSymCoI co) $
mkApps (Var toIOCon)
......@@ -292,11 +285,11 @@ boxResult augment mbTopCon result_ty
; return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) }
boxResult augment _mbTopCon result_ty
boxResult result_ty
= do -- It isn't IO, so do unsafePerformIO
-- It's not conveniently available, so we inline it
res <- resultWrapper result_ty
(ccall_res_ty, the_alt) <- mk_alt return_result (augment res)
(ccall_res_ty, the_alt) <- mk_alt return_result res
let
wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId))
ccall_res_ty
......
......@@ -128,13 +128,6 @@ dsFImport id (CImport cconv safety _ spec) = do
(ids, h, c) <- dsCImport id spec cconv safety
return (ids, h, c)
-- FIXME: the `lib' field is needed for .NET ILX generation when invoking
-- routines that are external to the .NET runtime, but GHC doesn't
-- support such calls yet; if `nullFastString lib', the value was not given
dsFImport id (DNImport spec) = do
(ids, h, c) <- dsFCall id (DNCall spec)
return (ids, h, c)
dsCImport :: Id
-> CImportSpec
-> CCallConv
......@@ -200,30 +193,7 @@ dsFCall fn_id fcall = do
let
work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars
forDotnet =
case fcall of
DNCall{} -> True
_ -> False
topConDs
| forDotnet = Just <$> dsLookupGlobalId checkDotnetResName
| otherwise = return Nothing
augmentResultDs
| forDotnet = do
return (\ (mb_res_ty, resWrap) ->
case mb_res_ty of
Nothing -> (Just (mkTyConApp (tupleTyCon Unboxed 1)
[ addrPrimTy ]),
resWrap)
Just x -> (Just (mkTyConApp (tupleTyCon Unboxed 2)
[ x, addrPrimTy ]),
resWrap))
| otherwise = return id
augment <- augmentResultDs
topCon <- topConDs
(ccall_result_ty, res_wrapper) <- boxResult augment topCon io_res_ty
(ccall_result_ty, res_wrapper) <- boxResult io_res_ty
ccall_uniq <- newUnique
work_uniq <- newUnique
......
......@@ -39,7 +39,7 @@ module HsDecls (
SpliceDecl(..),
-- ** Foreign function interface declarations
ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
CImportSpec(..), FoType(..),
CImportSpec(..),
-- ** Data-constructor declarations
ConDecl(..), LConDecl, ResType(..),
HsConDeclDetails, hsConDeclArgTys, hsConDeclsNames,
......@@ -401,8 +401,7 @@ type LTyClDecl name = Located (TyClDecl name)
data TyClDecl name
= ForeignType {
tcdLName :: Located name,
tcdExtName :: Maybe FastString,
tcdFoType :: FoType
tcdExtName :: Maybe FastString
}
......@@ -909,10 +908,6 @@ data ForeignImport = -- import of a C entity
FastString -- name of C header
CImportSpec -- details of the C entity
-- import of a .NET function
--
| DNImport DNCallSpec
-- details of an external C entity
--
data CImportSpec = CLabel CLabelString -- import address of a C label
......@@ -924,13 +919,6 @@ data CImportSpec = CLabel CLabelString -- import address of a C label
-- convention
--
data ForeignExport = CExport CExportSpec -- contains the calling convention
| DNExport -- presently unused
-- abstract type imported from .NET
--
data FoType = DNType -- In due course we'll add subtype stuff
deriving (Eq) -- Used for equality instance for TyClDecl
-- pretty printing of foreign declarations
--
......@@ -944,8 +932,6 @@ instance OutputableBndr name => Outputable (ForeignDecl name) where
2 (dcolon <+> ppr ty)
instance Outputable ForeignImport where
ppr (DNImport spec) =
ptext (sLit "dotnet") <+> ppr spec
ppr (CImport cconv safety header spec) =
ppr cconv <+> ppr safety <+>
char '"' <> pprCEntity spec <> char '"'
......@@ -963,11 +949,6 @@ instance Outputable ForeignImport where
instance Outputable ForeignExport where
ppr (CExport (CExportStatic lbl cconv)) =
ppr cconv <+> char '"' <> ppr lbl <> char '"'
ppr (DNExport ) =
ptext (sLit "dotnet") <+> ptext (sLit "\"<unused>\"")
instance Outputable FoType where
ppr DNType = ptext (sLit "type dotnet")
\end{code}
......
......@@ -454,7 +454,6 @@ data Token
| ITstdcallconv
| ITccallconv
| ITprimcallconv
| ITdotnet
| ITmdo
| ITfamily
| ITgroup
......@@ -664,7 +663,6 @@ reservedWordsFM = listToUFM $
( "stdcall", ITstdcallconv, bit ffiBit),
( "ccall", ITccallconv, bit ffiBit),
( "prim", ITprimcallconv, bit ffiBit),
( "dotnet", ITdotnet, bit ffiBit),
( "rec", ITrec, bit arrowsBit),
( "proc", ITproc, bit arrowsBit)
......
......@@ -248,7 +248,6 @@ incorrect.
'stdcall' { L _ ITstdcallconv }
'ccall' { L _ ITccallconv }
'prim' { L _ ITprimcallconv }
'dotnet' { L _ ITdotnet }
'proc' { L _ ITproc } -- for arrow notation extension
'rec' { L _ ITrec } -- for arrow notation extension
'group' { L _ ITgroup } -- for list transform extension
......@@ -876,11 +875,10 @@ fdecl : 'import' callconv safety fspec
| 'export' callconv fspec
{% mkExport $2 (unLoc $3) >>= return.LL }
callconv :: { CallConv }
: 'stdcall' { CCall StdCallConv }
| 'ccall' { CCall CCallConv }
| 'prim' { CCall PrimCallConv}
| 'dotnet' { DNCall }
callconv :: { CCallConv }
: 'stdcall' { StdCallConv }
| 'ccall' { CCallConv }
| 'prim' { PrimCallConv}
safety :: { Safety }
: 'unsafe' { PlayRisky }
......
......@@ -21,14 +21,9 @@ module RdrHsSyn (
findSplice, checkDecBrGroup,
-- Stuff to do with Foreign declarations
CallConv(..),
mkImport, -- CallConv -> Safety
-- -> (FastString, RdrName, RdrNameHsType)
-- -> P RdrNameHsDecl
mkImport,
parseCImport,
mkExport, -- CallConv
-- -> (FastString, RdrName, RdrNameHsType)
-- -> P RdrNameHsDecl
mkExport,
mkExtName, -- RdrName -> CLabelString
mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
mkSimpleConDecl,
......@@ -65,8 +60,7 @@ import BasicTypes ( maxPrecedence, Activation, RuleMatchInfo,
alwaysInlineSpec, neverInlineSpec )
import Lexer
import TysWiredIn ( unitTyCon )
import ForeignCall ( CCallConv(..), Safety, CCallTarget(..), CExportSpec(..),
DNCallSpec(..), DNKind(..), CLabelString )
import ForeignCall
import OccName ( srcDataName, varName, isDataOcc, isTcOcc,
occNameString )
import PrelNames ( forall_tv_RDR )
......@@ -972,18 +966,13 @@ mkInlineSpec (Just act) match_info inl = Inline (InlinePragma act match_info)
-----------------------------------------------------------------------------
-- utilities for foreign declarations
-- supported calling conventions
--
data CallConv = CCall CCallConv -- ccall or stdcall
| DNCall -- .NET
-- construct a foreign import declaration
--
mkImport :: CallConv
mkImport :: CCallConv
-> Safety
-> (Located FastString, Located RdrName, LHsType RdrName)
-> P (HsDecl RdrName)
mkImport (CCall cconv) safety (L loc entity, v, ty)
mkImport cconv safety (L loc entity, v, ty)
| cconv == PrimCallConv = do
let funcTarget = CFunction (StaticTarget entity)
importSpec = CImport PrimCallConv safety nilFS funcTarget
......@@ -992,9 +981,6 @@ mkImport (CCall cconv) safety (L loc entity, v, ty)
case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of
Nothing -> parseError loc "Malformed entity string"
Just importSpec -> return (ForD (ForeignImport v ty importSpec))
mkImport (DNCall ) _ (entity, v, ty) = do
spec <- parseDImport entity
return $ ForD (ForeignImport v ty (DNImport spec))
-- the string "foo" is ambigous: either a header or a C identifier. The
-- C identifier case comes first in the alternatives below, so we pick
......@@ -1027,56 +1013,16 @@ parseCImport cconv safety nm str =
return (mkFastString (c:cs)))
--
-- Unravel a dotnet spec string.
--
parseDImport :: Located FastString -> P DNCallSpec
parseDImport (L loc entity) = parse0 comps
where
comps = words (unpackFS entity)
parse0 [] = d'oh
parse0 (x : xs)
| x == "static" = parse1 True xs
| otherwise = parse1 False (x:xs)
parse1 _ [] = d'oh
parse1 isStatic (x:xs)
| x == "method" = parse2 isStatic DNMethod xs
| x == "field" = parse2 isStatic DNField xs
| x == "ctor" = parse2 isStatic DNConstructor xs
parse1 isStatic xs = parse2 isStatic DNMethod xs
parse2 _ _ [] = d'oh
parse2 isStatic kind (('[':x):xs) =
case x of
[] -> d'oh
vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
_ -> d'oh
parse2 isStatic kind xs = parse3 isStatic kind "" xs
parse3 isStatic kind assem [x] =
return (DNCallSpec isStatic kind assem x
-- these will be filled in once known.
(error "FFI-dotnet-args")
(error "FFI-dotnet-result"))
parse3 _ _ _ _ = d'oh
d'oh = parseError loc "Malformed entity string"
-- construct a foreign export declaration
--
mkExport :: CallConv
mkExport :: CCallConv
-> (Located FastString, Located RdrName, LHsType RdrName)
-> P (HsDecl RdrName)
mkExport (CCall cconv) (L _ entity, v, ty) = return $
mkExport cconv (L _ entity, v, ty) = return $
ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
where
entity' | nullFS entity = mkExtName (unLoc v)
| otherwise = entity
mkExport DNCall (L _ _, v, _) =
parseError (getLoc v){-TODO: not quite right-}
"Foreign export is not yet supported for .NET"
-- Supplying the ext_name in a foreign decl is optional; if it
-- isn't there, the Haskell name is assumed. Note that no transformation
......
......@@ -19,9 +19,6 @@ module ForeignCall (
CCallSpec(..),
CCallTarget(..), isDynamicTarget,
CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,
DNCallSpec(..), DNKind(..), DNType(..),
withDNTypes
) where
import FastString
......@@ -39,18 +36,14 @@ import Data.Char
%************************************************************************
\begin{code}
data ForeignCall
= CCall CCallSpec
| DNCall DNCallSpec
deriving( Eq ) -- We compare them when seeing if an interface
-- has changed (for versioning purposes)
newtype ForeignCall = CCall CCallSpec
deriving Eq
{-! 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 (DNCall dn) = ppr dn
\end{code}
......@@ -69,7 +62,7 @@ data Safety
| PlayRisky -- None of the above can happen; the call will return
-- without interacting with the runtime system at all
deriving( Eq, Show )
deriving ( Eq, Show )
-- Show used just for Show Lex.Token, I think
{-! derive: Binary !-}
......@@ -198,68 +191,6 @@ instance Outputable CCallSpec where
\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{Misc}
......@@ -269,19 +200,8 @@ instance Outputable DNCallSpec where
\begin{code}
{-* 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)
put_ bh (CCall aa) = put_ bh aa
get bh = do aa <- get bh; return (CCall aa)
instance Binary Safety where
put_ bh (PlaySafe aa) = do
......@@ -342,94 +262,4 @@ instance Binary CCallConv where
0 -> do return CCallConv
1 -> do return StdCallConv
_ -> do return PrimCallConv
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 :-
\end{code}
......@@ -634,9 +634,9 @@ However, we can also do some scoping checks at the same time.
\begin{code}
rnTyClDecl :: TyClDecl RdrName -> RnM (TyClDecl Name, FreeVars)
rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_name})
rnTyClDecl (ForeignType {tcdLName = name, tcdExtName = ext_name})
= lookupLocatedTopBndrRn name `thenM` \ name' ->
return (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name},
return (ForeignType {tcdLName = name', tcdExtName = ext_name},
emptyFVs)
-- all flavours of type family declarations ("type family", "newtype fanily",
......
......@@ -91,21 +91,6 @@ tcFImport d = pprPanic "tcFImport" (ppr d)
------------ Checking types for foreign import ----------------------
\begin{code}
tcCheckFIType :: Type -> [Type] -> Type -> ForeignImport -> TcM ForeignImport
tcCheckFIType _ arg_tys res_ty (DNImport spec) = do
checkCg checkDotnet
dflags <- getDOpts
checkForeignArgs (isFFIDotnetTy dflags) arg_tys
checkForeignRes nonIOok (isFFIDotnetTy dflags) res_ty
let (DNCallSpec isStatic kind _ _ _ _) = spec
case kind of
DNMethod | not isStatic ->
case arg_tys of
[] -> addErrTc illegalDNMethodSig
_
| not (isFFIDotnetObjTy (last arg_tys)) -> addErrTc illegalDNMethodSig
| otherwise -> return ()
_ -> return ()
return (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty)))
tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ (CLabel _))
= ASSERT( null arg_tys )
......@@ -268,7 +253,6 @@ tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do
-- the structure of the foreign type.
(_, t_ty) = tcSplitForAllTys sig_ty
(arg_tys, res_ty) = tcSplitFunTys t_ty
tcCheckFEType _ d = pprPanic "tcCheckFEType" (ppr d)
\end{code}
......@@ -309,14 +293,6 @@ checkForeignRes non_io_result_ok pred_res_ty ty
\end{code}
\begin{code}
checkDotnet :: HscTarget -> Maybe SDoc
#if defined(mingw32_TARGET_OS)
checkDotnet HscC = Nothing
checkDotnet _ = Just (text "requires C code generation (-fvia-C)")
#else
checkDotnet _ = Just (text "requires .NET support (-filx or win32)")
#endif
checkCOrAsm :: HscTarget -> Maybe SDoc