Commit c464eda3 authored by simonmar's avatar simonmar

[project @ 2005-01-14 17:57:41 by simonmar]

HEADS UP!  You now need to use an up to date Happy from CVS to build
GHC.  Happy version 1.15 will be released shortly.

Replace the slow hacked up String-based GetImports with one based on
the real Haskell parser.  This requires a new addition to Happy to
support parsing partial files.  We now avoid reading each source file
off the disk twice: once to get its module name and imports, and again
to parse it.  Instead we just slurp it once, and cache the StringBuffer.

This should result in improved startup times for ghc --make,
especially when there are lots of source files.
parent c7333e5d
......@@ -44,6 +44,7 @@ import Maybes ( expectJust )
import UniqFM
import UniqSet
import Binary
import StringBuffer ( StringBuffer )
import FastString
\end{code}
......@@ -57,19 +58,26 @@ import FastString
data ModLocation
= ModLocation {
ml_hs_file :: Maybe FilePath,
ml_hspp_file :: Maybe FilePath, -- Path of preprocessed source
ml_hi_file :: FilePath, -- Where the .hi file is, whether or not it exists
-- Always of form foo.hi, even if there is an hi-boot
-- file (we add the -boot suffix later)
ml_obj_file :: FilePath -- Where the .o file is, whether or not it exists
-- (might not exist either because the module
-- hasn't been compiled yet, or because
-- it is part of a package with a .a file)
}
deriving Show
-- the source file, if we have one. Package modules
-- probably don't have source files.
ml_hspp_file :: Maybe FilePath,
-- filename of preprocessed source, if we have
-- preprocessed it.
ml_hspp_buf :: Maybe StringBuffer,
-- the actual preprocessed source, maybe.
ml_hi_file :: FilePath,
-- Where the .hi file is, whether or not it exists
-- yet. Always of form foo.hi, even if there is an
-- hi-boot file (we add the -boot suffix later)
ml_obj_file :: FilePath
-- Where the .o file is, whether or not it exists yet.
-- (might not exist either because the module hasn't
-- been compiled yet, or because it is part of a
-- package with a .a file)
} deriving Show
instance Outputable ModLocation where
ppr = text . show
......
......@@ -71,6 +71,7 @@ import Digraph ( SCC(..), stronglyConnComp, flattenSCC, flattenSCCs )
import ErrUtils ( showPass )
import SysTools ( cleanTempFilesExcept )
import BasicTypes ( SuccessFlag(..), succeeded, failed )
import StringBuffer ( hGetStringBuffer )
import Util
import Outputable
import Panic
......@@ -1146,7 +1147,13 @@ noModError dflags loc mod_nm err
summariseFile :: DynFlags -> FilePath -> IO ModSummary
summariseFile dflags file
= do hspp_fn <- preprocess dflags file
(srcimps,imps,mod) <- getImportsFromFile hspp_fn
-- Read the file into a buffer. We're going to cache
-- this buffer in the ModLocation (ml_hspp_buf) so that it
-- doesn't have to be slurped again when hscMain parses the
-- file later.
buf <- hGetStringBuffer hspp_fn
(srcimps,imps,mod) <- getImports dflags buf hspp_fn
let -- GHC.Prim doesn't exist physically, so don't go looking for it.
the_imps = filter (/= gHC_PRIM) imps
......@@ -1159,7 +1166,8 @@ summariseFile dflags file
Just src_fn -> getModificationTime src_fn
return (ModSummary { ms_mod = mod,
ms_location = location{ml_hspp_file=Just hspp_fn},
ms_location = location{ ml_hspp_file = Just hspp_fn,
ml_hspp_buf = Just buf },
ms_srcimps = srcimps, ms_imps = the_imps,
ms_hs_date = src_timestamp })
......@@ -1183,7 +1191,9 @@ summarise dflags mod location old_summary
_ -> do
hspp_fn <- preprocess dflags hs_fn
(srcimps,imps,mod_name) <- getImportsFromFile hspp_fn
buf <- hGetStringBuffer hspp_fn
(srcimps,imps,mod_name) <- getImports dflags buf hspp_fn
let
-- GHC.Prim doesn't exist physically, so don't go looking for it.
the_imps = filter (/= gHC_PRIM) imps
......@@ -1194,7 +1204,8 @@ summarise dflags mod location old_summary
<> text ": file name does not match module name"
<+> quotes (ppr mod))))
return (Just (ModSummary mod location{ml_hspp_file=Just hspp_fn}
return (Just (ModSummary mod location{ ml_hspp_file = Just hspp_fn,
ml_hspp_buf = Just buf }
srcimps the_imps src_timestamp))
}
}
......
-----------------------------------------------------------------------------
-- $Id: DriverMkDepend.hs,v 1.34 2004/11/26 16:20:52 simonmar Exp $
-- $Id: DriverMkDepend.hs,v 1.35 2005/01/14 17:57:46 simonmar Exp $
--
-- GHC Driver
--
......@@ -14,7 +14,7 @@ module DriverMkDepend (
#include "HsVersions.h"
import HscTypes ( IfacePackage(..) )
import GetImports ( getImports )
import GetImports ( getImportsFromFile )
import CmdLineOpts ( DynFlags )
import DriverState
import DriverUtil
......@@ -123,8 +123,8 @@ beginMkDependHS = do
doMkDependHSPhase dflags basename suff input_fn
= do src <- readFile input_fn
let (import_sources, import_normals, mod_name) = getImports src
= do (import_sources, import_normals, mod_name)
<- getImportsFromFile dflags input_fn
let orig_fn = basename ++ '.':suff
location' <- mkHomeModLocation mod_name orig_fn
......
......@@ -44,6 +44,7 @@ import Config
import RdrName ( GlobalRdrEnv )
import Panic
import Util
import StringBuffer ( hGetStringBuffer )
import BasicTypes ( SuccessFlag(..) )
import Maybes ( expectJust )
......@@ -557,14 +558,16 @@ runPhase Hsc dflags basename suff input_fn get_output_fn _maybe_loc = do
writeIORef v_Include_paths (current_dir : paths)
-- gather the imports and module name
(_,_,mod_name) <-
(hspp_buf,mod_name) <-
if isExtCoreFilename ('.':suff)
then do
-- no explicit imports in ExtCore input.
m <- getCoreModuleName input_fn
return ([], [], mkModule m)
else
getImportsFromFile input_fn
return (Nothing, mkModule m)
else do
buf <- hGetStringBuffer input_fn
(_,_,mod_name) <- getImports dflags buf input_fn
return (Just buf, mod_name)
-- build a ModLocation to pass to hscMain.
location' <- mkHomeModLocation mod_name (basename ++ '.':suff)
......@@ -618,7 +621,8 @@ runPhase Hsc dflags basename suff input_fn get_output_fn _maybe_loc = do
-- run the compiler!
result <- hscMain hsc_env printErrorsAndWarnings mod_name
location{ ml_hspp_file=Just input_fn }
location{ ml_hspp_file = Just input_fn,
ml_hspp_buf = hspp_buf }
source_unchanged
False
Nothing -- no iface
......
......@@ -280,7 +280,8 @@ mkPackageModLocation pkg_info hisuf mod path basename _ext = do
hiOnlyModLocation path basename hisuf
= do let full_basename = path++'/':basename
obj_fn <- mkObjPath full_basename basename
return ModLocation{ ml_hspp_file = Nothing,
return ModLocation{ ml_hspp_file = Nothing,
ml_hspp_buf = Nothing,
ml_hs_file = Nothing,
ml_hi_file = full_basename ++ '.':hisuf,
-- Remove the .hi-boot suffix from
......@@ -338,6 +339,7 @@ mkHomeModLocation' mod src_basename ext = do
hi_fn <- mkHiPath src_basename mod_basename
let loc = ModLocation{ ml_hspp_file = Nothing,
ml_hspp_buf = Nothing,
ml_hs_file = Just (src_basename ++ '.':ext),
ml_hi_file = hi_fn,
ml_obj_file = obj_fn }
......
-----------------------------------------------------------------------------
-- $Id: GetImports.hs,v 1.11 2004/11/26 16:20:57 simonmar Exp $
--
-- GHC Driver program
-- Parsing the top of a Haskell source file to get its module name
-- and imports.
--
-- (c) Simon Marlow 2000
-- (c) Simon Marlow 2005
--
-----------------------------------------------------------------------------
module GetImports ( getImportsFromFile, getImports ) where
import Module
#include "HsVersions.h"
import Parser ( parseHeader )
import Lexer ( P(..), ParseResult(..), mkPState )
import HsSyn ( ImportDecl(..), HsModule(..) )
import Module ( Module, mkModule )
import StringBuffer ( StringBuffer, hGetStringBuffer )
import SrcLoc ( Located(..), mkSrcLoc, unLoc )
import FastString ( mkFastString )
import CmdLineOpts ( DynFlags )
import ErrUtils
import Pretty
import Panic
import Bag ( unitBag )
import EXCEPTION ( throwDyn )
import IO
import List
import Char
-- getImportsFromFile is careful to close the file afterwards, otherwise
-- we can end up with a large number of open handles before the garbage
-- collector gets around to closing them.
getImportsFromFile :: String -> IO ([Module], [Module], Module)
getImportsFromFile filename
= do hdl <- openFile filename ReadMode
modsrc <- hGetContents hdl
let (srcimps,imps,mod_name) = getImports modsrc
length srcimps `seq` length imps `seq` return ()
hClose hdl
return (srcimps,imps,mod_name)
getImports :: String -> ([Module], [Module], Module)
getImports s
= case f [{-accum source imports-}] [{-accum normal imports-}]
Nothing (clean s) of
(si, ni, Nothing) -> (si, ni, mkModule "Main")
(si, ni, Just me) -> (si, ni, me)
where
-- Only pick up the name following 'module' the first time.
-- Otherwise, we would be fooled by 'module Me ( module Wrong )'
-- and conclude that the module name is Wrong instead of Me.
f si ni old_me ("eludom" : me : ws)
= case old_me of
Nothing -> f si ni (Just (mkMN me)) ws
Just _ -> f si ni old_me ws
f si ni me ("ngierof" : "tropmi" : ws) = f si ni me ws
f si ni me ("tropmi" : "#-{" : "ECRUOS" : "}-#" : "deifilauq" : m : ws)
= f ((mkMN m):si) ni me ws
f si ni me ("tropmi" : "#-{" : "ECRUOS" : "}-#" : m : ws)
= f ((mkMN m):si) ni me ws
-- skip other contents of pragma comments
f si ni me ("#-{" : ws)
= f si ni me (drop 1 (dropWhile (/= "}-#") ws))
f si ni me ("tropmi" : "deifilauq" : m : ws)
= f si ((mkMN m):ni) me ws
f si ni me ("tropmi" : m : ws)
= f si ((mkMN m):ni) me ws
f si ni me (w:ws) = f si ni me ws
f si ni me [] = (nub si, nub ni, me)
mkMN str = mkModule (takeWhile isModId (reverse str))
isModId c = isAlphaNum c || c `elem` "'._"
-- remove literals and comments from a string, producing a
-- list of reversed words.
clean :: String -> [String]
clean s
= keep "" s
where
-- running through text we want to keep
keep acc [] = cons acc []
keep acc (c:cs) | isSpace c = cons acc (keep "" cs)
keep acc ('"':cs) = cons acc (dquote cs) -- "
-- don't be fooled by single quotes which are part of an identifier
keep acc (c:'\'':cs)
| isAlphaNum c || c == '_' = keep ('\'':c:acc) (c:cs)
keep acc ('\'':cs) = cons acc (squote cs)
keep acc ('-':'-':cs) = cons acc (linecomment cs)
keep acc ('{':'-':'#':' ':cs) = cons acc (cons "#-{" (keep "" cs))
keep acc ('{':'-':cs) = cons acc (runcomment (0::Int) cs) -- -}
keep acc ('{':cs) = cons acc (keep "" cs)
keep acc (';':cs) = cons acc (keep "" cs)
-- treat ';' and '{' as word separators so that stuff
-- like "{import A;" and ";;;;import B;" are handled correctly.
keep acc (c:cs) = keep (c:acc) cs
cons [] xs = xs
cons x xs = x : xs
-- in a double-quoted string
dquote [] = []
dquote ('\\':'\"':cs) = dquote cs -- "
dquote ('\\':'\\':cs) = dquote cs
dquote ('\"':cs) = keep "" cs -- "
dquote (c:cs) = dquote cs
-- in a single-quoted string
squote [] = []
squote ('\\':'\'':cs) = squote cs
squote ('\\':'\\':cs) = squote cs
squote ('\'':cs) = keep "" cs
squote (c:cs) = squote cs
-- in a line comment
linecomment [] = []
linecomment ('\n':cs) = keep "" cs
linecomment (c:cs) = linecomment cs
-- in a running comment
runcomment _ [] = []
runcomment n ('{':'-':cs) = runcomment (n+1) cs -- catches both nested comments and pragmas.
runcomment n ('-':'}':cs)
| n == 0 = keep "" cs
| otherwise = runcomment (n-1) cs
runcomment n (c:cs) = runcomment n cs
getImportsFromFile :: DynFlags -> FilePath -> IO ([Module], [Module], Module)
getImportsFromFile dflags filename = do
buf <- hGetStringBuffer filename
getImports dflags buf filename
getImports :: DynFlags -> StringBuffer -> FilePath -> IO ([Module], [Module], Module)
getImports dflags buf filename = do
let loc = mkSrcLoc (mkFastString filename) 1 0
case unP parseHeader (mkPState buf loc dflags) of
PFailed span err -> parseError span err
POk _ rdr_module ->
case rdr_module of
L _ (HsModule mod _ imps _ _) ->
let
mod_name | Just (L _ m) <- mod = m
| otherwise = mkModule "Main"
(src_idecls, ord_idecls) = partition isSourceIdecl (map unLoc imps)
source_imps = map getImpMod src_idecls
ordinary_imps = map getImpMod ord_idecls
in
return (source_imps, ordinary_imps, mod_name)
parseError span err = throwDyn (ProgramError err_doc)
where err_doc = render (pprBagOfErrors (unitBag (mkPlainErrMsg span err)))
isSourceIdecl (ImportDecl _ s _ _ _) = s
getImpMod (ImportDecl (L _ mod) _ _ _ _) = mod
......@@ -224,7 +224,7 @@ hscRecomp hsc_env msg_act have_object
; front_res <- if toCore then
hscCoreFrontEnd hsc_env msg_act hspp_file
else
hscFileFrontEnd hsc_env msg_act hspp_file
hscFileFrontEnd hsc_env msg_act hspp_file (ml_hspp_buf location)
; case front_res of
Left flure -> return flure;
......@@ -350,11 +350,11 @@ hscCoreFrontEnd hsc_env msg_act hspp_file = do {
}}}
hscFileFrontEnd hsc_env msg_act hspp_file = do {
hscFileFrontEnd hsc_env msg_act hspp_file hspp_buf = do {
-------------------
-- PARSE
-------------------
; maybe_parsed <- myParseModule (hsc_dflags hsc_env) hspp_file
; maybe_parsed <- myParseModule (hsc_dflags hsc_env) hspp_file hspp_buf
; case maybe_parsed of {
Left err -> do { msg_act (unitBag err, emptyBag) ;
......@@ -388,7 +388,7 @@ hscFileCheck hsc_env msg_act hspp_file = do {
-------------------
-- PARSE
-------------------
; maybe_parsed <- myParseModule (hsc_dflags hsc_env) hspp_file
; maybe_parsed <- myParseModule (hsc_dflags hsc_env) hspp_file Nothing
; case maybe_parsed of {
Left err -> do { msg_act (unitBag err, emptyBag) ;
......@@ -488,11 +488,17 @@ hscCmmFile dflags filename = do
no_mod = panic "hscCmmFile: no_mod"
myParseModule dflags src_filename
myParseModule dflags src_filename maybe_src_buf
= do -------------------------- Parser ----------------
showPass dflags "Parser"
_scc_ "Parser" do
buf <- hGetStringBuffer src_filename
-- sometimes we already have the buffer in memory, perhaps
-- because we needed to parse the imports out of it, or get the
-- module name.
buf <- case maybe_src_buf of
Just b -> return b
Nothing -> hGetStringBuffer src_filename
let loc = mkSrcLoc (mkFastString src_filename) 1 0
......
......@@ -8,7 +8,8 @@
-- ---------------------------------------------------------------------------
{
module Parser ( parseModule, parseStmt, parseIdentifier, parseIface, parseType ) where
module Parser ( parseModule, parseStmt, parseIdentifier, parseIface, parseType,
parseHeader ) where
#define INCLUDE #include
INCLUDE "HsVersions.h"
......@@ -276,6 +277,7 @@ TH_TY_QUOTE { L _ ITtyQuote } -- ''T
%name parseIdentifier identifier
%name parseIface iface
%name parseType ctype
%partial parseHeader header
%tokentype { Located Token }
%%
......@@ -317,6 +319,21 @@ top :: { ([LImportDecl RdrName], [LHsDecl RdrName]) }
cvtopdecls :: { [LHsDecl RdrName] }
: topdecls { cvTopDecls $1 }
-----------------------------------------------------------------------------
-- Module declaration & imports only
header :: { Located (HsModule RdrName) }
: 'module' modid maybemoddeprec maybeexports 'where' header_body
{% fileSrcSpan >>= \ loc ->
return (L loc (HsModule (Just $2) $4 $6 [] $3)) }
| missing_module_keyword importdecls
{% fileSrcSpan >>= \ loc ->
return (L loc (HsModule Nothing Nothing $2 [] Nothing)) }
header_body :: { [LImportDecl RdrName] }
: '{' importdecls { $2 }
| vocurly importdecls { $2 }
-----------------------------------------------------------------------------
-- Interfaces (.hi-boot files)
......
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