Commit 6b6b25ae authored by Ian Lynagh's avatar Ian Lynagh

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

parents 51ac19ae ccfbfdaf
......@@ -709,7 +709,8 @@ pprUsage usage@UsageHomeModule{}
vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ]
)
pprUsage usage@UsageFile{}
= hsep [ptext (sLit "addDependentFile"), ppr (usg_file_path usage)]
= hsep [ptext (sLit "addDependentFile"),
doubleQuotes (text (usg_file_path usage))]
pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc
pprUsageImport usage usg_mod'
......
......@@ -329,8 +329,8 @@ link' dflags batch_attempt_linking hpt
return Succeeded
else do
debugTraceMsg dflags 1 (ptext (sLit "Linking") <+> text exe_file
<+> text "...")
compilationProgressMsg dflags $ showSDoc $
(ptext (sLit "Linking") <+> text exe_file <+> text "...")
-- Don't showPass in Batch mode; doLink will do that for us.
let link = case ghcLink dflags of
......
......@@ -590,7 +590,8 @@ class TypecheckedMod m => DesugaredMod m where
-- | The result of successful parsing.
data ParsedModule =
ParsedModule { pm_mod_summary :: ModSummary
, pm_parsed_source :: ParsedSource }
, pm_parsed_source :: ParsedSource
, pm_extra_src_files :: [FilePath] }
instance ParsedMod ParsedModule where
modSummary m = pm_mod_summary m
......@@ -676,8 +677,8 @@ parseModule :: GhcMonad m => ModSummary -> m ParsedModule
parseModule ms = do
hsc_env <- getSession
let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
rdr_module <- liftIO $ hscParse hsc_env_tmp ms
return (ParsedModule ms rdr_module)
hpm <- liftIO $ hscParse hsc_env_tmp ms
return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm))
-- | Typecheck and rename a parsed module.
--
......@@ -688,7 +689,9 @@ typecheckModule pmod = do
hsc_env <- getSession
let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
(tc_gbl_env, rn_info)
<- liftIO $ hscTypecheckRename hsc_env_tmp ms (parsedSource pmod)
<- liftIO $ hscTypecheckRename hsc_env_tmp ms $
HsParsedModule { hpm_module = parsedSource pmod,
hpm_src_files = pm_extra_src_files pmod }
details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env
return $
TypecheckedModule {
......
......@@ -83,7 +83,6 @@ import DsMeta ( templateHaskellNames )
import VarSet
import VarEnv ( emptyTidyEnv )
import Panic
import Data.List
#endif
import Id
......@@ -145,9 +144,12 @@ import UniqSupply ( initUs_ )
import Bag
import Exception
import Data.List
import Control.Monad
import Data.Maybe
import Data.IORef
import System.FilePath as FilePath
import System.Directory
#include "HsVersions.h"
......@@ -309,11 +311,11 @@ hscRnImportDecls hsc_env import_decls =
-- -----------------------------------------------------------------------------
-- | parse a file, returning the abstract syntax
hscParse :: HscEnv -> ModSummary -> IO (Located (HsModule RdrName))
hscParse :: HscEnv -> ModSummary -> IO HsParsedModule
hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary
-- internal version, that doesn't fail due to -Werror
hscParse' :: ModSummary -> Hsc (Located (HsModule RdrName))
hscParse' :: ModSummary -> Hsc HsParsedModule
hscParse' mod_summary = do
dflags <- getDynFlags
let src_filename = ms_hspp_file mod_summary
......@@ -342,8 +344,37 @@ hscParse' mod_summary = do
ppr rdr_module
liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $
ppSourceStats False rdr_module
return rdr_module
-- ToDo: free the string buffer later.
-- To get the list of extra source files, we take the list
-- that the parser gave us,
-- - eliminate files beginning with '<'. gcc likes to use
-- pseudo-filenames like "<built-in>" and "<command-line>"
-- - normalise them (elimiante differences between ./f and f)
-- - filter out the preprocessed source file
-- - filter out anything beginning with tmpdir
-- - remove duplicates
-- - filter out the .hs/.lhs source filename if we have one
--
let n_hspp = FilePath.normalise src_filename
srcs0 = nub $ filter (not . (tmpDir dflags `isPrefixOf`))
$ filter (not . (== n_hspp))
$ map FilePath.normalise
$ filter (not . (== '<') . head)
$ map unpackFS
$ srcfiles pst
srcs1 = case ml_hs_file (ms_location mod_summary) of
Just f -> filter (/= FilePath.normalise f) srcs0
Nothing -> srcs0
-- sometimes we see source files from earlier
-- preprocessing stages that cannot be found, so just
-- filter them out:
srcs2 <- liftIO $ filterM doesFileExist srcs1
return HsParsedModule {
hpm_module = rdr_module,
hpm_src_files = srcs2
}
-- XXX: should this really be a Maybe X? Check under which circumstances this
-- can become a Nothing and decide whether this should instead throw an
......@@ -353,7 +384,7 @@ type RenamedStuff =
Maybe LHsDocString))
-- | Rename and typecheck a module, additionally returning the renamed syntax
hscTypecheckRename :: HscEnv -> ModSummary -> Located (HsModule RdrName)
hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule
-> IO (TcGblEnv, RenamedStuff)
hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do
tc_result <- {-# SCC "Typecheck-Rename" #-}
......@@ -784,13 +815,13 @@ batchMsg hsc_env mb_mod_index recomp mod_summary =
hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv
hscFileFrontEnd mod_summary = do
rdr_module <- hscParse' mod_summary
hpm <- hscParse' mod_summary
hsc_env <- getHscEnv
dflags <- getDynFlags
tcg_env <-
{-# SCC "Typecheck-Rename" #-}
ioMsgMaybe $
tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module
tcRnModule hsc_env (ms_hsc_src mod_summary) False hpm
tcSafeOK <- liftIO $ readIORef (tcg_safeInfer tcg_env)
-- end of the Safe Haskell line, how to respond to user?
......
......@@ -99,6 +99,9 @@ module HscTypes (
IfaceTrustInfo, getSafeMode, setSafeMode, noIfaceTrustInfo,
trustInfoToNum, numToTrustInfo, IsSafeImport,
-- * result of the parser
HsParsedModule(..),
-- * Compilation errors and warnings
SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr,
throwOneError, handleSourceError,
......@@ -2041,6 +2044,24 @@ instance Outputable IfaceTrustInfo where
ppr (TrustInfo Sf_SafeInfered) = ptext $ sLit "safe-infered"
\end{code}
%************************************************************************
%* *
\subsection{Parser result}
%* *
%************************************************************************
\begin{code}
data HsParsedModule = HsParsedModule {
hpm_module :: Located (HsModule RdrName),
hpm_src_files :: [FilePath]
-- ^ extra source files (e.g. from #includes). The lexer collects
-- these from '# <file> <line>' pragmas, which the C preprocessor
-- leaves behind. These files and their timestamps are stored in
-- the .hi file, so that we can force recompilation if any of
-- them change (#3589)
}
\end{code}
%************************************************************************
%* *
\subsection{Linkable stuff}
......
......@@ -1129,6 +1129,7 @@ setFile code span buf len = do
let file = lexemeToFastString (stepOn buf) (len-2)
setAlrLastLoc $ alrInitialLoc file
setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
addSrcFile file
_ <- popLexState
pushLexState code
lexToken
......@@ -1482,6 +1483,7 @@ data PState = PState {
-- extensions
context :: [LayoutContext],
lex_state :: [Int],
srcfiles :: [FastString],
-- Used in the alternative layout rule:
-- These tokens are the next ones to be sent out. They are
-- just blindly emitted, without the rule looking at them again:
......@@ -1569,6 +1571,9 @@ setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} ()
getSrcLoc :: P RealSrcLoc
getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc
addSrcFile :: FastString -> P ()
addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } ()
setLastToken :: RealSrcSpan -> Int -> P ()
setLastToken loc len = P $ \s -> POk s {
last_loc=loc,
......@@ -1851,6 +1856,7 @@ mkPState flags buf loc =
extsBitmap = fromIntegral bitmap,
context = [],
lex_state = [bol, 0],
srcfiles = [],
alr_pending_implicit_tokens = [],
alr_next_token = Nothing,
alr_last_loc = alrInitialLoc (fsLit "<no file>"),
......
......@@ -121,13 +121,18 @@ import Control.Monad
tcRnModule :: HscEnv
-> HscSource
-> Bool -- True <=> save renamed syntax
-> Located (HsModule RdrName)
-> HsParsedModule
-> IO (Messages, Maybe TcGblEnv)
tcRnModule hsc_env hsc_src save_rn_syntax
(L loc (HsModule maybe_mod export_ies
HsParsedModule {
hpm_module =
(L loc (HsModule maybe_mod export_ies
import_decls local_decls mod_deprec
maybe_doc_hdr))
maybe_doc_hdr)),
hpm_src_files =
src_files
}
= do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
let { this_pkg = thisPackage (hsc_dflags hsc_env) ;
......@@ -207,7 +212,10 @@ tcRnModule hsc_env hsc_src save_rn_syntax
-- Report unused names
reportUnusedNames export_ies tcg_env ;
-- Dump output and return
-- add extra source files to tcg_dependent_files
addDependentFiles src_files ;
-- Dump output and return
tcDump tcg_env ;
return tcg_env
}}}}
......
......@@ -513,6 +513,12 @@ getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }
getDeclaredDefaultTys :: TcRn (Maybe [Type])
getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
addDependentFiles :: [FilePath] -> TcRn ()
addDependentFiles fs = do
ref <- fmap tcg_dependent_files getGblEnv
dep_files <- readTcRef ref
writeTcRef ref (fs ++ dep_files)
\end{code}
%************************************************************************
......
......@@ -294,7 +294,7 @@ data TcGblEnv
-- ^ Renamed decls, maybe. @Nothing@ <=> Don't retain renamed
-- decls.
tcg_dependent_files :: TcRef [FilePath], -- ^ dependencies from addDependentFile
tcg_dependent_files :: TcRef [FilePath], -- ^ dependencies from addDependentFile
tcg_ev_binds :: Bag EvBind, -- Top-level evidence bindings
tcg_binds :: LHsBinds Id, -- Value bindings in this module
......
......@@ -4206,18 +4206,24 @@ do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC,
{
int j;
char *symbol = NULL;
Elf_Addr targ;
Elf_Rela* rtab = (Elf_Rela*) (ehdrC + shdr[shnum].sh_offset);
Elf_Sym* stab;
char* strtab;
int nent = shdr[shnum].sh_size / sizeof(Elf_Rela);
int target_shndx = shdr[shnum].sh_info;
int symtab_shndx = shdr[shnum].sh_link;
int strtab_shndx = shdr[symtab_shndx].sh_link;
#if defined(DEBUG) || defined(sparc_HOST_ARCH) || defined(ia64_HOST_ARCH) || defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
/* This #ifdef only serves to avoid unused-var warnings. */
Elf_Addr targ;
int target_shndx = shdr[shnum].sh_info;
#endif
stab = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
strtab= (char*) (ehdrC + shdr[ strtab_shndx ].sh_offset);
#if defined(DEBUG) || defined(sparc_HOST_ARCH) || defined(ia64_HOST_ARCH) || defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
/* This #ifdef only serves to avoid set-but-not-used warnings */
targ = (Elf_Addr) (ehdrC + shdr[ target_shndx ].sh_offset);
#endif
IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d\n",
target_shndx, symtab_shndx ));
......@@ -4226,12 +4232,14 @@ do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC,
/* This #ifdef only serves to avoid unused-var warnings. */
Elf_Addr offset = rtab[j].r_offset;
Elf_Addr P = targ + offset;
Elf_Addr A = rtab[j].r_addend;
#endif
#if defined(sparc_HOST_ARCH) || defined(ia64_HOST_ARCH) || defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
Elf_Addr value;
#endif
Elf_Addr info = rtab[j].r_info;
Elf_Addr A = rtab[j].r_addend;
Elf_Addr S;
void* S_tmp;
Elf_Addr value;
# if defined(sparc_HOST_ARCH)
Elf_Word* pP = (Elf_Word*)P;
Elf_Word w1, w2;
......@@ -4286,7 +4294,9 @@ do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC,
(void*)P, (void*)S, (void*)A ));
/* checkProddableBlock ( oc, (void*)P ); */
#if defined(sparc_HOST_ARCH) || defined(ia64_HOST_ARCH) || defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
value = S + A;
#endif
switch (ELF_R_TYPE(info)) {
# if defined(sparc_HOST_ARCH)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment