Commit 7bb96844 authored by Ian Lynagh's avatar Ian Lynagh

Merge branch 'master' of http://darcs.haskell.org/ghc

parents 78d8681a 6490ea6d
......@@ -181,7 +181,7 @@ duDefs dus = foldr get emptyNameSet dus
get (Just d1, _u1) d2 = d1 `unionNameSets` d2
allUses :: DefUses -> Uses
-- ^ Just like 'allUses', but 'Defs' are not eliminated from the 'Uses' returned
-- ^ Just like 'duUses', but 'Defs' are not eliminated from the 'Uses' returned
allUses dus = foldr get emptyNameSet dus
where
get (_d1, u1) u2 = u1 `unionNameSets` u2
......@@ -189,8 +189,7 @@ allUses dus = foldr get emptyNameSet dus
duUses :: DefUses -> Uses
-- ^ Collect all 'Uses', regardless of whether the group is itself used,
-- but remove 'Defs' on the way
duUses dus
= foldr get emptyNameSet dus
duUses dus = foldr get emptyNameSet dus
where
get (Nothing, rhs_uses) uses = rhs_uses `unionNameSets` uses
get (Just defs, rhs_uses) uses = (rhs_uses `unionNameSets` uses)
......
......@@ -3,15 +3,7 @@
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\begin{code}
{-# OPTIONS -fno-warn-incomplete-patterns #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
{-# LANGUAGE DeriveDataTypeable #-}
-- | Abstract syntax of global declarations.
......@@ -630,15 +622,15 @@ instance OutputableBndr name
(ppr new_or_data <+>
(if isJust typats then ptext (sLit "instance") else empty) <+>
pp_decl_head (unLoc context) ltycon tyvars typats <+>
ppr_sig mb_sig)
ppr_sigx mb_sig)
(pp_condecls condecls)
derivings
where
ppr_sig Nothing = empty
ppr_sig (Just kind) = dcolon <+> pprKind kind
ppr_sigx Nothing = empty
ppr_sigx (Just kind) = dcolon <+> pprKind kind
ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars,
tcdFDs = fds,
tcdFDs = fds,
tcdSigs = sigs, tcdMeths = methods, tcdATs = ats})
| null sigs && null ats -- No "where" part
= top_matter
......@@ -773,14 +765,14 @@ instance (OutputableBndr name) => Outputable (ConDecl name) where
ppr = pprConDecl
pprConDecl :: OutputableBndr name => ConDecl name -> SDoc
pprConDecl (ConDecl { con_name =con, con_explicit = expl, con_qvars = tvs
pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
, con_cxt = cxt, con_details = details
, con_res = ResTyH98, con_doc = doc })
= sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details con details]
= sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details details]
where
ppr_details con (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2]
ppr_details con (PrefixCon tys) = hsep (pprHsVar con : map ppr tys)
ppr_details con (RecCon fields) = ppr con <+> pprConDeclFields fields
ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2]
ppr_details (PrefixCon tys) = hsep (pprHsVar con : map ppr tys)
ppr_details (RecCon fields) = ppr con <+> pprConDeclFields fields
pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
, con_cxt = cxt, con_details = PrefixCon arg_tys
......@@ -802,7 +794,7 @@ pprConDecl (ConDecl {con_name = con, con_details = InfixCon {}, con_res = ResTyG
%************************************************************************
%* *
\subsection[InstDecl]{An instance declaration
\subsection[InstDecl]{An instance declaration}
%* *
%************************************************************************
......@@ -835,7 +827,7 @@ instDeclATs inst_decls = [at | L _ (InstDecl _ _ _ ats) <- inst_decls, at <- ats
%************************************************************************
%* *
\subsection[DerivDecl]{A stand-alone instance deriving declaration
\subsection[DerivDecl]{A stand-alone instance deriving declaration}
%* *
%************************************************************************
......
......@@ -6,12 +6,6 @@
HsImpExp: Abstract syntax: imports, exports, interfaces
\begin{code}
{-# OPTIONS -fno-warn-incomplete-patterns #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
{-# LANGUAGE DeriveDataTypeable #-}
module HsImpExp where
......@@ -103,6 +97,7 @@ ieName (IEVar n) = n
ieName (IEThingAbs n) = n
ieName (IEThingWith n _) = n
ieName (IEThingAll n) = n
ieName _ = panic "ieName failed pattern match!"
ieNames :: IE a -> [a]
ieNames (IEVar n ) = [n]
......@@ -122,8 +117,8 @@ instance (Outputable name) => Outputable (IE name) where
ppr (IEThingAll thing) = hcat [ppr thing, text "(..)"]
ppr (IEThingWith thing withs)
= ppr thing <> parens (fsep (punctuate comma (map pprHsVar withs)))
ppr (IEModuleContents mod)
= ptext (sLit "module") <+> ppr mod
ppr (IEModuleContents mod')
= ptext (sLit "module") <+> ppr mod'
ppr (IEGroup n _) = text ("<IEGroup: " ++ (show n) ++ ">")
ppr (IEDoc doc) = ppr doc
ppr (IEDocNamed string) = text ("<IEDocNamed: " ++ string ++ ">")
......
......@@ -900,8 +900,8 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names
finsts_mod = mi_finsts iface
hash_env = mi_hash_fn iface
mod_hash = mi_mod_hash iface
export_hash | depend_on_exports mod = Just (mi_exp_hash iface)
| otherwise = Nothing
export_hash | depend_on_exports = Just (mi_exp_hash iface)
| otherwise = Nothing
used_occs = lookupModuleEnv ent_map mod `orElse` []
......@@ -918,21 +918,21 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names
Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names)
Just r -> r
depend_on_exports mod =
case lookupModuleEnv direct_imports mod of
Just _ -> True
-- Even if we used 'import M ()', we have to register a
-- usage on the export list because we are sensitive to
-- changes in orphan instances/rules.
Nothing -> False
-- In GHC 6.8.x the above line read "True", and in
-- fact it recorded a dependency on *all* the
-- modules underneath in the dependency tree. This
-- happens to make orphans work right, but is too
-- expensive: it'll read too many interface files.
-- The 'isNothing maybe_iface' check above saved us
-- from generating many of these usages (at least in
-- one-shot mode), but that's even more bogus!
depend_on_exports = is_direct_import
{- True
Even if we used 'import M ()', we have to register a
usage on the export list because we are sensitive to
changes in orphan instances/rules.
False
In GHC 6.8.x we always returned true, and in
fact it recorded a dependency on *all* the
modules underneath in the dependency tree. This
happens to make orphans work right, but is too
expensive: it'll read too many interface files.
The 'isNothing maybe_iface' check above saved us
from generating many of these usages (at least in
one-shot mode), but that's even more bogus!
-}
\end{code}
\begin{code}
......
......@@ -16,7 +16,6 @@ module DriverMkDepend (
#include "HsVersions.h"
import qualified GHC
-- import GHC ( ModSummary(..), GhcMonad )
import GhcMonad
import HsSyn ( ImportDecl(..) )
import DynFlags
......@@ -35,7 +34,6 @@ import FastString
import Exception
import ErrUtils
-- import MonadUtils ( liftIO )
import System.Directory
import System.FilePath
......
......@@ -779,9 +779,9 @@ runPhase (Cpp sf) input_fn dflags0
src_opts <- io $ getOptionsFromFile dflags0 output_fn
(dflags2, unhandled_flags, warns)
<- io $ parseDynamicNoPackageFlags dflags0 src_opts
io $ checkProcessArgsResult unhandled_flags
unless (dopt Opt_Pp dflags2) $ io $ handleFlagWarnings dflags2 warns
-- the HsPp pass below will emit warnings
io $ checkProcessArgsResult unhandled_flags
setDynFlags dflags2
......@@ -814,8 +814,8 @@ runPhase (HsPp sf) input_fn dflags
(dflags1, unhandled_flags, warns)
<- io $ parseDynamicNoPackageFlags dflags src_opts
setDynFlags dflags1
io $ handleFlagWarnings dflags1 warns
io $ checkProcessArgsResult unhandled_flags
io $ handleFlagWarnings dflags1 warns
return (Hsc sf, output_fn)
......
......@@ -1405,17 +1405,14 @@ preprocessFile hsc_env src_fn mb_phase Nothing
preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
= do
let dflags = hsc_dflags hsc_env
-- case we bypass the preprocessing stage?
let
local_opts = getOptions dflags buf src_fn
--
let local_opts = getOptions dflags buf src_fn
(dflags', leftovers, warns)
<- parseDynamicNoPackageFlags dflags local_opts
checkProcessArgsResult leftovers
handleFlagWarnings dflags' warns
let
needs_preprocessing
let needs_preprocessing
| Just (Unlit _) <- mb_phase = True
| Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True
-- note: local_opts is only required if there's no Unlit phase
......
......@@ -1132,12 +1132,11 @@ hscTcExpr -- Typecheck an expression (but don't run it)
hscTcExpr hsc_env expr = runHsc hsc_env $ do
maybe_stmt <- hscParseStmt expr
case maybe_stmt of
Just (L _ (ExprStmt expr _ _)) ->
ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr
_ ->
liftIO $ throwIO $ mkSrcErr $ unitBag $
mkPlainErrMsg noSrcSpan
(text "not an expression:" <+> quotes (text expr))
Just (L _ (ExprStmt expr _ _)) ->
ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr
_ ->
liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg noSrcSpan
(text "not an expression:" <+> quotes (text expr))
-- | Find the kind of a type
hscKcType
......
......@@ -717,7 +717,7 @@ type ImportedMods = ModuleEnv [(ModuleName, Bool, SrcSpan)]
-- | A ModGuts is carried through the compiler, accumulating stuff as it goes
-- There is only one ModGuts at any time, the one for the module
-- being compiled right now. Once it is compiled, a 'ModIface' and
-- 'ModDetails' are extracted and the ModGuts is dicarded.
-- 'ModDetails' are extracted and the ModGuts is discarded.
data ModGuts
= ModGuts {
mg_module :: !Module, -- ^ Module being compiled
......
......@@ -1856,7 +1856,7 @@ pragState dynflags buf loc = (mkPState dynflags buf loc) {
mkPState :: DynFlags -> StringBuffer -> SrcLoc -> PState
mkPState flags buf loc =
PState {
buffer = buf,
buffer = buf,
dflags = flags,
messages = emptyMessages,
last_loc = mkSrcSpan loc loc,
......@@ -1873,34 +1873,34 @@ mkPState flags buf loc =
alr_justClosedExplicitLetBlock = False
}
where
bitmap = genericsBit `setBitIf` xopt Opt_Generics flags
.|. ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags
.|. parrBit `setBitIf` xopt Opt_ParallelArrays flags
.|. arrowsBit `setBitIf` xopt Opt_Arrows flags
.|. thBit `setBitIf` xopt Opt_TemplateHaskell flags
.|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags
.|. ipBit `setBitIf` xopt Opt_ImplicitParams flags
.|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags
.|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags
.|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags
.|. haddockBit `setBitIf` dopt Opt_Haddock flags
.|. magicHashBit `setBitIf` xopt Opt_MagicHash flags
.|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags
.|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags
.|. recBit `setBitIf` xopt Opt_DoRec flags
.|. recBit `setBitIf` xopt Opt_Arrows flags
.|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags
.|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags
bitmap = genericsBit `setBitIf` xopt Opt_Generics flags
.|. ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags
.|. parrBit `setBitIf` xopt Opt_ParallelArrays flags
.|. arrowsBit `setBitIf` xopt Opt_Arrows flags
.|. thBit `setBitIf` xopt Opt_TemplateHaskell flags
.|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags
.|. ipBit `setBitIf` xopt Opt_ImplicitParams flags
.|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags
.|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags
.|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags
.|. haddockBit `setBitIf` dopt Opt_Haddock flags
.|. magicHashBit `setBitIf` xopt Opt_MagicHash flags
.|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags
.|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags
.|. recBit `setBitIf` xopt Opt_DoRec flags
.|. recBit `setBitIf` xopt Opt_Arrows flags
.|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags
.|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags
.|. datatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags
.|. transformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags
.|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags
.|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags
.|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags
.|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags
.|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags
--
setBitIf :: Int -> Bool -> Int
b `setBitIf` cond | cond = bit b
| otherwise = 0
| otherwise = 0
addWarning :: DynFlag -> SrcSpan -> SDoc -> P ()
addWarning option srcspan warning
......
......@@ -54,7 +54,7 @@ Well, of course you'd need a lot of rules if you did it
like that, so we use a BuiltinRule instead, so that we
can match in any two literal values. So the rule is really
more like
(Lit 4) +# (Lit y) = Lit (x+#y)
(Lit x) +# (Lit y) = Lit (x+#y)
where the (+#) on the rhs is done at compile time
That is why these rules are built in here. Other rules
......
......@@ -1252,4 +1252,4 @@ add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind"
add_sig :: LSig a -> HsValBinds a -> HsValBinds a
add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig"
\end{code}
\ No newline at end of file
\end{code}
......@@ -12,11 +12,11 @@ is restricted to what the outside world understands (read C), and this
module checks to see if a foreign declaration has got a legal type.
\begin{code}
module TcForeign
(
tcForeignImports
module TcForeign
(
tcForeignImports
, tcForeignExports
) where
) where
#include "HsVersions.h"
......@@ -43,18 +43,18 @@ import FastString
-- Defines a binding
isForeignImport :: LForeignDecl name -> Bool
isForeignImport (L _ (ForeignImport _ _ _)) = True
isForeignImport _ = False
isForeignImport _ = False
-- Exports a binding
isForeignExport :: LForeignDecl name -> Bool
isForeignExport (L _ (ForeignExport _ _ _)) = True
isForeignExport _ = False
isForeignExport _ = False
\end{code}
%************************************************************************
%* *
%* *
\subsection{Imports}
%* *
%* *
%************************************************************************
\begin{code}
......@@ -64,22 +64,22 @@ tcForeignImports decls
tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
= addErrCtxt (foreignDeclCtxt fo) $
do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
; let
-- Drop the foralls before inspecting the
-- structure of the foreign type.
(_, t_ty) = tcSplitForAllTys sig_ty
(arg_tys, res_ty) = tcSplitFunTys t_ty
id = mkLocalId nm sig_ty
-- Use a LocalId to obey the invariant that locally-defined
-- things are LocalIds. However, it does not need zonking,
-- (so TcHsSyn.zonkForeignExports ignores it).
; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
-- Can't use sig_ty here because sig_ty :: Type and
-- we need HsType Id hence the undefined
; return (id, ForeignImport (L loc id) undefined imp_decl') }
= addErrCtxt (foreignDeclCtxt fo) $
do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
; let
-- Drop the foralls before inspecting the
-- structure of the foreign type.
(_, t_ty) = tcSplitForAllTys sig_ty
(arg_tys, res_ty) = tcSplitFunTys t_ty
id = mkLocalId nm sig_ty
-- Use a LocalId to obey the invariant that locally-defined
-- things are LocalIds. However, it does not need zonking,
-- (so TcHsSyn.zonkForeignExports ignores it).
; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
-- Can't use sig_ty here because sig_ty :: Type and
-- we need HsType Id hence the undefined
; return (id, ForeignImport (L loc id) undefined imp_decl') }
tcFImport d = pprPanic "tcFImport" (ppr d)
\end{code}
......@@ -93,15 +93,15 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ (CLabel _))
do { checkCg checkCOrAsmOrLlvmOrInterp
; checkSafety safety
; check (isFFILabelTy res_ty) (illegalForeignTyErr empty sig_ty)
; return idecl } -- NB check res_ty not sig_ty!
-- In case sig_ty is (forall a. ForeignPtr a)
; return idecl } -- NB check res_ty not sig_ty!
-- In case sig_ty is (forall a. ForeignPtr a)
tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ CWrapper) = do
-- Foreign wrapper (former f.e.d.)
-- The type must be of the form ft -> IO (FunPtr ft), where ft is a
-- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well
-- as ft -> IO Addr is accepted, too. The use of the latter two forms
-- is DEPRECATED, though.
-- Foreign wrapper (former f.e.d.)
-- The type must be of the form ft -> IO (FunPtr ft), where ft is a
-- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well
-- as ft -> IO Addr is accepted, too. The use of the latter two forms
-- is DEPRECATED, though.
checkCg checkCOrAsmOrLlvmOrInterp
checkCConv cconv
checkSafety safety
......@@ -174,14 +174,14 @@ checkMissingAmpersand dflags arg_tys res_ty
\end{code}
%************************************************************************
%* *
%* *
\subsection{Exports}
%* *
%* *
%************************************************************************
\begin{code}
tcForeignExports :: [LForeignDecl Name]
-> TcM (LHsBinds TcId, [LForeignDecl TcId])
tcForeignExports :: [LForeignDecl Name]
-> TcM (LHsBinds TcId, [LForeignDecl TcId])
tcForeignExports decls
= foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
where
......@@ -190,25 +190,25 @@ tcForeignExports decls
return (b `consBag` binds, f:fs)
tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
addErrCtxt (foreignDeclCtxt fo) $ do
tcFExport fo@(ForeignExport (L loc nm) hs_ty spec)
= addErrCtxt (foreignDeclCtxt fo) $ do
sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
rhs <- tcPolyExpr (nlHsVar nm) sig_ty
sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
rhs <- tcPolyExpr (nlHsVar nm) sig_ty
tcCheckFEType sig_ty spec
tcCheckFEType sig_ty spec
-- we're exporting a function, but at a type possibly more
-- constrained than its declared/inferred type. Hence the need
-- to create a local binding which will call the exported function
-- at a particular type (and, maybe, overloading).
-- we're exporting a function, but at a type possibly more
-- constrained than its declared/inferred type. Hence the need
-- to create a local binding which will call the exported function
-- at a particular type (and, maybe, overloading).
-- We need to give a name to the new top-level binding that
-- is *stable* (i.e. the compiler won't change it later),
-- because this name will be referred to by the C code stub.
id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
return (mkVarBind id rhs, ForeignExport (L loc id) undefined spec)
-- We need to give a name to the new top-level binding that
-- is *stable* (i.e. the compiler won't change it later),
-- because this name will be referred to by the C code stub.
id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
return (mkVarBind id rhs, ForeignExport (L loc id) undefined spec)
tcFExport d = pprPanic "tcFExport" (ppr d)
\end{code}
......@@ -232,9 +232,9 @@ tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do
%************************************************************************
%* *
%* *
\subsection{Miscellaneous}
%* *
%* *
%************************************************************************
\begin{code}
......@@ -246,7 +246,7 @@ checkForeignArgs pred tys
go ty = check (pred ty) (illegalForeignTyErr argument ty)
------------ Checking result types for foreign calls ----------------------
-- Check that the type has the form
-- Check that the type has the form
-- (IO t) or (t) , and that t satisfies the given predicate.
--
checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
......@@ -256,14 +256,14 @@ nonIOok = True
mustBeIO = False
checkForeignRes non_io_result_ok pred_res_ty ty
-- (IO t) is ok, and so is any newtype wrapping thereof
-- (IO t) is ok, and so is any newtype wrapping thereof
| Just (_, res_ty, _) <- tcSplitIOType_maybe ty,
pred_res_ty res_ty
= return ()
| otherwise
= check (non_io_result_ok && pred_res_ty ty)
(illegalForeignTyErr result ty)
= check (non_io_result_ok && pred_res_ty ty)
(illegalForeignTyErr result ty)
\end{code}
\begin{code}
......@@ -272,7 +272,7 @@ checkCOrAsmOrLlvm HscC = Nothing
checkCOrAsmOrLlvm HscAsm = Nothing
checkCOrAsmOrLlvm HscLlvm = Nothing
checkCOrAsmOrLlvm _
= Just (text "requires via-C, llvm (-fllvm) or native code generation (-fvia-C)")
= Just (text "requires via-C, llvm (-fllvm) or native code generation (-fvia-C)")
checkCOrAsmOrLlvmOrInterp :: HscTarget -> Maybe SDoc
checkCOrAsmOrLlvmOrInterp HscC = Nothing
......@@ -280,7 +280,7 @@ checkCOrAsmOrLlvmOrInterp HscAsm = Nothing
checkCOrAsmOrLlvmOrInterp HscLlvm = Nothing
checkCOrAsmOrLlvmOrInterp HscInterpreted = Nothing
checkCOrAsmOrLlvmOrInterp _
= Just (text "requires interpreted, C, Llvm or native code generation")
= Just (text "requires interpreted, C, Llvm or native code generation")
checkCOrAsmOrLlvmOrDotNetOrInterp :: HscTarget -> Maybe SDoc
checkCOrAsmOrLlvmOrDotNetOrInterp HscC = Nothing
......@@ -288,33 +288,33 @@ checkCOrAsmOrLlvmOrDotNetOrInterp HscAsm = Nothing
checkCOrAsmOrLlvmOrDotNetOrInterp HscLlvm = Nothing
checkCOrAsmOrLlvmOrDotNetOrInterp HscInterpreted = Nothing
checkCOrAsmOrLlvmOrDotNetOrInterp _
= Just (text "requires interpreted, C, Llvm or native code generation")
= Just (text "requires interpreted, C, Llvm or native code generation")
checkCg :: (HscTarget -> Maybe SDoc) -> TcM ()
checkCg check = do
dflags <- getDOpts
let target = hscTarget dflags
case target of
HscNothing -> return ()
_ ->
case check target of
Nothing -> return ()
Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
dflags <- getDOpts
let target = hscTarget dflags
case target of
HscNothing -> return ()
_ ->
case check target of
Nothing -> return ()
Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
\end{code}
Calling conventions
\begin{code}
checkCConv :: CCallConv -> TcM ()
checkCConv CCallConv = return ()
checkCConv CCallConv = return ()
#if i386_TARGET_ARCH
checkCConv StdCallConv = return ()
checkCConv StdCallConv = return ()
#else
-- This is a warning, not an error. see #3336
checkCConv StdCallConv = addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform,"$$ text "treating as ccall")
checkCConv StdCallConv = addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall")
#endif
checkCConv PrimCallConv = addErrTc (text "The `prim' calling convention can only be used with `foreign import'")
checkCConv CmmCallConv = panic "checkCConv CmmCallConv"
checkCConv CmmCallConv = panic "checkCConv CmmCallConv"
\end{code}
Deprecated "threadsafe" calls
......@@ -329,12 +329,12 @@ Warnings
\begin{code}
check :: Bool -> Message -> TcM ()
check True _ = return ()
check True _ = return ()
check _ the_err = addErrTc the_err
illegalForeignTyErr :: SDoc -> Type -> SDoc
illegalForeignTyErr arg_or_res ty
= hang (hsep [ptext (sLit "Unacceptable"), arg_or_res,
= hang (hsep [ptext (sLit "Unacceptable"), arg_or_res,
ptext (sLit "type in foreign declaration:")])
2 (hsep [ppr ty])
......@@ -344,12 +344,11 @@ argument = text "argument"
result = text "result"
badCName :: CLabelString -> Message
badCName target
= sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
badCName target
= sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
foreignDeclCtxt :: ForeignDecl Name -> SDoc
foreignDeclCtxt fo
= hang (ptext (sLit "When checking declaration:"))
2 (ppr fo)
\end{code}
......@@ -639,7 +639,7 @@ plusImportAvails
(ImportAvails { imp_mods = mods2,
imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2,
imp_orphs = orphs2, imp_finsts = finsts2 })
= ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2,
= ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2,
imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2,
imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2,