From 1fede4bc9501744bf2269ce2a4cb9fb735969caa Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Mon, 27 Jul 2009 14:45:24 +0000 Subject: [PATCH] Remove old 'foreign import dotnet' code It still lives in darcs, if anyone wants to revive it sometime. --- compiler/codeGen/CgForeignCall.hs | 3 - compiler/codeGen/StgCmmExpr.hs | 1 - compiler/codeGen/StgCmmForeign.hs | 3 - compiler/deSugar/DsCCall.lhs | 25 ++---- compiler/deSugar/DsForeign.lhs | 32 +------ compiler/hsSyn/HsDecls.lhs | 23 +---- compiler/parser/Lexer.x | 2 - compiler/parser/Parser.y.pp | 10 +-- compiler/parser/RdrHsSyn.lhs | 68 ++------------ compiler/prelude/ForeignCall.lhs | 180 ++----------------------------------- compiler/rename/RnSource.lhs | 4 +- compiler/typecheck/TcForeign.lhs | 29 ------ compiler/typecheck/TcType.lhs | 34 ------- 13 files changed, 30 insertions(+), 384 deletions(-) diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs index 87c82cb..957651d 100644 --- a/compiler/codeGen/CgForeignCall.hs +++ b/compiler/codeGen/CgForeignCall.hs @@ -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' diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 2a0716e..8952f92 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -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 diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index af00c79..fae4f2f 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -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)] diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs index 27dff94..0dd29c9 100644 --- a/compiler/deSugar/DsCCall.lhs +++ b/compiler/deSugar/DsCCall.lhs @@ -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 diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index 9127676..1b1b7f0 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -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 diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index c770386..bca3a53 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -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 "\"\"") - -instance Outputable FoType where - ppr DNType = ptext (sLit "type dotnet") \end{code} diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 54045aa..30fc4b6 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -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) diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 47307ff..6712f4e 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -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 } diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 51b77bc..5d54c2f 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -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 diff --git a/compiler/prelude/ForeignCall.lhs b/compiler/prelude/ForeignCall.lhs index a6047a5..e2f5320 100644 --- a/compiler/prelude/ForeignCall.lhs +++ b/compiler/prelude/ForeignCall.lhs @@ -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 !-} @@ -200,68 +193,6 @@ instance Outputable CCallSpec where %************************************************************************ %* * -\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} diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 9f8ea7d..86873b0 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -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", diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index df3f1ef..d643995 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -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 checkCOrAsm HscC = Nothing checkCOrAsm HscAsm = Nothing @@ -397,10 +373,5 @@ foreignDeclCtxt :: ForeignDecl Name -> SDoc foreignDeclCtxt fo = hang (ptext (sLit "When checking declaration:")) 4 (ppr fo) - -illegalDNMethodSig :: SDoc -illegalDNMethodSig - = ptext (sLit "'This pointer' expected as last argument") - \end{code} diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index ce42def..71fee4c 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -92,7 +92,6 @@ module TcType ( isFFITy, -- :: Type -> Bool isFunPtrTy, -- :: Type -> Bool tcSplitIOType_maybe, -- :: Type -> Maybe Type - toDNType, -- :: Type -> DNType -------------------------------- -- Rexported from Type @@ -1258,39 +1257,6 @@ isFFIDotnetObjTy ty isFunPtrTy :: Type -> Bool isFunPtrTy = checkRepTyConKey [funPtrTyConKey] -toDNType :: Type -> DNType -toDNType ty - | isStringTy ty = DNString - | isFFIDotnetObjTy ty = DNObject - | Just (tc,argTys) <- tcSplitTyConApp_maybe ty - = case lookup (getUnique tc) dn_assoc of - Just x -> x - Nothing - | tc `hasKey` ioTyConKey -> toDNType (head argTys) - | otherwise -> pprPanic ("toDNType: unsupported .NET type") - (pprType ty <+> parens (hcat (map pprType argTys)) <+> ppr tc) - | otherwise = panic "toDNType" -- Is this right? - where - dn_assoc :: [ (Unique, DNType) ] - dn_assoc = [ (unitTyConKey, DNUnit) - , (intTyConKey, DNInt) - , (int8TyConKey, DNInt8) - , (int16TyConKey, DNInt16) - , (int32TyConKey, DNInt32) - , (int64TyConKey, DNInt64) - , (wordTyConKey, DNInt) - , (word8TyConKey, DNWord8) - , (word16TyConKey, DNWord16) - , (word32TyConKey, DNWord32) - , (word64TyConKey, DNWord64) - , (floatTyConKey, DNFloat) - , (doubleTyConKey, DNDouble) - , (ptrTyConKey, DNPtr) - , (funPtrTyConKey, DNPtr) - , (charTyConKey, DNChar) - , (boolTyConKey, DNBool) - ] - checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool -- Look through newtypes, but *not* foralls -- Should work even for recursive newtypes -- 1.7.10.4