From 2129fa6fc4afd7f7b0c767f8c0c14b9ab5508ec2 Mon Sep 17 00:00:00 2001 From: simonmar Date: Tue, 16 Sep 2003 13:03:49 +0000 Subject: [PATCH] [project @ 2003-09-16 13:03:37 by simonmar] Legacy Removal ~~~~~~~~~~~~~~ The following features have been consigned to the bit bucket: _ccall_ _casm_ ``....'' (lit-lits) the CCallable class the CReturnable class --- ghc/compiler/absCSyn/AbsCUtils.lhs | 7 ++- ghc/compiler/absCSyn/PprAbsC.lhs | 1 - ghc/compiler/basicTypes/Literal.lhs | 31 +------------- ghc/compiler/codeGen/CgCon.lhs | 2 +- ghc/compiler/coreSyn/CoreUnfold.lhs | 36 +--------------- ghc/compiler/coreSyn/CoreUtils.lhs | 16 +++---- ghc/compiler/deSugar/DsCCall.lhs | 8 ++-- ghc/compiler/deSugar/DsExpr.lhs | 5 --- ghc/compiler/deSugar/DsForeign.lhs | 2 +- ghc/compiler/deSugar/DsMeta.hs | 1 - ghc/compiler/deSugar/MatchLit.lhs | 10 ----- ghc/compiler/hsSyn/HsCore.lhs | 16 ++----- ghc/compiler/hsSyn/HsDecls.lhs | 2 - ghc/compiler/hsSyn/HsExpr.lhs | 22 ---------- ghc/compiler/hsSyn/HsLit.lhs | 9 ---- ghc/compiler/main/BinIface.hs | 18 +------- ghc/compiler/main/CmdLineOpts.lhs | 3 -- ghc/compiler/main/TidyPgm.lhs | 5 +-- ghc/compiler/nativeGen/StixPrim.lhs | 12 +----- ghc/compiler/parser/Lexer.x | 21 +-------- ghc/compiler/parser/Parser.y | 13 +----- ghc/compiler/prelude/ForeignCall.lhs | 27 ++---------- ghc/compiler/prelude/PrelInfo.lhs | 41 +++--------------- ghc/compiler/prelude/PrelNames.lhs | 27 +----------- ghc/compiler/prelude/PrelRules.lhs | 12 +++--- ghc/compiler/rename/RnExpr.lhs | 9 ---- ghc/compiler/rename/RnHiFiles.lhs | 5 +-- ghc/compiler/rename/RnHsSyn.lhs | 2 - ghc/compiler/rename/RnSource.lhs | 8 ---- ghc/compiler/rename/RnTypes.lhs | 15 +------ ghc/compiler/stgSyn/StgSyn.lhs | 11 ++--- ghc/compiler/typecheck/Inst.lhs | 8 +--- ghc/compiler/typecheck/TcExpr.lhs | 75 +-------------------------------- ghc/compiler/typecheck/TcForeign.lhs | 8 +--- ghc/compiler/typecheck/TcHsSyn.lhs | 10 ----- ghc/compiler/typecheck/TcIfaceSig.lhs | 12 ------ ghc/compiler/typecheck/TcMType.lhs | 18 +------- ghc/compiler/typecheck/TcPat.lhs | 11 +---- ghc/compiler/typecheck/TcRnTypes.lhs | 4 -- ghc/compiler/typecheck/TcSimplify.lhs | 20 ++------- 40 files changed, 63 insertions(+), 500 deletions(-) diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs index 893f88a..7dfd8ee 100644 --- a/ghc/compiler/absCSyn/AbsCUtils.lhs +++ b/ghc/compiler/absCSyn/AbsCUtils.lhs @@ -31,8 +31,7 @@ import Unique ( Unique{-instance Eq-} ) import UniqSupply ( uniqFromSupply, uniqsFromSupply, splitUniqSupply, UniqSupply ) import CmdLineOpts ( opt_EmitCExternDecls, opt_Unregisterised ) -import ForeignCall ( ForeignCall(..), CCallSpec(..), - isDynamicTarget, isCasmTarget ) +import ForeignCall ( ForeignCall(..), CCallSpec(..), isDynamicTarget ) import StgSyn ( StgOp(..) ) import CoreSyn ( AltCon(..) ) import SMRep ( arrPtrsHdrSize, arrWordsHdrSize, fixedHdrSize ) @@ -343,8 +342,8 @@ flatAbsC (CSwitch discrim alts deflt) returnFlt ( (tag, alt_heres), alt_tops ) flatAbsC stmt@(COpStmt results (StgFCallOp (CCall ccall@(CCallSpec target _ _)) uniq) args _) - | is_dynamic -- Emit a typedef if its a dynamic call - || (opt_EmitCExternDecls && not (isCasmTarget target)) -- or we want extern decls + | is_dynamic -- Emit a typedef if its a dynamic call + || (opt_EmitCExternDecls) -- or we want extern decls = returnFlt (stmt, CCallTypedef is_dynamic ccall uniq results args) where is_dynamic = isDynamicTarget target diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index f7b3118..bea6d67 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -949,7 +949,6 @@ pprFCall call uniq args results vol_regs call_str tgt = case tgt of - CasmTarget str -> unpackFS str StaticTarget fn -> mk_ccall_str (pprCLabelString fn) ccall_args DynamicTarget -> mk_ccall_str dyn_fun (tail ccall_args) diff --git a/ghc/compiler/basicTypes/Literal.lhs b/ghc/compiler/basicTypes/Literal.lhs index 1e39e65..d71bedf 100644 --- a/ghc/compiler/basicTypes/Literal.lhs +++ b/ghc/compiler/basicTypes/Literal.lhs @@ -8,7 +8,7 @@ module Literal ( Literal(..) -- Exported to ParseIface , mkMachInt, mkMachWord , mkMachInt64, mkMachWord64 - , isLitLitLit, maybeLitLit, litSize + , litSize , litIsDupable, litIsTrivial , literalType, literalPrimRep , hashLiteral @@ -123,16 +123,9 @@ data Literal -- 'stdcall' labels. -- Just x => "@" will be appended to label -- name when emitting asm. - - -- lit-lits only work for via-C compilation, hence they - -- are deprecated. The string is emitted verbatim into - -- the C file, and can therefore be any C expression, - -- macro call, #defined constant etc. - | MachLitLit FastString Type -- Type might be Addr# or Int# etc \end{code} -Binary instance: must do this manually, because we don't want the type -arg of MachLitLit involved. +Binary instance \begin{code} instance Binary Literal where @@ -146,7 +139,6 @@ instance Binary Literal where put_ bh (MachFloat ah) = do putByte bh 7; put_ bh ah put_ bh (MachDouble ai) = do putByte bh 8; put_ bh ai put_ bh (MachLabel aj mb) = do putByte bh 9; put_ bh aj ; put_ bh mb - put_ bh (MachLitLit ak _) = do putByte bh 10; put_ bh ak get bh = do h <- getByte bh case h of @@ -180,9 +172,6 @@ instance Binary Literal where aj <- get bh mb <- get bh return (MachLabel aj mb) - 10 -> do - ak <- get bh - return (MachLitLit ak (error "MachLitLit: no type")) \end{code} \begin{code} @@ -283,12 +272,6 @@ nullAddrLit = MachNullAddr Predicates ~~~~~~~~~~ \begin{code} -isLitLitLit (MachLitLit _ _) = True -isLitLitLit _ = False - -maybeLitLit (MachLitLit s t) = Just (s,t) -maybeLitLit _ = Nothing - litIsTrivial :: Literal -> Bool -- True if there is absolutely no penalty to duplicating the literal -- c.f. CoreUtils.exprIsTrivial @@ -326,7 +309,6 @@ literalType (MachWord64 _) = word64PrimTy literalType (MachFloat _) = floatPrimTy literalType (MachDouble _) = doublePrimTy literalType (MachLabel _ _) = addrPrimTy -literalType (MachLitLit _ ty) = ty \end{code} \begin{code} @@ -342,7 +324,6 @@ literalPrimRep (MachWord64 _) = Word64Rep literalPrimRep (MachFloat _) = FloatRep literalPrimRep (MachDouble _) = DoubleRep literalPrimRep (MachLabel _ _) = AddrRep -literalPrimRep (MachLitLit _ ty) = typePrimRep ty \end{code} @@ -359,7 +340,6 @@ cmpLit (MachWord64 a) (MachWord64 b) = a `compare` b cmpLit (MachFloat a) (MachFloat b) = a `compare` b cmpLit (MachDouble a) (MachDouble b) = a `compare` b cmpLit (MachLabel a _) (MachLabel b _) = a `compare` b -cmpLit (MachLitLit a b) (MachLitLit c d) = (a `compare` c) `thenCmp` (b `tcCmpType` d) cmpLit lit1 lit2 | litTag lit1 <# litTag lit2 = LT | otherwise = GT @@ -373,7 +353,6 @@ litTag (MachWord64 _) = _ILIT(7) litTag (MachFloat _) = _ILIT(8) litTag (MachDouble _) = _ILIT(9) litTag (MachLabel _ _) = _ILIT(10) -litTag (MachLitLit _ _) = _ILIT(11) \end{code} Printing @@ -426,11 +405,6 @@ pprLit lit Nothing -> pprHsString l Just x -> doubleQuotes (text (unpackFS l ++ '@':show x)) - MachLitLit s ty | code_style -> ftext s - | otherwise -> parens (hsep [ptext SLIT("__litlit"), - pprHsString s, - pprParendType ty]) - -- negative floating literals in code style need parentheses to avoid -- interacting with surrounding syntax. code_rational d | d < 0 = parens (rational d) @@ -476,7 +450,6 @@ hashLiteral (MachWord64 i) = hashInteger i hashLiteral (MachFloat r) = hashRational r hashLiteral (MachDouble r) = hashRational r hashLiteral (MachLabel s _) = hashFS s -hashLiteral (MachLitLit s _) = hashFS s hashRational :: Rational -> Int hashRational r = hashInteger (numerator r) diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs index c83a035..6752a3b 100644 --- a/ghc/compiler/codeGen/CgCon.lhs +++ b/ghc/compiler/codeGen/CgCon.lhs @@ -68,7 +68,7 @@ cgTopRhsCon :: Id -- Name of thing bound to this RHS -> [StgArg] -- Args -> FCode (Id, CgIdInfo) cgTopRhsCon id con args - = ASSERT( not (isDllConApp con args) ) -- checks for litlit args too + = ASSERT( not (isDllConApp con args) ) ASSERT( args `lengthIs` dataConRepArity con ) -- LAY IT OUT diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index 46f2ba2..01d7925 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -24,7 +24,6 @@ module CoreUnfold ( couldBeSmallEnoughToInline, certainlyWillInline, - okToUnfoldInHiFile, callSiteInline ) where @@ -35,7 +34,7 @@ import CmdLineOpts ( opt_UF_CreationThreshold, opt_UF_UseThreshold, opt_UF_FunAppDiscount, opt_UF_KeenessFactor, - opt_UF_DearOp, opt_UnfoldCasms, + opt_UF_DearOp, DynFlags, DynFlag(..), dopt ) import CoreSyn @@ -47,9 +46,8 @@ import Id ( Id, idType, isId, isFCallId_maybe, globalIdDetails ) import DataCon ( isUnboxedTupleCon ) -import Literal ( isLitLitLit, litSize ) +import Literal ( litSize ) import PrimOp ( primOpIsDupable, primOpOutOfLine ) -import ForeignCall ( okToExposeFCall ) import IdInfo ( OccInfo(..), GlobalIdDetails(..) ) import Type ( isUnLiftedType ) import PrelNames ( hasKey, buildIdKey, augmentIdKey ) @@ -467,36 +465,6 @@ certainlyWillInline other = False \end{code} -@okToUnfoldInHifile@ is used when emitting unfolding info into an interface -file to determine whether an unfolding candidate really should be unfolded. -The predicate is needed to prevent @_casm_@s (+ lit-lits) from being emitted -into interface files. - -The reason for inlining expressions containing _casm_s into interface files -is that these fragments of C are likely to mention functions/#defines that -will be out-of-scope when inlined into another module. This is not an -unfixable problem for the user (just need to -#include the approp. header -file), but turning it off seems to the simplest thing to do. - -\begin{code} -okToUnfoldInHiFile :: CoreExpr -> Bool -okToUnfoldInHiFile e = opt_UnfoldCasms || go e - where - -- Race over an expression looking for CCalls.. - go (Var v) = case isFCallId_maybe v of - Just fcall -> okToExposeFCall fcall - Nothing -> True - go (Lit lit) = not (isLitLitLit lit) - go (App fun arg) = go fun && go arg - go (Lam _ body) = go body - go (Let binds body) = and (map go (body :rhssOfBind binds)) - go (Case scrut bndr alts) = and (map go (scrut:rhssOfAlts alts)) && - not (any isLitLitLit [ lit | (LitAlt lit, _, _) <- alts ]) - go (Note _ body) = go body - go (Type _) = True -\end{code} - - %************************************************************************ %* * \subsection{callSiteInline} diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 882d469..7921b3c 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -45,7 +45,7 @@ import Var ( Var, isId, isTyVar ) import VarEnv import Name ( hashName, isDllName ) import Literal ( hashLiteral, literalType, litIsDupable, - litIsTrivial, isZeroLit, isLitLitLit ) + litIsTrivial, isZeroLit ) import DataCon ( DataCon, dataConRepArity, dataConArgTys, isExistentialDataCon, dataConTyCon, dataConName ) import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap ) @@ -1157,11 +1157,10 @@ hashId id = hashName (idName id) %* * %************************************************************************ -Top-level constructor applications can usually be allocated -statically, but they can't if - a) the constructor, or any of the arguments, come from another DLL - b) any of the arguments are LitLits -(because we can't refer to static labels in other DLLs). +Top-level constructor applications can usually be allocated +statically, but they can't if the constructor, or any of the +arguments, come from another DLL (because we can't refer to static +labels in other DLLs). If this happens we simply make the RHS into an updatable thunk, and 'exectute' it rather than allocating it statically. @@ -1235,10 +1234,7 @@ is_static False (Lam b e) = isRuntimeVar b || is_static False e is_static in_arg (Note (SCC _) e) = False is_static in_arg (Note _ e) = is_static in_arg e - -is_static in_arg (Lit lit) = not (isLitLitLit lit) - -- lit-lit arguments cannot be used in static constructors either. - -- (litlits are deprecated, so I'm not going to bother cleaning up this infelicity --SDM). +is_static in_arg (Lit lit) = True is_static in_arg other_expr = go other_expr 0 where diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index f2fdc28..71f3324 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -1,7 +1,7 @@ % % (c) The AQUA Project, Glasgow University, 1994-1998 % -\section[DsCCall]{Desugaring \tr{_ccall_}s and \tr{_casm_}s} +\section[DsCCall]{Desugaring C calls} \begin{code} module DsCCall @@ -103,17 +103,15 @@ follows: dsCCall :: CLabelString -- C routine to invoke -> [CoreExpr] -- Arguments (desugared) -> Safety -- Safety of the call - -> Bool -- True <=> really a "_casm_" -> Type -- Type of the result: IO t -> DsM CoreExpr -dsCCall lbl args may_gc is_asm result_ty +dsCCall lbl args may_gc result_ty = mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) -> boxResult [] id Nothing result_ty `thenDs` \ (ccall_result_ty, res_wrapper) -> getUniqueDs `thenDs` \ uniq -> let - target | is_asm = CasmTarget lbl - | otherwise = StaticTarget lbl + target = StaticTarget lbl the_fcall = CCall (CCallSpec target CCallConv may_gc) the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty in diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 6ef07ff..bed0a6f 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -236,11 +236,6 @@ dsExpr (SectionR op expr) returnDs (bindNonRec y_id y_core $ Lam x_id (mkApps core_op [Var x_id, Var y_id])) -dsExpr (HsCCall lbl args may_gc is_asm result_ty) - = mapDs dsExpr args `thenDs` \ core_args -> - dsCCall lbl core_args may_gc is_asm result_ty - -- dsCCall does all the unboxification, etc. - dsExpr (HsSCC cc expr) = dsExpr expr `thenDs` \ core_expr -> getModuleDs `thenDs` \ mod_name -> diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index 4f34d4c..22c8569 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -391,7 +391,7 @@ dsFExportDynamic id cconv StdCallConv -> Just sz_args _ -> Nothing in - dsCCall adjustor adj_args PlayRisky False io_res_ty `thenDs` \ ccall_adj -> + dsCCall adjustor adj_args PlayRisky io_res_ty `thenDs` \ ccall_adj -> -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback let ccall_adj_ty = exprType ccall_adj ccall_io_adj = mkLams [stbl_value] $ diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index b02761c..4b179f5 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -525,7 +525,6 @@ repE (ArithSeqIn aseq) = repFromThenTo ds1 ds2 ds3 repE (PArrSeqOut _ aseq) = panic "DsMeta.repE: parallel array seq.s missing" repE (HsCoreAnn _ _) = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations -repE (HsCCall _ _ _ _ _) = panic "DsMeta.repE: Can't represent __ccall__" repE (HsSCC _ _) = panic "DsMeta.repE: Can't represent SCC" repE (HsBracketOut _ _) = panic "DsMeta.repE: Can't represent Oxford brackets" diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs index 01d1ed8..2be6e25 100644 --- a/ghc/compiler/deSugar/MatchLit.lhs +++ b/ghc/compiler/deSugar/MatchLit.lhs @@ -12,7 +12,6 @@ import {-# SOURCE #-} Match ( match ) import {-# SOURCE #-} DsExpr ( dsExpr ) import DsMonad -import DsCCall ( resultWrapper ) import DsUtils import HsSyn ( HsLit(..), Pat(..), HsExpr(..) ) @@ -26,9 +25,7 @@ import PrelNames ( ratioTyConKey ) import Unique ( hasKey ) import Literal ( mkMachInt, Literal(..) ) import Maybes ( catMaybes ) -import Type ( isUnLiftedType ) import Panic ( panic, assertPanic ) -import Maybe ( isJust ) import Ratio ( numerator, denominator ) \end{code} @@ -64,11 +61,6 @@ dsLit (HsInt i) = returnDs (mkIntExpr i) dsLit (HsIntPrim i) = returnDs (mkIntLit i) dsLit (HsFloatPrim f) = returnDs (mkLit (MachFloat f)) dsLit (HsDoublePrim d) = returnDs (mkLit (MachDouble d)) -dsLit (HsLitLit str ty) - = resultWrapper ty `thenDs` \ (maybe_ty, wrap_fn) -> - ASSERT( isJust maybe_ty ) - let (Just rep_ty) = maybe_ty in - returnDs (wrap_fn (mkLit (MachLitLit str rep_ty))) dsLit (HsRat r ty) = mkIntegerExpr (numerator r) `thenDs` \ num -> @@ -133,8 +125,6 @@ matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (LitPat literal : ps1 mk_core_lit (HsStringPrim s) = MachStr s mk_core_lit (HsFloatPrim f) = MachFloat f mk_core_lit (HsDoublePrim d) = MachDouble d - mk_core_lit (HsLitLit s ty) = ASSERT(isUnLiftedType ty) - MachLitLit s ty mk_core_lit other = panic "matchLiterals:mk_core_lit:unhandled" \end{code} diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index 27b6ae6..cc0c27b 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -39,7 +39,7 @@ import RdrName ( RdrName, rdrNameOcc ) import CoreSyn import CostCentre ( pprCostCentreCore ) import NewDemand ( StrictSig, pprIfaceStrictSig ) -import Literal ( Literal, maybeLitLit ) +import Literal ( Literal ) import ForeignCall ( ForeignCall ) import DataCon ( dataConTyCon, dataConSourceArity ) import TyCon ( isTupleTyCon, tupleTyConBoxity ) @@ -69,7 +69,6 @@ data UfExpr name | UfLet (UfBinding name) (UfExpr name) | UfNote (UfNote name) (UfExpr name) | UfLit Literal - | UfLitLit FastString (HsType name) | UfFCall ForeignCall (HsType name) data UfNote name = UfSCC CostCentre @@ -84,7 +83,6 @@ data UfConAlt name = UfDefault | UfDataAlt name | UfTupleAlt HsTupCon | UfLitAlt Literal - | UfLitLitAlt FastString (HsType name) data UfBinding name = UfNonRec (UfBinder name) @@ -110,9 +108,7 @@ ufBinderName (UfTyBinder n _) = n \begin{code} toUfExpr :: CoreExpr -> UfExpr Name toUfExpr (Var v) = toUfVar v -toUfExpr (Lit l) = case maybeLitLit l of - Just (s,ty) -> UfLitLit s (toHsType ty) - Nothing -> UfLit l +toUfExpr (Lit l) = UfLit l toUfExpr (Type ty) = UfType (toHsType ty) toUfExpr (Lam x b) = UfLam (toUfBndr x) (toUfExpr b) toUfExpr (App f a) = toUfApp f [a] @@ -140,9 +136,7 @@ toUfCon (DataAlt dc) | isTupleTyCon tc = UfTupleAlt (mk_hs_tup_con tc dc) where tc = dataConTyCon dc -toUfCon (LitAlt l) = case maybeLitLit l of - Just (s,ty) -> UfLitLitAlt s (toHsType ty) - Nothing -> UfLitAlt l +toUfCon (LitAlt l) = UfLitAlt l toUfCon DEFAULT = UfDefault --------------------- @@ -207,7 +201,6 @@ pprUfExpr :: OutputableBndr name => (SDoc -> SDoc) -> UfExpr name -> SDoc pprUfExpr add_par (UfVar v) = ppr v pprUfExpr add_par (UfLit l) = ppr l -pprUfExpr add_par (UfLitLit l ty) = add_par (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty]) pprUfExpr add_par (UfFCall cc ty) = braces (ppr cc <+> ppr ty) pprUfExpr add_par (UfType ty) = char '@' <+> pprParendHsType ty @@ -259,7 +252,6 @@ instance Outputable name => Outputable (UfNote name) where instance Outputable name => Outputable (UfConAlt name) where ppr UfDefault = text "__DEFAULT" ppr (UfLitAlt l) = ppr l - ppr (UfLitLitAlt l ty) = parens (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty]) ppr (UfDataAlt d) = ppr d instance Outputable name => Outputable (UfBinder name) where @@ -326,7 +318,6 @@ eq_ufVar env n1 n2 = case lookupFM env n1 of eq_ufExpr :: (NamedThing name, Ord name) => EqHsEnv name -> UfExpr name -> UfExpr name -> Bool eq_ufExpr env (UfVar v1) (UfVar v2) = eq_ufVar env v1 v2 eq_ufExpr env (UfLit l1) (UfLit l2) = l1 == l2 -eq_ufExpr env (UfLitLit l1 ty1) (UfLitLit l2 ty2) = l1==l2 && eq_hsType env ty1 ty2 eq_ufExpr env (UfFCall c1 ty1) (UfFCall c2 ty2) = c1==c2 && eq_hsType env ty1 ty2 eq_ufExpr env (UfType ty1) (UfType ty2) = eq_hsType env ty1 ty2 eq_ufExpr env (UfTuple n1 as1) (UfTuple n2 as2) = n1==n2 && eqListBy (eq_ufExpr env) as1 as2 @@ -366,7 +357,6 @@ eq_ufConAlt env UfDefault UfDefault = True eq_ufConAlt env (UfDataAlt n1) (UfDataAlt n2) = n1==n2 eq_ufConAlt env (UfTupleAlt c1) (UfTupleAlt c2) = c1==c2 eq_ufConAlt env (UfLitAlt l1) (UfLitAlt l2) = l1==l2 -eq_ufConAlt env (UfLitLitAlt s1 t1) (UfLitLitAlt s2 t2) = s1==s2 && eq_hsType env t1 t2 eq_ufConAlt env _ _ = False \end{code} diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 001d4f8..d5e9c07 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -794,8 +794,6 @@ instance Outputable ForeignImport where pprLib lib <> ppr lbl pprCEntity header lib (CFunction (DynamicTarget)) = ptext SLIT("dynamic") - pprCEntity header lib (CFunction (CasmTarget _)) = - panic "HsDecls.pprCEntity: malformed C function target" pprCEntity _ _ (CWrapper) = ptext SLIT("wrapper") -- pprLib lib | nullFastString lib = empty diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index cf6b424..9b2b64f 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -17,14 +17,11 @@ import HsTypes ( HsType, PostTcType, SyntaxName ) import HsImpExp ( isOperator, pprHsVar ) -- others: -import ForeignCall ( Safety ) import PprType ( pprParendType ) import Type ( Type ) import Var ( TyVar, Id ) import Name ( Name ) -import NameSet ( FreeVars ) import DataCon ( DataCon ) -import CStrings ( CLabelString, pprCLabelString ) import BasicTypes ( IPName, Boxity, tupleParens, Fixity(..) ) import SrcLoc ( SrcLoc ) import Outputable @@ -141,19 +138,6 @@ data HsExpr id (HsExpr id) -- (typechecked, of course) (ArithSeqInfo id) - | HsCCall CLabelString -- call into the C world; string is - [HsExpr id] -- the C function; exprs are the - -- arguments to pass. - Safety -- True <=> might cause Haskell - -- garbage-collection (must generate - -- more paranoid code) - Bool -- True <=> it's really a "casm" - -- NOTE: this CCall is the *boxed* - -- version; the desugarer will convert - -- it into the unboxed "ccall#". - PostTcType -- The result type; will be *bottom* - -- until the typechecker gets ahold of it - | HsSCC FastString -- "set cost centre" (_scc_) annotation (HsExpr id) -- expr whose cost is to be measured @@ -390,12 +374,6 @@ ppr_expr EWildPat = char '_' ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e -ppr_expr (HsCCall fun args _ is_asm result_ty) - = hang (if is_asm - then ptext SLIT("_casm_ ``") <> pprCLabelString fun <> ptext SLIT("''") - else ptext SLIT("_ccall_") <+> pprCLabelString fun) - 4 (sep (map pprParendExpr args)) - ppr_expr (HsSCC lbl expr) = sep [ ptext SLIT("_scc_") <+> doubleQuotes (ftext lbl), pprParendExpr expr ] diff --git a/ghc/compiler/hsSyn/HsLit.lhs b/ghc/compiler/hsSyn/HsLit.lhs index 0d90098..8eb18e2 100644 --- a/ghc/compiler/hsSyn/HsLit.lhs +++ b/ghc/compiler/hsSyn/HsLit.lhs @@ -38,11 +38,6 @@ data HsLit -- (overloaded literals are done with HsOverLit) | HsFloatPrim Rational -- Unboxed Float | HsDoublePrim Rational -- Unboxed Double - | HsLitLit FastString PostTcType -- to pass ``literal literals'' through to C - -- also: "overloaded" type; but - -- must resolve to boxed-primitive! - -- The Type in HsLitLit is needed when desuaring; - -- before the typechecker it's just an error value instance Eq HsLit where (HsChar x1) == (HsChar x2) = x1==x2 @@ -55,7 +50,6 @@ instance Eq HsLit where (HsRat x1 _) == (HsRat x2 _) = x1==x2 (HsFloatPrim x1) == (HsFloatPrim x2) = x1==x2 (HsDoublePrim x1) == (HsDoublePrim x2) = x1==x2 - (HsLitLit x1 _) == (HsLitLit x2 _) = x1==x2 lit1 == lit2 = False data HsOverLit -- An overloaded literal @@ -88,11 +82,8 @@ instance Outputable HsLit where ppr (HsFloatPrim f) = rational f <> char '#' ppr (HsDoublePrim d) = rational d <> text "##" ppr (HsIntPrim i) = integer i <> char '#' - ppr (HsLitLit s _) = hcat [text "``", ftext s, text "''"] instance Outputable HsOverLit where ppr (HsIntegral i _) = integer i ppr (HsFractional f _) = rational f \end{code} - - diff --git a/ghc/compiler/main/BinIface.hs b/ghc/compiler/main/BinIface.hs index e489fb2..a2c8249 100644 --- a/ghc/compiler/main/BinIface.hs +++ b/ghc/compiler/main/BinIface.hs @@ -788,12 +788,8 @@ instance (Binary name) => Binary (UfExpr name) where put_ bh (UfLit ap) = do putByte bh 8 put_ bh ap - put_ bh (UfLitLit aq ar) = do - putByte bh 9 - put_ bh aq - put_ bh ar put_ bh (UfFCall as at) = do - putByte bh 10 + putByte bh 9 put_ bh as put_ bh at get bh = do @@ -824,9 +820,6 @@ instance (Binary name) => Binary (UfExpr name) where return (UfNote an ao) 8 -> do ap <- get bh return (UfLit ap) - 9 -> do aq <- get bh - ar <- get bh - return (UfLitLit aq ar) _ -> do as <- get bh at <- get bh return (UfFCall as at) @@ -843,10 +836,6 @@ instance (Binary name) => Binary (UfConAlt name) where put_ bh (UfLitAlt ac) = do putByte bh 3 put_ bh ac - put_ bh (UfLitLitAlt ad ae) = do - putByte bh 4 - put_ bh ad - put_ bh ae get bh = do h <- getByte bh case h of @@ -855,11 +844,8 @@ instance (Binary name) => Binary (UfConAlt name) where return (UfDataAlt aa) 2 -> do ab <- get bh return (UfTupleAlt ab) - 3 -> do ac <- get bh + _ -> do ac <- get bh return (UfLitAlt ac) - _ -> do ad <- get bh - ae <- get bh - return (UfLitLitAlt ad ae) instance (Binary name) => Binary (UfBinding name) where put_ bh (UfNonRec aa ab) = do diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 2d0718b..6de5b11 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -75,7 +75,6 @@ module CmdLineOpts ( opt_DoSemiTagging, opt_LiberateCaseThreshold, opt_StgDoLetNoEscapes, - opt_UnfoldCasms, opt_CprOff, opt_RulesOff, opt_UnboxStrictFields, @@ -592,7 +591,6 @@ opt_RulesOff = lookUp FSLIT("-frules-off") -- Switch off CPR analysis in the new demand analyser opt_LiberateCaseThreshold = lookup_def_int "-fliberate-case-threshold" (10::Int) opt_StgDoLetNoEscapes = lookUp FSLIT("-flet-no-escape") -opt_UnfoldCasms = lookUp FSLIT("-funfold-casms-in-hi-file") opt_UnboxStrictFields = lookUp FSLIT("-funbox-strict-fields") opt_MaxWorkerArgs = lookup_def_int "-fmax-worker-args" (10::Int) @@ -666,7 +664,6 @@ isStaticHscFlag f = "fflatten", "fsemi-tagging", "flet-no-escape", - "funfold-casms-in-hi-file", "funbox-strict-fields", "femit-extern-decls", "fglobalise-toplev-names", diff --git a/ghc/compiler/main/TidyPgm.lhs b/ghc/compiler/main/TidyPgm.lhs index 5785fa5..d543080 100644 --- a/ghc/compiler/main/TidyPgm.lhs +++ b/ghc/compiler/main/TidyPgm.lhs @@ -10,7 +10,7 @@ module TidyPgm( tidyCorePgm, tidyCoreExpr ) where import CmdLineOpts ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas ) import CoreSyn -import CoreUnfold ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile ) +import CoreUnfold ( noUnfolding, mkTopUnfolding ) import CoreFVs ( ruleLhsFreeIds, ruleRhsFreeVars, exprSomeFreeVars ) import CoreTidy ( tidyExpr, tidyVarOcc, tidyIdRules ) import PprCore ( pprIdRules ) @@ -374,8 +374,7 @@ addExternal (id,rhs) needed show_unfold = not bottoming_fn && -- Not necessary not dont_inline && not loop_breaker && - rhs_is_small && -- Small enough - okToUnfoldInHiFile rhs -- No casms etc + rhs_is_small -- Small enough unfold_ids | show_unfold = exprSomeFreeVars isLocalId rhs | otherwise = emptyVarSet diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index 1e9f029..d1edcc0 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -50,14 +50,11 @@ foreignCallCode %* * %************************************************************************ -First, the dreaded @ccall@. We can't handle @casm@s. +First, the dreaded @ccall@. Usually, this compiles to an assignment, but when the left-hand side is empty, we just perform the call and ignore the result. -btw Why not let programmer use casm to provide assembly code instead -of C code? ADR - ToDo: saving/restoring of volatile regs around ccalls. JRS, 001113: always do the call of suspendThread and resumeThread as a ccall @@ -96,9 +93,6 @@ foreignCallCode lhs call@(CCall (CCallSpec ctarget cconv safety)) rhs StaticTarget nm -> (rhs, Left nm) DynamicTarget | notNull rhs -- an assertion -> (tail rhs, Right (amodeToStix (head rhs))) - CasmTarget _ - -> ncgPrimopMoan "Native code generator can't handle foreign call" - (ppr call) stix_args = map amodeToStix' cargs @@ -187,7 +181,6 @@ amodeToStix (CLit core) MachNullAddr -> StInt 0 MachInt i -> StInt i MachWord w -> case word2IntLit core of MachInt iw -> StInt iw - MachLitLit s _ -> litLitErr -- dreadful, but rare. MachLabel l (Just x) -> StCLbl (mkForeignLabel (mkFastString (unpackFS l ++ '@':show x)) False) MachLabel l _ -> StCLbl (mkForeignLabel l False{-ToDo: dynamic-}) @@ -221,9 +214,6 @@ amodeToStix (CMacroExpr _ macro [arg]) amodeToStix other = pprPanic "StixPrim.amodeToStix" (pprAmode other) - -litLitErr - = ncgPrimopMoan "native code generator can't handle lit-lits" empty \end{code} Sizes of the CharLike and IntLike closures that are arranged as arrays diff --git a/ghc/compiler/parser/Lexer.x b/ghc/compiler/parser/Lexer.x index aa5067f..264b724 100644 --- a/ghc/compiler/parser/Lexer.x +++ b/ghc/compiler/parser/Lexer.x @@ -288,9 +288,6 @@ $white_no_nl+ ; \" { lex_string_tok } } - "``" (([$graphic $whitechar] # \') | \' ([$graphic $whitechar] # \'))* - "''" { clitlit } - { -- work around bug in Alex 2.0 #if __GLASGOW_HASKELL__ < 503 @@ -341,7 +338,6 @@ data Token__ | ITstdcallconv | ITccallconv | ITdotnet - | ITccall (Bool,Bool,Safety) -- (is_dyn, is_casm, may_gc) | ITmdo | ITspecialise_prag -- Pragmas @@ -416,7 +412,6 @@ data Token__ | ITprimint Integer | ITprimfloat Rational | ITprimdouble Rational - | ITlitlit FastString -- MetaHaskell extension tokens | ITopenExpQuote -- [| or [e| @@ -522,17 +517,7 @@ reservedWordsFM = listToUFM $ ( "with", ITwith, bit withBit), ( "rec", ITrec, bit arrowsBit), - ( "proc", ITproc, bit arrowsBit), - - -- On death row - ("_ccall_", ITccall (False, False, PlayRisky), - bit glaExtsBit), - ("_ccall_GC_", ITccall (False, False, PlaySafe False), - bit glaExtsBit), - ("_casm_", ITccall (False, True, PlayRisky), - bit glaExtsBit), - ("_casm_GC_", ITccall (False, True, PlaySafe False), - bit glaExtsBit) + ( "proc", ITproc, bit arrowsBit) ] reservedSymsFM = listToUFM $ @@ -749,10 +734,6 @@ parseInteger buf len radix to_int where go i x | i == len = x | otherwise = go (i+1) (x * radix + toInteger (to_int (lookAhead buf i))) -clitlit :: Action -clitlit loc end buf len = - return (T loc end (ITlitlit $! lexemeToFastString (stepOnBy 2 buf) (len-4))) - -- ----------------------------------------------------------------------------- -- Layout processing diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index a4294e1..985e501 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- -*-haskell-*- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.122 2003/09/08 11:52:25 simonmar Exp $ +$Id: Parser.y,v 1.123 2003/09/16 13:03:44 simonmar Exp $ Haskell grammar. @@ -134,10 +134,6 @@ Conflicts: 29 shift/reduce, [SDM 19/9/2002] 'dotnet' { T _ _ ITdotnet } 'proc' { T _ _ ITproc } -- for arrow notation extension 'rec' { T _ _ ITrec } -- for arrow notation extension - '_ccall_' { T _ _ (ITccall (False, False, PlayRisky)) } - '_ccall_GC_' { T _ _ (ITccall (False, False, PlaySafe False)) } - '_casm_' { T _ _ (ITccall (False, True, PlayRisky)) } - '_casm_GC_' { T _ _ (ITccall (False, True, PlaySafe False)) } '{-# SPECIALISE' { T _ _ ITspecialise_prag } '{-# SOURCE' { T _ _ ITsource_prag } @@ -211,7 +207,6 @@ Conflicts: 29 shift/reduce, [SDM 19/9/2002] PRIMINTEGER { T _ _ (ITprimint $$) } PRIMFLOAT { T _ _ (ITprimfloat $$) } PRIMDOUBLE { T _ _ (ITprimdouble $$) } - CLITLIT { T _ _ (ITlitlit $$) } -- Template Haskell '[|' { T _ _ ITopenExpQuote } @@ -937,11 +932,6 @@ exp10 :: { RdrNameHsExpr } | srcloc 'mdo' stmtlist {% checkMDo $3 >>= \ stmts -> return (mkHsDo MDoExpr stmts $1) } - | '_ccall_' ccallid aexps0 { HsCCall $2 $3 PlayRisky False placeHolderType } - | '_ccall_GC_' ccallid aexps0 { HsCCall $2 $3 (PlaySafe False) False placeHolderType } - | '_casm_' CLITLIT aexps0 { HsCCall $2 $3 PlayRisky True placeHolderType } - | '_casm_GC_' CLITLIT aexps0 { HsCCall $2 $3 (PlaySafe False) True placeHolderType } - | scc_annot exp { if opt_SccProfilingOn then HsSCC $1 $2 else HsPar $2 } @@ -1421,7 +1411,6 @@ literal :: { HsLit } | PRIMSTRING { HsStringPrim $1 } | PRIMFLOAT { HsFloatPrim $1 } | PRIMDOUBLE { HsDoublePrim $1 } - | CLITLIT { HsLitLit $1 placeHolderType } srcloc :: { SrcLoc } : {% getSrcLoc } diff --git a/ghc/compiler/prelude/ForeignCall.lhs b/ghc/compiler/prelude/ForeignCall.lhs index 0197d64..ab04abf 100644 --- a/ghc/compiler/prelude/ForeignCall.lhs +++ b/ghc/compiler/prelude/ForeignCall.lhs @@ -12,13 +12,11 @@ module ForeignCall ( CExportSpec(..), CCallSpec(..), - CCallTarget(..), isDynamicTarget, isCasmTarget, + CCallTarget(..), isDynamicTarget, CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute, DNCallSpec(..), DNKind(..), DNType(..), - withDNTypes, - - okToExposeFCall + withDNTypes ) where #include "HsVersions.h" @@ -110,16 +108,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} @@ -178,7 +172,6 @@ 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} @@ -251,13 +244,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 @@ -313,17 +299,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 diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index 256b03c..c6afe14 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -10,24 +10,21 @@ module PrelInfo ( wiredInThingEnv, ghcPrimExports, - cCallableClassDecl, cReturnableClassDecl, knownKeyNames, -- Random other things maybeCharLikeCon, maybeIntLikeCon, -- Class categories - isCcallishClass, isCreturnableClass, isNoDictClass, - isNumericClass, isStandardClass + isNoDictClass, isNumericClass, isStandardClass ) where #include "HsVersions.h" import PrelNames ( basicKnownKeyNames, - cCallableClassName, cReturnableClassName, hasKey, charDataConKey, intDataConKey, - numericClassKeys, standardClassKeys, cCallishClassKeys, + numericClassKeys, standardClassKeys, noDictClassKeys ) #ifdef GHCI import DsMeta ( templateHaskellNames ) @@ -40,18 +37,16 @@ import Id ( idName ) import MkId ( mkPrimOpId, wiredInIds ) import MkId -- All of it, for re-export import Name ( Name, nameOccName, NamedThing(..) ) -import RdrName ( mkRdrUnqual, getRdrName ) +import RdrName ( mkRdrUnqual ) import HsSyn ( HsTyVarBndr(..) ) import OccName ( mkVarOcc ) import TysPrim ( primTyCons ) import TysWiredIn ( wiredInTyCons ) -import RdrHsSyn ( mkClassDecl ) import HscTypes ( TyThing(..), implicitTyThings, TypeEnv, mkTypeEnv, GenAvailInfo(..), RdrAvailInfo ) import Class ( Class, classKey, className ) import Type ( funTyCon, openTypeKind, liftedTypeKind ) import TyCon ( tyConName ) -import SrcLoc ( noSrcLoc ) import Util ( isIn ) \end{code} @@ -104,36 +99,15 @@ sense of them in interface pragmas. It's cool, though they all have %************************************************************************ GHC.Prim "exports" all the primops and primitive types, some -wired-in Ids, and the CCallable & CReturnable classes. +wired-in Ids. \begin{code} ghcPrimExports :: [RdrAvailInfo] - = AvailTC cCallableOcc [ cCallableOcc ] : - AvailTC cReturnableOcc [ cReturnableOcc ] : - map (Avail . nameOccName . idName) ghcPrimIds ++ + = map (Avail . nameOccName . idName) ghcPrimIds ++ map (Avail . primOpOcc) allThePrimOps ++ [ AvailTC occ [occ] | n <- funTyCon : primTyCons, let occ = nameOccName (tyConName n) ] - where - cCallableOcc = nameOccName cCallableClassName - cReturnableOcc = nameOccName cReturnableClassName - -cCallableClassDecl - = mkClassDecl - ([], getRdrName cCallableClassName, [openAlpha]) - [] -- no fds - [] -- no sigs - Nothing -- no mbinds - noSrcLoc - -cReturnableClassDecl - = mkClassDecl - ([], getRdrName cReturnableClassName, [openAlpha]) - [] -- no fds - [] -- no sigs - Nothing -- no mbinds - noSrcLoc alpha = mkRdrUnqual (mkVarOcc FSLIT("a")) openAlpha = IfaceTyVar alpha openTypeKind @@ -163,13 +137,10 @@ maybeIntLikeCon con = con `hasKey` intDataConKey %************************************************************************ \begin{code} -isCcallishClass, isCreturnableClass, isNoDictClass, - isNumericClass, isStandardClass :: Class -> Bool +isNoDictClass, isNumericClass, isStandardClass :: Class -> Bool isNumericClass clas = classKey clas `is_elem` numericClassKeys isStandardClass clas = classKey clas `is_elem` standardClassKeys -isCcallishClass clas = classKey clas `is_elem` cCallishClassKeys -isCreturnableClass clas = className clas == cReturnableClassName isNoDictClass clas = classKey clas `is_elem` noDictClassKeys is_elem = isIn "is_X_Class" \end{code} diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index bacb0ec..4c8f926 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -153,8 +153,6 @@ basicKnownKeyNames floatingClassName, -- numeric realFracClassName, -- numeric realFloatClassName, -- numeric - cCallableClassName, -- mentioned, ccallish - cReturnableClassName, -- mentioned, ccallish dataClassName, typeableClassName, @@ -356,8 +354,6 @@ numClass_RDR = nameRdrName numClassName ordClass_RDR = nameRdrName ordClassName enumClass_RDR = nameRdrName enumClassName monadClass_RDR = nameRdrName monadClassName -cCallableClass_RDR = nameRdrName cCallableClassName -cReturnableClass_RDR = nameRdrName cReturnableClassName map_RDR = varQual_RDR pREL_BASE_Name FSLIT("map") append_RDR = varQual_RDR pREL_BASE_Name FSLIT("++") @@ -505,8 +501,6 @@ foreignObjPrimTyConName = tcQual gHC_PRIM_Name FSLIT("ForeignObj#") forei bcoPrimTyConName = tcQual gHC_PRIM_Name FSLIT("BCO#") bcoPrimTyConKey weakPrimTyConName = tcQual gHC_PRIM_Name FSLIT("Weak#") weakPrimTyConKey threadIdPrimTyConName = tcQual gHC_PRIM_Name FSLIT("ThreadId#") threadIdPrimTyConKey -cCallableClassName = clsQual gHC_PRIM_Name FSLIT("CCallable") cCallableClassKey -cReturnableClassName = clsQual gHC_PRIM_Name FSLIT("CReturnable") cReturnableClassKey unsafeCoerceName = wVarQual gHC_PRIM_Name FSLIT("unsafeCoerce#") unsafeCoerceIdKey nullAddrName = wVarQual gHC_PRIM_Name FSLIT("nullAddr#") nullAddrIdKey @@ -788,8 +782,6 @@ realClassKey = mkPreludeClassUnique 14 realFloatClassKey = mkPreludeClassUnique 15 realFracClassKey = mkPreludeClassUnique 16 showClassKey = mkPreludeClassUnique 17 -cCallableClassKey = mkPreludeClassUnique 18 -cReturnableClassKey = mkPreludeClassUnique 19 ixClassKey = mkPreludeClassUnique 20 \end{code} @@ -1114,24 +1106,9 @@ needsDataDeclCtxtClassKeys = -- see comments in TcDeriv [ readClassKey ] -cCallishClassKeys = - [ cCallableClassKey - , cReturnableClassKey - ] +standardClassKeys = derivableClassKeys ++ numericClassKeys -standardClassKeys - = derivableClassKeys ++ numericClassKeys ++ cCallishClassKeys - -- - -- We have to have "CCallable" and "CReturnable" in the standard - -- classes, so that if you go... - -- - -- _ccall_ foo ... 93{-numeric literal-} ... - -- - -- ... it can do The Right Thing on the 93. - -noDictClassKeys -- These classes are used only for type annotations; - -- they are not implemented by dictionaries, ever. - = cCallishClassKeys +noDictClassKeys = [] -- ToDo: remove? \end{code} @derivableClassKeys@ is also used in checking \tr{deriving} constructs diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs index c13d6ed..8f5df8c 100644 --- a/ghc/compiler/prelude/PrelRules.lhs +++ b/ghc/compiler/prelude/PrelRules.lhs @@ -21,7 +21,7 @@ module PrelRules ( primOpRules, builtinRules ) where import CoreSyn import Id ( mkWildId ) -import Literal ( Literal(..), isLitLitLit, mkMachInt, mkMachWord +import Literal ( Literal(..), mkMachInt, mkMachWord , literalType , word2IntLit, int2WordLit , narrow8IntLit, narrow16IntLit, narrow32IntLit @@ -177,16 +177,14 @@ primOpRules op = primop_rule op %* * %************************************************************************ - IMPORTANT NOTE - -In all these operations we might find a LitLit as an operand; that's -why we have the catch-all Nothing case. +ToDo: the reason these all return Nothing is because there used to be +the possibility of an argument being a litlit. Litlits are now gone, +so this could be cleaned up. \begin{code} -------------------------- litCoerce :: (Literal -> Literal) -> Literal -> Maybe CoreExpr -litCoerce fn lit | isLitLitLit lit = Nothing - | otherwise = Just (Lit (fn lit)) +litCoerce fn lit = Just (Lit (fn lit)) -------------------------- cmpOp :: (Ordering -> Bool) -> Literal -> Literal -> Maybe CoreExpr diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 23e41c0..2b1f285 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -36,7 +36,6 @@ import BasicTypes ( Fixity(..), FixityDirection(..), IPName(..), defaultFixity, negateFixity, compareFixity ) import PrelNames ( hasKey, assertIdKey, foldrName, buildName, - cCallableClassName, cReturnableClassName, enumClassName, loopAName, choiceAName, appAName, arrAName, composeAName, firstAName, splitName, fstName, sndName, ioDataConName, @@ -261,14 +260,6 @@ rnExpr section@(SectionR op expr) checkSectionPrec InfixR section op' expr' `thenM_` returnM (SectionR op' expr', fvs_op `plusFV` fvs_expr) -rnExpr (HsCCall fun args may_gc is_casm _) - -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls - = rnExprs args `thenM` \ (args', fvs_args) -> - returnM (HsCCall fun args' may_gc is_casm placeHolderType, - fvs_args `plusFV` mkFVs [cCallableClassName, - cReturnableClassName, - ioDataConName]) - rnExpr (HsCoreAnn ann expr) = rnExpr expr `thenM` \ (expr', fvs_expr) -> returnM (HsCoreAnn ann expr', fvs_expr) diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index 3ef8c26..57b32e7 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -39,7 +39,7 @@ import RnEnv import TcRnMonad import PrelNames ( gHC_PRIM_Name, gHC_PRIM ) -import PrelInfo ( ghcPrimExports, cCallableClassDecl, cReturnableClassDecl ) +import PrelInfo ( ghcPrimExports ) import Name ( Name {-instance NamedThing-}, nameModule, isInternalName ) import NameEnv @@ -685,8 +685,7 @@ ghcPrimIface = ParsedIface { pi_orphan = False, pi_usages = [], pi_exports = (1, [(gHC_PRIM_Name, ghcPrimExports)]), - pi_decls = [(1,cCallableClassDecl), - (1,cReturnableClassDecl)], + pi_decls = [], pi_fixity = [FixitySig (nameRdrName (idName seqId)) (Fixity 0 InfixR) noSrcLoc], -- seq is infixr 0 diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 5c959d2..0d20ecf 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -209,7 +209,6 @@ hsIdInfoFVs other = emptyFVs ---------------- ufExprFVs (UfVar n) = unitFV n ufExprFVs (UfLit l) = emptyFVs -ufExprFVs (UfLitLit l ty) = extractHsTyNames ty ufExprFVs (UfFCall cc ty) = extractHsTyNames ty ufExprFVs (UfType ty) = extractHsTyNames ty ufExprFVs (UfTuple tc es) = hsTupConFVs tc `plusFV` plusFVs (map ufExprFVs es) @@ -229,7 +228,6 @@ ufAltFVs (con, vs, e) = ufConFVs con `plusFV` delFVs vs (ufExprFVs e) ufConFVs (UfDataAlt n) = unitFV n ufConFVs (UfTupleAlt t) = hsTupConFVs t -ufConFVs (UfLitLitAlt _ ty) = extractHsTyNames ty ufConFVs other = emptyFVs ufNoteFVs (UfCoerce ty) = extractHsTyNames ty diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index f74c712..35ebab2 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -809,10 +809,6 @@ rnCoreExpr (UfVar v) rnCoreExpr (UfLit l) = returnM (UfLit l) -rnCoreExpr (UfLitLit l ty) - = rnHsType (text "litlit") ty `thenM` \ ty' -> - returnM (UfLitLit l ty') - rnCoreExpr (UfFCall cc ty) = rnHsType (text "ccall") ty `thenM` \ ty' -> returnM (UfFCall cc ty') @@ -903,10 +899,6 @@ rnUfCon (UfDataAlt con) rnUfCon (UfLitAlt lit) = returnM (UfLitAlt lit) - -rnUfCon (UfLitLitAlt lit ty) - = rnHsType (text "litlit") ty `thenM` \ ty' -> - returnM (UfLitLitAlt lit ty') \end{code} %********************************************************* diff --git a/ghc/compiler/rename/RnTypes.lhs b/ghc/compiler/rename/RnTypes.lhs index fed9f0d..8644587 100644 --- a/ghc/compiler/rename/RnTypes.lhs +++ b/ghc/compiler/rename/RnTypes.lhs @@ -24,9 +24,9 @@ import RnEnv ( lookupOccRn, lookupBndrRn, lookupSyntaxName, lookupGlobalOccRn, bindPatSigTyVarsFV, bindLocalsFV, warnUnusedMatches ) import TcRnMonad -import PrelNames( cCallishClassKeys, eqStringName, eqClassName, integralClassName, +import PrelNames( eqStringName, eqClassName, integralClassName, negateName, minusName, lengthPName, indexPName, plusIntegerName, fromIntegerName, - timesIntegerName, ratioDataConName, fromRationalName, cCallableClassName ) + timesIntegerName, ratioDataConName, fromRationalName ) import Constants ( mAX_TUPLE_SIZE ) import TysWiredIn ( intTyCon ) import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, @@ -264,19 +264,9 @@ rnContext doc ctxt returnM theta where - --Someone discovered that @CCallable@ and @CReturnable@ - -- could be used in contexts such as: - -- foo :: CCallable a => a -> PrimIO Int - -- Doing this utterly wrecks the whole point of introducing these - -- classes so we specifically check that this isn't being done. rn_pred pred = rnPred doc pred `thenM` \ pred'-> - checkErr (not (bad_pred pred')) - (naughtyCCallContextErr pred') `thenM_` returnM pred' - bad_pred (HsClassP clas _) = getUnique clas `elem` cCallishClassKeys - bad_pred other = False - rnPred doc (HsClassP clas tys) = lookupOccRn clas `thenM` \ clas_name -> @@ -506,7 +496,6 @@ litFVs (HsInt i) = returnM (unitFV (getName intTyCon)) litFVs (HsIntPrim i) = returnM (unitFV (getName intPrimTyCon)) litFVs (HsFloatPrim f) = returnM (unitFV (getName floatPrimTyCon)) litFVs (HsDoublePrim d) = returnM (unitFV (getName doublePrimTyCon)) -litFVs (HsLitLit l bogus_ty) = returnM (unitFV cCallableClassName) litFVs lit = pprPanic "RnExpr.litFVs" (ppr lit) -- HsInteger and HsRat only appear -- in post-typechecker translations bogusCharError c diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index b9f3671..ed1dacf 100644 --- a/ghc/compiler/stgSyn/StgSyn.lhs +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -34,7 +34,7 @@ module StgSyn ( -- utils stgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity, getArgPrimRep, - isLitLitArg, isDllConApp, isStgTypeArg, + isDllConApp, isStgTypeArg, stgArgType, stgBinders, pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs @@ -52,7 +52,7 @@ import Var ( isId ) import Id ( Id, idName, idPrimRep, idType, idCafInfo ) import IdInfo ( mayHaveCafRefs ) import Name ( isDllName ) -import Literal ( Literal, literalType, isLitLitLit, literalPrimRep ) +import Literal ( Literal, literalType, literalPrimRep ) import ForeignCall ( ForeignCall ) import DataCon ( DataCon, dataConName ) import CoreSyn ( AltCon ) @@ -107,17 +107,14 @@ data GenStgArg occ getArgPrimRep (StgVarArg local) = idPrimRep local getArgPrimRep (StgLitArg lit) = literalPrimRep lit -isLitLitArg (StgLitArg lit) = isLitLitLit lit -isLitLitArg _ = False - isStgTypeArg (StgTypeArg _) = True isStgTypeArg other = False isDllArg :: StgArg -> Bool -- Does this argument refer to something in a different DLL? -isDllArg (StgTypeArg v) = False +isDllArg (StgTypeArg v) = False isDllArg (StgVarArg v) = isDllName (idName v) -isDllArg (StgLitArg lit) = isLitLitLit lit +isDllArg (StgLitArg lit) = False isDllConApp :: DataCon -> [StgArg] -> Bool -- Does this constructor application refer to diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 9f3c684..61bfd60 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -27,7 +27,7 @@ module Inst ( isDict, isClassDict, isMethod, isLinearInst, linearInstType, isIPDict, isInheritableInst, isTyVarDict, isStdClassTyVarDict, isMethodFor, - instBindingRequired, instCanBeGeneralised, + instBindingRequired, zonkInst, zonkInsts, instToId, instName, @@ -65,7 +65,7 @@ import TcType ( Type, TcType, TcThetaType, TcTyVarSet, import CoreFVs ( idFreeTyVars ) import DataCon ( DataCon,dataConSig ) import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique ) -import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass ) +import PrelInfo ( isStandardClass, isNoDictClass ) import Name ( Name, mkMethodOcc, getOccName ) import PprType ( pprPred, pprParendType ) import Subst ( substTy, substTyWith, substTheta, mkTyVarSubst ) @@ -194,10 +194,6 @@ must be witnessed by an actual binding; the second tells whether an instBindingRequired :: Inst -> Bool instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas) instBindingRequired other = True - -instCanBeGeneralised :: Inst -> Bool -instCanBeGeneralised (Dict _ (ClassP clas _) _) = not (isCcallishClass clas) -instCanBeGeneralised other = True \end{code} diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index f889697..7b55afd 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -54,8 +54,7 @@ import TyCon ( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons ) import Subst ( mkTopTyVarSubst, substTheta, substTy ) import VarSet ( emptyVarSet, elemVarSet ) import TysWiredIn ( boolTy ) -import PrelNames ( cCallableClassName, cReturnableClassName, - enumFromName, enumFromThenName, +import PrelNames ( enumFromName, enumFromThenName, enumFromToName, enumFromThenToName, enumFromToPName, enumFromThenToPName, ioTyConName @@ -314,70 +313,6 @@ tcMonoExpr (HsProc pat cmd loc) res_ty returnM (HsProc pat' cmd' loc) \end{code} - -%************************************************************************ -%* * - Foreign calls -%* * -%************************************************************************ - -The interesting thing about @ccall@ is that it is just a template -which we instantiate by filling in details about the types of its -argument and result (ie minimal typechecking is performed). So, the -basic story is that we allocate a load of type variables (to hold the -arg/result types); unify them with the args/result; and store them for -later use. - -\begin{code} -tcMonoExpr e0@(HsCCall lbl args may_gc is_casm ignored_fake_result_ty) res_ty - - = getDOpts `thenM` \ dflags -> - - checkTc (not (is_casm && dopt_HscLang dflags /= HscC)) - (vcat [text "_casm_ is only supported when compiling via C (-fvia-C).", - text "Either compile with -fvia-C, or, better, rewrite your code", - text "to use the foreign function interface. _casm_s are deprecated", - text "and support for them may one day disappear."]) - `thenM_` - - -- Get the callable and returnable classes. - tcLookupClass cCallableClassName `thenM` \ cCallableClass -> - tcLookupClass cReturnableClassName `thenM` \ cReturnableClass -> - tcLookupTyCon ioTyConName `thenM` \ ioTyCon -> - let - new_arg_dict (arg, arg_ty) - = newDicts (CCallOrigin (unpackFS lbl) (Just arg)) - [mkClassPred cCallableClass [arg_ty]] `thenM` \ arg_dicts -> - returnM arg_dicts -- Actually a singleton bag - - result_origin = CCallOrigin (unpackFS lbl) Nothing {- Not an arg -} - in - - -- Arguments - let tv_idxs | null args = [] - | otherwise = [1..length args] - in - newTyVarTys (length tv_idxs) openTypeKind `thenM` \ arg_tys -> - tcCheckRhos args arg_tys `thenM` \ args' -> - - -- The argument types can be unlifted or lifted; the result - -- type must, however, be lifted since it's an argument to the IO - -- type constructor. - newTyVarTy liftedTypeKind `thenM` \ result_ty -> - let - io_result_ty = mkTyConApp ioTyCon [result_ty] - in - zapExpectedTo res_ty io_result_ty `thenM_` - - -- Construct the extra insts, which encode the - -- constraints on the argument and result types. - mappM new_arg_dict (zipEqual "tcMonoExpr:CCall" args arg_tys) `thenM` \ ccarg_dicts_s -> - newDicts result_origin [mkClassPred cReturnableClass [result_ty]] `thenM` \ ccres_dict -> - extendLIEs (ccres_dict ++ concat ccarg_dicts_s) `thenM_` - returnM (HsCCall lbl args' may_gc is_casm io_result_ty) -\end{code} - - %************************************************************************ %* * Record construction and update @@ -1025,14 +960,6 @@ Overloaded literals. \begin{code} tcLit :: HsLit -> Expected TcRhoType -> TcM TcExpr -tcLit (HsLitLit s _) res_ty - = zapExpectedType res_ty `thenM` \ res_ty' -> - tcLookupClass cCallableClassName `thenM` \ cCallableClass -> - newDicts (LitLitOrigin (unpackFS s)) - [mkClassPred cCallableClass [res_ty']] `thenM` \ dicts -> - extendLIEs dicts `thenM_` - returnM (HsLit (HsLitLit s res_ty')) - tcLit lit res_ty = zapExpectedTo res_ty (hsLitType lit) `thenM_` returnM (HsLit lit) diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index accb750..04e6ce4 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -46,7 +46,7 @@ import TcType ( Type, tcSplitFunTys, tcSplitTyConApp_maybe, toDNType ) import ForeignCall ( CExportSpec(..), CCallTarget(..), - isDynamicTarget, isCasmTarget, withDNTypes, DNKind(..), DNCallSpec(..) ) + isDynamicTarget, withDNTypes, DNKind(..), DNCallSpec(..) ) import CStrings ( CLabelString, isCLabelString ) import PrelNames ( hasKey, ioTyConKey ) import CmdLineOpts ( dopt_HscLang, HscLang(..) ) @@ -154,8 +154,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ _ (CFunction targe checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty `thenM_` return idecl | otherwise -- Normal foreign import - = checkCg (if isCasmTarget target - then checkC else checkCOrAsmOrDotNetOrInterp) `thenM_` + = checkCg (checkCOrAsmOrDotNetOrInterp) `thenM_` checkCTarget target `thenM_` getDOpts `thenM` \ dflags -> checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenM_` @@ -167,9 +166,6 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ _ (CFunction targe checkCTarget (StaticTarget str) = checkCg checkCOrAsmOrDotNetOrInterp `thenM_` check (isCLabelString str) (badCName str) - -checkCTarget (CasmTarget _) - = checkCg checkC \end{code} On an Alpha, with foreign export dynamic, due to a giant hack when diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 2b30c3c..dd27a91 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -191,7 +191,6 @@ hsLitType (HsInteger i) = integerTy hsLitType (HsRat _ ty) = ty hsLitType (HsFloatPrim f) = floatPrimTy hsLitType (HsDoublePrim d) = doublePrimTy -hsLitType (HsLitLit _ ty) = ty \end{code} %************************************************************************ @@ -488,10 +487,6 @@ zonkExpr env (HsLit (HsRat f ty)) = zonkTcTypeToType env ty `thenM` \ new_ty -> returnM (HsLit (HsRat f new_ty)) -zonkExpr env (HsLit (HsLitLit lit ty)) - = zonkTcTypeToType env ty `thenM` \ new_ty -> - returnM (HsLit (HsLitLit lit new_ty)) - zonkExpr env (HsLit lit) = returnM (HsLit lit) @@ -605,11 +600,6 @@ zonkExpr env (PArrSeqOut expr info) zonkArithSeq env info `thenM` \ new_info -> returnM (PArrSeqOut new_expr new_info) -zonkExpr env (HsCCall fun args may_gc is_casm result_ty) - = zonkExprs env args `thenM` \ new_args -> - zonkTcTypeToType env result_ty `thenM` \ new_result_ty -> - returnM (HsCCall fun new_args may_gc is_casm new_result_ty) - zonkExpr env (HsSCC lbl expr) = zonkExpr env expr `thenM` \ new_expr -> returnM (HsSCC lbl new_expr) diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 5295fec..ebfdb49 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -230,12 +230,6 @@ tcCoreExpr (UfVar name) tcCoreExpr (UfLit lit) = returnM (Lit lit) --- The dreaded lit-lits are also similar, except here the type --- is read in explicitly rather than being implicit -tcCoreExpr (UfLitLit lit ty) - = tcIfaceType ty `thenM` \ ty' -> - returnM (Lit (MachLitLit lit ty')) - tcCoreExpr (UfFCall cc ty) = tcIfaceType ty `thenM` \ ty' -> newUnique `thenM` \ u -> @@ -349,12 +343,6 @@ tcCoreAlt scrut_ty (UfLitAlt lit, names, rhs) tcCoreExpr rhs `thenM` \ rhs' -> returnM (LitAlt lit, [], rhs') -tcCoreAlt scrut_ty (UfLitLitAlt str ty, names, rhs) - = ASSERT( null names ) - tcCoreExpr rhs `thenM` \ rhs' -> - tcIfaceType ty `thenM` \ ty' -> - returnM (LitAlt (MachLitLit str ty'), [], rhs') - -- A case alternative is made quite a bit more complicated -- by the fact that we omit type annotations because we can -- work them out. True enough, but its not that easy! diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs index 207411c..cc45bf4 100644 --- a/ghc/compiler/typecheck/TcMType.lhs +++ b/ghc/compiler/typecheck/TcMType.lhs @@ -76,7 +76,7 @@ import Var ( TyVar, idType, idName, tyVarKind, tyVarName, isTyVar, -- others: import Generics ( validGenericMethodType ) import TcRnMonad -- TcType, amongst others -import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey ) +import PrelNames ( hasKey ) import ForeignCall ( Safety(..) ) import FunDeps ( grow ) import PprType ( pprPred, pprSourceType, pprTheta, pprClassPred ) @@ -1106,15 +1106,6 @@ checkValidInstHead ty -- Should be a source type }} check_inst_head dflags clas tys - | -- CCALL CHECK - -- A user declaration of a CCallable/CReturnable instance - -- must be for a "boxed primitive" type. - (clas `hasKey` cCallableClassKey - && not (ccallable_type first_ty)) - || (clas `hasKey` cReturnableClassKey - && not (creturnable_type first_ty)) - = failWithTc (nonBoxedPrimCCallErr clas first_ty) - -- If GlasgowExts then check at least one isn't a type variable | dopt Opt_GlasgowExts dflags = check_tyvars dflags clas tys @@ -1134,9 +1125,6 @@ check_inst_head dflags clas tys where (first_ty : _) = tys - ccallable_type ty = isFFIArgumentTy dflags PlayRisky ty - creturnable_type ty = isFFIImportResultTy dflags ty - head_shape_msg = parens (text "The instance type must be of form (T a b c)" $$ text "where T is not a synonym, and a,b,c are distinct type variables") @@ -1157,8 +1145,4 @@ undecidableMsg = ptext SLIT("Use -fallow-undecidable-instances to permit this") instTypeErr pp_ty msg = sep [ptext SLIT("Illegal instance declaration for") <+> quotes pp_ty, nest 4 msg] - -nonBoxedPrimCCallErr clas inst_ty - = hang (ptext SLIT("Unacceptable instance type for ccall-ish class")) - 4 (pprClassPred clas [inst_ty]) \end{code} diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 133db82..b0bb16b 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -36,7 +36,7 @@ import TysWiredIn ( stringTy ) import CmdLineOpts ( opt_IrrefutableTuples ) import DataCon ( DataCon, dataConFieldLabels, dataConSourceArity ) import PrelNames ( eqStringName, eqName, geName, negateName, minusName, - integralClassName, cCallableClassName ) + integralClassName ) import BasicTypes ( isBoxed ) import Bag import Outputable @@ -242,15 +242,6 @@ tcPat tc_bndr pat_in@(ConPatIn con_name arg_pats) pat_ty %************************************************************************ \begin{code} -tcPat tc_bndr (LitPat lit@(HsLitLit s _)) pat_ty - -- cf tcExpr on LitLits - = zapExpectedType pat_ty `thenM` \ pat_ty' -> - tcLookupClass cCallableClassName `thenM` \ cCallableClass -> - newDicts (LitLitOrigin (unpackFS s)) - [mkClassPred cCallableClass [pat_ty']] `thenM` \ dicts -> - extendLIEs dicts `thenM_` - returnM (LitPat (HsLitLit s pat_ty'), emptyBag, emptyBag, []) - tcPat tc_bndr pat@(LitPat lit@(HsString _)) pat_ty = zapExpectedType pat_ty `thenM` \ pat_ty' -> unifyTauTy pat_ty' stringTy `thenM_` diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index c5620e7..1408eda 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -919,8 +919,6 @@ data InstOrigin (Maybe RenamedHsExpr) -- Nothing if it's the result -- Just arg, for an argument - | LitLitOrigin String -- the litlit - | UnknownOrigin -- Help! I give up... \end{code} @@ -969,8 +967,6 @@ pprInstLoc (InstLoc orig locn ctxt) pp_orig (CCallOrigin clabel (Just arg_expr)) = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma, text "namely", quotes (ppr arg_expr)] - pp_orig (LitLitOrigin s) - = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)] pp_orig (UnknownOrigin) = ptext SLIT("...oops -- I don't know where the overloading came from!") \end{code} diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 1eadf03..1970ab3 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -33,7 +33,7 @@ import Inst ( lookupInst, LookupInstResult(..), isStdClassTyVarDict, isMethodFor, isMethod, instToId, tyVarsOfInsts, cloneDict, ipNamesOfInsts, ipNamesOfInst, dictPred, - instBindingRequired, instCanBeGeneralised, + instBindingRequired, newDictsFromOld, tcInstClassOp, getDictClassTys, isTyVarDict, instLoc, zonkInst, tidyInsts, tidyMoreInsts, @@ -53,7 +53,7 @@ import Name ( getOccName, getSrcLoc ) import NameSet ( NameSet, mkNameSet, elemNameSet ) import Class ( classBigSig, classKey ) import FunDeps ( oclose, grow, improve, pprEquationDoc ) -import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass ) +import PrelInfo ( isNumericClass ) import PrelNames ( splitName, fstName, sndName, showClassKey, eqClassKey, ordClassKey) import HscTypes ( GhciMode(Interactive) ) @@ -552,9 +552,6 @@ tcSimplifyInfer doc tau_tvs wanted_lie = inferLoop doc (varSetElems tau_tvs) wanted_lie `thenM` \ (qtvs, frees, binds, irreds) -> - -- Check for non-generalisable insts - mappM_ addCantGenErr (filter (not . instCanBeGeneralised) irreds) `thenM_` - extendLIEs frees `thenM_` returnM (qtvs, binds, map instToId irreds) @@ -1081,6 +1078,7 @@ data Avail | NoRhs -- Used for Insts like (CCallable f) -- where no witness is required. + -- ToDo: remove? | Rhs -- Used when there is a RHS TcExpr -- The RHS @@ -1773,10 +1771,6 @@ disambigGroup :: Bool -- True <=> simplifying at top-level interactive loop disambigGroup is_interactive dicts | any std_default_class classes -- Guaranteed all standard classes - -- See comment at the end of function for reasons as to - -- why the defaulting mechanism doesn't apply to groups that - -- include CCallable or CReturnable dicts. - && not (any isCcallishClass classes) = -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT -- SO, TRY DEFAULT TYPES IN ORDER @@ -1803,9 +1797,6 @@ disambigGroup is_interactive dicts Left _ -> bomb_out Right chosen_default_ty -> choose_default chosen_default_ty - | all isCreturnableClass classes -- Default CCall stuff to () - = choose_default unitTy - | otherwise -- No defaults = bomb_out @@ -2155,9 +2146,4 @@ reduceDepthErr n stack nest 4 (pprInstsInFull stack)] reduceDepthMsg n stack = nest 4 (pprInstsInFull stack) - ------------------------------------------------ -addCantGenErr inst - = addErrTc (sep [ptext SLIT("Cannot generalise these overloadings (in a _ccall_):"), - nest 4 (ppr inst <+> pprInstLoc (instLoc inst))]) \end{code} -- 1.7.10.4