From: Lemmih Date: Fri, 10 Mar 2006 01:10:35 +0000 (+0000) Subject: Parse OPTIONS properly and cache the result. X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=d700953c29ffe78d6530f734f2820c796e5ec6e0;p=ghc-hetmet.git Parse OPTIONS properly and cache the result. Use the lexer to parse OPTIONS, LANGUAGE and INCLUDE pragmas. This gives us greater flexibility and far better error messages. However, I had to make a few quirks: * The token parser is written manually since Happy doesn't like lexer errors (we need to extract options before the buffer is passed through 'cpp'). Still better than manually parsing a String, though. * The StringBuffer API has been extended so files can be read in blocks. I also made a new field in ModSummary called ms_hspp_opts which stores the updated DynFlags. Oh, and I took the liberty of moving 'getImports' into HeaderInfo together with 'getOptions'. --- diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index 80f85fa..c70811b 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -22,14 +22,12 @@ module DriverPipeline ( -- DLL building doMkDLL, - getOptionsFromStringBuffer, -- used in module GHC - optionsErrorMsgs, -- ditto ) where #include "HsVersions.h" import Packages -import GetImports +import HeaderInfo import DriverPhases import SysTools ( newTempName, addFilesToClean, getSysMan, copy ) import qualified SysTools @@ -50,9 +48,8 @@ import Maybes ( expectJust ) import Ctype ( is_ident ) import StringBuffer ( StringBuffer(..), lexemeToString ) import ParserCoreUtils ( getCoreModuleName ) -import SrcLoc ( srcLocSpan, mkSrcLoc ) +import SrcLoc ( srcLocSpan, mkSrcLoc, unLoc ) import FastString ( mkFastString ) -import Bag ( listToBag, emptyBag ) import SrcLoc ( Located(..) ) import Distribution.Compiler ( extensionsToGHCFlag ) @@ -112,7 +109,7 @@ data CompResult compile hsc_env mod_summary maybe_old_linkable old_iface mod_index nmods = do - let dflags0 = hsc_dflags hsc_env + let dflags0 = ms_hspp_opts mod_summary this_mod = ms_mod mod_summary src_flavour = ms_hsc_src mod_summary @@ -124,29 +121,18 @@ compile hsc_env mod_summary maybe_old_linkable old_iface mod_index nmods = do let location = ms_location mod_summary let input_fn = expectJust "compile:hs" (ml_hs_file location) - let input_fnpp = expectJust "compile:hspp" (ms_hspp_file mod_summary) + let input_fnpp = ms_hspp_file mod_summary debugTraceMsg dflags0 2 (text "compile: input file" <+> text input_fnpp) - -- Add in the OPTIONS from the source file - -- This is nasty: we've done this once already, in the compilation manager - -- It might be better to cache the flags in the ml_hspp_file field,say - let hspp_buf = expectJust "compile:hspp_buf" (ms_hspp_buf mod_summary) - opts = getOptionsFromStringBuffer hspp_buf input_fn - (dflags1,unhandled_flags) <- parseDynamicFlags dflags0 (map snd opts) - if (not (null unhandled_flags)) - then do printErrorsAndWarnings dflags1 (optionsErrorMsgs unhandled_flags opts input_fn) - return CompErrs - else do - let (basename, _) = splitFilename input_fn -- We add the directory in which the .hs files resides) to the import path. -- This is needed when we try to compile the .hc file later, if it -- imports a _stub.h file that we created here. let current_dir = directoryOf basename - old_paths = includePaths dflags1 - dflags = dflags1 { includePaths = current_dir : old_paths } + old_paths = includePaths dflags0 + dflags = dflags0 { includePaths = current_dir : old_paths } -- Figure out what lang we're generating let hsc_lang = hscMaybeAdjustTarget dflags StopLn src_flavour (hscTarget dflags) @@ -603,8 +589,8 @@ runPhase (Unlit sf) _stop dflags _basename _suff input_fn get_output_fn maybe_lo -- (b) runs cpp if necessary runPhase (Cpp sf) _stop dflags0 basename suff input_fn get_output_fn maybe_loc - = do src_opts <- getOptionsFromSource input_fn - (dflags,unhandled_flags) <- parseDynamicFlags dflags0 src_opts + = do src_opts <- getOptionsFromFile input_fn + (dflags,unhandled_flags) <- parseDynamicFlags dflags0 (map unLoc src_opts) checkProcessArgsResult unhandled_flags (basename `joinFileExt` suff) if not (dopt Opt_Cpp dflags) then @@ -702,7 +688,8 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma -- Some fields are not looked at by hscMain mod_summary = ModSummary { ms_mod = mod_name, ms_hsc_src = src_flavour, - ms_hspp_file = Just input_fn, + ms_hspp_file = input_fn, + ms_hspp_opts = dflags, ms_hspp_buf = hspp_buf, ms_location = location4, ms_hs_date = src_timestamp, @@ -1385,113 +1372,6 @@ hsSourceCppOpts = , "-D__CONCURRENT_HASKELL__" ] ------------------------------------------------------------------------------ --- Reading OPTIONS pragmas - --- This is really very ugly and should be rewritten. --- - some error messages are thrown as exceptions (should return) --- - we ignore LINE pragmas --- - parsing is horrible, combination of prefixMatch and 'read'. - -getOptionsFromSource - :: String -- input file - -> IO [String] -- options, if any -getOptionsFromSource file - = do h <- openFile file ReadMode - look h 1 `finally` hClose h - where - look h i = do - r <- tryJust ioErrors (hGetLine h) - case r of - Left e | isEOFError e -> return [] - | otherwise -> ioError e - Right l' -> do - let l = removeSpaces l' - case () of - () | null l -> look h (i+1) - | prefixMatch "#" l -> look h (i+1) - | prefixMatch "{-# LINE" l -> look h (i+1) -- -} wrong! - | Just opts <- matchOptions i file l - -> do rest <- look h (i+1) - return (opts ++ rest) - | otherwise -> return [] - -getOptionsFromStringBuffer :: StringBuffer -> FilePath -> [(Int,String)] -getOptionsFromStringBuffer buffer@(StringBuffer _ len _) fn = - let - ls = lines (lexemeToString buffer len) -- lazy, so it's ok - in - look 1 ls - where - look i [] = [] - look i (l':ls) = do - let l = removeSpaces l' - case () of - () | null l -> look (i+1) ls - | prefixMatch "#" l -> look (i+1) ls - | prefixMatch "{-# LINE" l -> look (i+1) ls -- -} wrong! - | Just opts <- matchOptions i fn l - -> zip (repeat i) opts ++ look (i+1) ls - | otherwise -> [] - --- detect {-# OPTIONS_GHC ... #-}. For the time being, we accept OPTIONS --- instead of OPTIONS_GHC, but that is deprecated. -matchOptions i fn s - | Just s1 <- maybePrefixMatch "{-#" s -- -} - = matchOptions1 i fn (removeSpaces s1) - | otherwise - = Nothing - where - matchOptions1 i fn s - | Just s2 <- maybePrefixMatch "OPTIONS" s - = case () of - _ | Just s3 <- maybePrefixMatch "_GHC" s2, not (is_ident (head s3)) - -> matchOptions2 i fn s3 - | not (is_ident (head s2)) - -> matchOptions2 i fn s2 - | otherwise - -> Just [] -- OPTIONS_anything is ignored, not treated as start of source - | Just s2 <- maybePrefixMatch "INCLUDE" s, not (is_ident (head s2)), - Just s3 <- maybePrefixMatch "}-#" (reverse s2) - = Just ["-#include", removeSpaces (reverse s3)] - - | Just s2 <- maybePrefixMatch "LANGUAGE" s, not (is_ident (head s2)), - Just s3 <- maybePrefixMatch "}-#" (reverse s2) - = case [ exts | (exts,"") <- reads ('[' : reverse (']':s3))] of - [] -> languagePragParseError i fn - exts:_ -> case extensionsToGHCFlag exts of - ([], opts) -> Just opts - (unsup,_) -> unsupportedExtnError i fn unsup - | otherwise = Nothing - matchOptions2 i fn s - | Just s3 <- maybePrefixMatch "}-#" (reverse s) = Just (words (reverse s3)) - | otherwise = Nothing - - -languagePragParseError i fn = - pgmError (showSDoc (mkLocMessage loc ( - text "cannot parse LANGUAGE pragma"))) - where loc = srcLocSpan (mkSrcLoc (mkFastString fn) i 0) - -unsupportedExtnError i fn unsup = - pgmError (showSDoc (mkLocMessage loc ( - text "unsupported extensions: " <> - hcat (punctuate comma (map (text.show) unsup))))) - where loc = srcLocSpan (mkSrcLoc (mkFastString fn) i 0) - - -optionsErrorMsgs :: [String] -> [(Int,String)] -> FilePath -> Messages -optionsErrorMsgs unhandled_flags flags_lines filename - = (emptyBag, listToBag (map mkMsg unhandled_flags_lines)) - where - unhandled_flags_lines = [ (l,f) | f <- unhandled_flags, - (l,f') <- flags_lines, f == f' ] - mkMsg (line,flag) = - ErrUtils.mkPlainErrMsg (srcLocSpan loc) $ - text "unknown flag in {-# OPTIONS #-} pragma:" <+> text flag - where - loc = mkSrcLoc (mkFastString filename) line 0 - -- ToDo: we need a better SrcSpan here -- ----------------------------------------------------------------------------- -- Misc. diff --git a/ghc/compiler/main/GHC.hs b/ghc/compiler/main/GHC.hs index b38b379..cef3a72 100644 --- a/ghc/compiler/main/GHC.hs +++ b/ghc/compiler/main/GHC.hs @@ -208,7 +208,7 @@ import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr ) import SrcLoc import DriverPipeline import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase ) -import GetImports ( getImports ) +import HeaderInfo ( getImports, getOptions, optionsErrorMsgs ) import Packages ( isHomePackage ) import Finder import HscMain ( newHscEnv, hscFileCheck, HscChecked(..) ) @@ -712,7 +712,7 @@ discardProg hsc_env -- used to fish out the preprocess output files for the purposes of -- cleaning up. The preprocessed file *might* be the same as the -- source file, but that doesn't do any harm. -ppFilesFromSummaries summaries = [ fn | Just fn <- map ms_hspp_file summaries ] +ppFilesFromSummaries summaries = map ms_hspp_file summaries -- ----------------------------------------------------------------------------- -- Check module @@ -762,21 +762,7 @@ checkModule session@(Session ref) mod = do case [ ms | ms <- mg, ms_mod ms == mod ] of [] -> return Nothing (ms:_) -> do - -- Add in the OPTIONS from the source file This is nasty: - -- we've done this once already, in the compilation manager - -- It might be better to cache the flags in the - -- ml_hspp_file field, say - let dflags0 = hsc_dflags hsc_env - hspp_buf = expectJust "GHC.checkModule" (ms_hspp_buf ms) - filename = expectJust "checkModule" (ml_hs_file (ms_location ms)) - opts = getOptionsFromStringBuffer hspp_buf filename - (dflags1,leftovers) <- parseDynamicFlags dflags0 (map snd opts) - if (not (null leftovers)) - then do printErrorsAndWarnings dflags1 (optionsErrorMsgs leftovers opts filename) - return Nothing - else do - - mbChecked <- hscFileCheck hsc_env{hsc_dflags=dflags1} ms + mbChecked <- hscFileCheck hsc_env{hsc_dflags=ms_hspp_opts ms} ms case mbChecked of Nothing -> return Nothing Just (HscChecked parsed renamed Nothing) -> @@ -1436,7 +1422,8 @@ summariseFile hsc_env old_summaries file mb_phase maybe_buf return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile, ms_location = location, - ms_hspp_file = Just hspp_fn, + ms_hspp_file = hspp_fn, + ms_hspp_opts = dflags', ms_hspp_buf = Just buf, ms_srcimps = srcimps, ms_imps = the_imps, ms_hs_date = src_timestamp, @@ -1546,7 +1533,8 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc return (Just ( ModSummary { ms_mod = wanted_mod, ms_hsc_src = hsc_src, ms_location = location, - ms_hspp_file = Just hspp_fn, + ms_hspp_file = hspp_fn, + ms_hspp_opts = dflags', ms_hspp_buf = Just buf, ms_srcimps = srcimps, ms_imps = the_imps, @@ -1571,9 +1559,9 @@ preprocessFile dflags src_fn mb_phase (Just (buf, time)) = do -- case we bypass the preprocessing stage? let - local_opts = getOptionsFromStringBuffer buf src_fn + local_opts = getOptions buf src_fn -- - (dflags', errs) <- parseDynamicFlags dflags (map snd local_opts) + (dflags', errs) <- parseDynamicFlags dflags (map unLoc local_opts) let needs_preprocessing diff --git a/ghc/compiler/main/GetImports.hs b/ghc/compiler/main/GetImports.hs deleted file mode 100644 index 6ccb8be..0000000 --- a/ghc/compiler/main/GetImports.hs +++ /dev/null @@ -1,65 +0,0 @@ ------------------------------------------------------------------------------ --- --- Parsing the top of a Haskell source file to get its module name --- and imports. --- --- (c) Simon Marlow 2005 --- ------------------------------------------------------------------------------ - -module GetImports ( getImportsFromFile, getImports ) where - -#include "HsVersions.h" - -import Parser ( parseHeader ) -import Lexer ( P(..), ParseResult(..), mkPState ) -import HsSyn ( ImportDecl(..), HsModule(..) ) -import Module ( Module, mkModule ) -import PrelNames ( gHC_PRIM ) -import StringBuffer ( StringBuffer, hGetStringBuffer ) -import SrcLoc ( Located(..), mkSrcLoc, unLoc, noSrcSpan ) -import FastString ( mkFastString ) -import DynFlags ( DynFlags ) -import ErrUtils -import Pretty -import Panic -import Bag ( unitBag ) - -import EXCEPTION ( throwDyn ) -import IO -import List - --- 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 :: DynFlags -> FilePath - -> IO ([Located Module], [Located Module], Located Module) -getImportsFromFile dflags filename = do - buf <- hGetStringBuffer filename - getImports dflags buf filename - -getImports :: DynFlags -> StringBuffer -> FilePath - -> IO ([Located Module], [Located Module], Located 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 located_mod <- mod = located_mod - | otherwise = L noSrcSpan (mkModule "Main") - (src_idecls, ord_idecls) = partition isSourceIdecl (map unLoc imps) - source_imps = map getImpMod src_idecls - ordinary_imps = filter ((/= gHC_PRIM) . unLoc) - (map getImpMod ord_idecls) - -- GHC.Prim doesn't exist physically, so don't go looking for it. - in - return (source_imps, ordinary_imps, mod_name) - -parseError span err = throwDyn $ mkPlainErrMsg span err - -isSourceIdecl (ImportDecl _ s _ _ _) = s - -getImpMod (ImportDecl located_mod _ _ _ _) = located_mod diff --git a/ghc/compiler/main/HeaderInfo.hs b/ghc/compiler/main/HeaderInfo.hs new file mode 100644 index 0000000..913ac33 --- /dev/null +++ b/ghc/compiler/main/HeaderInfo.hs @@ -0,0 +1,201 @@ +----------------------------------------------------------------------------- +-- +-- Parsing the top of a Haskell source file to get its module name, +-- imports and options. +-- +-- (c) Simon Marlow 2005 +-- (c) Lemmih 2006 +-- +----------------------------------------------------------------------------- + +module HeaderInfo ( getImportsFromFile, getImports + , getOptionsFromFile, getOptions + , optionsErrorMsgs ) where + +#include "HsVersions.h" + +import Parser ( parseHeader ) +import Lexer ( P(..), ParseResult(..), mkPState, pragState + , lexer, Token(..), PState(..) ) +import FastString +import HsSyn ( ImportDecl(..), HsModule(..) ) +import Module ( Module, mkModule ) +import PrelNames ( gHC_PRIM ) +import StringBuffer ( StringBuffer(..), hGetStringBuffer, hGetStringBufferBlock + , appendStringBuffers ) +import SrcLoc ( Located(..), mkSrcLoc, unLoc, noSrcSpan ) +import FastString ( mkFastString ) +import DynFlags ( DynFlags ) +import ErrUtils +import Util +import Outputable +import Pretty () +import Panic +import Bag ( unitBag, emptyBag, listToBag ) + +import Distribution.Compiler + +import TRACE + +import EXCEPTION ( throwDyn ) +import IO +import List + +#if __GLASGOW_HASKELL__ >= 601 +import System.IO ( openBinaryFile ) +#else +import IOExts ( openFileEx, IOModeEx(..) ) +#endif + +#if __GLASGOW_HASKELL__ < 601 +openBinaryFile fp mode = openFileEx fp (BinaryMode mode) +#endif + +-- 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 :: DynFlags -> FilePath + -> IO ([Located Module], [Located Module], Located Module) +getImportsFromFile dflags filename = do + buf <- hGetStringBuffer filename + getImports dflags buf filename + +getImports :: DynFlags -> StringBuffer -> FilePath + -> IO ([Located Module], [Located Module], Located 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 located_mod <- mod = located_mod + | otherwise = L noSrcSpan (mkModule "Main") + (src_idecls, ord_idecls) = partition isSourceIdecl (map unLoc imps) + source_imps = map getImpMod src_idecls + ordinary_imps = filter ((/= gHC_PRIM) . unLoc) + (map getImpMod ord_idecls) + -- GHC.Prim doesn't exist physically, so don't go looking for it. + in + return (source_imps, ordinary_imps, mod_name) + +parseError span err = throwDyn $ mkPlainErrMsg span err + +isSourceIdecl (ImportDecl _ s _ _ _) = s + +getImpMod (ImportDecl located_mod _ _ _ _) = located_mod + +-------------------------------------------------------------- +-- Get options +-------------------------------------------------------------- + + +getOptionsFromFile :: FilePath -- input file + -> IO [Located String] -- options, if any +getOptionsFromFile filename + = bracket (openBinaryFile filename ReadMode) + (hClose) + (\handle -> + do buf <- hGetStringBufferBlock handle blockSize + loop handle buf) + where blockSize = 1024 + loop handle buf + | len buf == 0 = return [] + | otherwise + = case getOptions' buf filename of + (Nothing, opts) -> return opts + (Just buf', opts) -> do nextBlock <- hGetStringBufferBlock handle blockSize + newBuf <- appendStringBuffers buf' nextBlock + if len newBuf == len buf + then return opts + else do opts' <- loop handle newBuf + return (opts++opts') + +getOptions :: StringBuffer -> FilePath -> [Located String] +getOptions buf filename + = case getOptions' buf filename of + (_,opts) -> opts + +-- The token parser is written manually because Happy can't +-- return a partial result when it encounters a lexer error. +-- We want to extract options before the buffer is passed through +-- CPP, so we can't use the same trick as 'getImports'. +getOptions' :: StringBuffer -- Input buffer + -> FilePath -- Source file. Used for msgs only. + -> ( Maybe StringBuffer -- Just => we can use more input + , [Located String] -- Options. + ) +getOptions' buf filename + = parseToks (lexAll (pragState buf loc)) + where loc = mkSrcLoc (mkFastString filename) 1 0 + + getToken (buf,L _loc tok) = tok + getLoc (buf,L loc _tok) = loc + getBuf (buf,_tok) = buf + combine opts (flag, opts') = (flag, opts++opts') + add opt (flag, opts) = (flag, opt:opts) + + parseToks (open:close:xs) + | IToptions_prag str <- getToken open + , ITclose_prag <- getToken close + = map (L (getLoc open)) (words str) `combine` + parseToks xs + parseToks (open:close:xs) + | ITinclude_prag str <- getToken open + , ITclose_prag <- getToken close + = map (L (getLoc open)) ["-#include",removeSpaces str] `combine` + parseToks xs + parseToks (open:xs) + | ITlanguage_prag <- getToken open + = parseLanguage xs + -- The last token before EOF could have been truncated. + -- We ignore it to be on the safe side. + parseToks [tok,eof] + | ITeof <- getToken eof + = (Just (getBuf tok),[]) + parseToks (eof:_) + | ITeof <- getToken eof + = (Just (getBuf eof),[]) + parseToks _ = (Nothing,[]) + parseLanguage ((_buf,L loc (ITconid fs)):rest) + = checkExtension (L loc fs) `add` + case rest of + (_,L loc ITcomma):more -> parseLanguage more + (_,L loc ITclose_prag):more -> parseToks more + (_,L loc _):_ -> languagePragParseError loc + parseLanguage (tok:_) + = languagePragParseError (getLoc tok) + lexToken t = return t + lexAll state = case unP (lexer lexToken) state of + POk state' t@(L _ ITeof) -> [(buffer state,t)] + POk state' t -> (buffer state,t):lexAll state' + _ -> [(buffer state,L (last_loc state) ITeof)] + +checkExtension :: Located FastString -> Located String +checkExtension (L l ext) + = case reads (unpackFS ext) of + [] -> languagePragParseError l + (okExt,""):_ -> case extensionsToGHCFlag [okExt] of + ([],[opt]) -> L l opt + _ -> unsupportedExtnError l okExt + +languagePragParseError loc = + pgmError (showSDoc (mkLocMessage loc ( + text "cannot parse LANGUAGE pragma"))) + +unsupportedExtnError loc unsup = + pgmError (showSDoc (mkLocMessage loc ( + text "unsupported extension: " <> + (text.show) unsup))) + + +optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages +optionsErrorMsgs unhandled_flags flags_lines filename + = (emptyBag, listToBag (map mkMsg unhandled_flags_lines)) + where unhandled_flags_lines = [ L l f | f <- unhandled_flags, + L l f' <- flags_lines, f == f' ] + mkMsg (L flagSpan flag) = + ErrUtils.mkPlainErrMsg flagSpan $ + text "unknown flag in {-# OPTIONS #-} pragma:" <+> text flag + diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index f2360a9..ed95559 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -402,7 +402,7 @@ hscCoreFrontEnd = ------------------- -- PARSE ------------------- - inp <- readFile (expectJust "hscCoreFrontEnd" (ms_hspp_file mod_summary)) + inp <- readFile (ms_hspp_file mod_summary) case parseCore inp 1 of FailP s -> do errorMsg (hsc_dflags hsc_env) (text s{-ToDo: wrong-}) @@ -428,7 +428,7 @@ hscFileFrontEnd = -- PARSE ------------------- let dflags = hsc_dflags hsc_env - hspp_file = expectJust "hscFileFrontEnd" (ms_hspp_file mod_summary) + hspp_file = ms_hspp_file mod_summary hspp_buf = ms_hspp_buf mod_summary maybe_parsed <- myParseModule dflags hspp_file hspp_buf case maybe_parsed of @@ -641,7 +641,7 @@ hscFileCheck hsc_env mod_summary = do { -- PARSE ------------------- ; let dflags = hsc_dflags hsc_env - hspp_file = expectJust "hscFileFrontEnd" (ms_hspp_file mod_summary) + hspp_file = ms_hspp_file mod_summary hspp_buf = ms_hspp_buf mod_summary ; maybe_parsed <- myParseModule dflags hspp_file hspp_buf diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 00e1b49..2f2888d 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -962,9 +962,10 @@ data ModSummary ms_obj_date :: Maybe ClockTime, -- Timestamp of object, maybe ms_srcimps :: [Located Module], -- Source imports ms_imps :: [Located Module], -- Non-source imports - ms_hspp_file :: Maybe FilePath, -- Filename of preprocessed source, - -- once we have preprocessed it. - ms_hspp_buf :: Maybe StringBuffer -- The actual preprocessed source, maybe. + ms_hspp_file :: FilePath, -- Filename of preprocessed source. + ms_hspp_opts :: DynFlags, -- Cached flags from OPTIONS, INCLUDE + -- and LANGUAGE pragmas. + ms_hspp_buf :: Maybe StringBuffer -- The actual preprocessed source, maybe. } -- The ModLocation contains both the original source filename and the diff --git a/ghc/compiler/package.conf.in b/ghc/compiler/package.conf.in index 4d348c1..b216cd9 100644 --- a/ghc/compiler/package.conf.in +++ b/ghc/compiler/package.conf.in @@ -102,7 +102,7 @@ exposed-modules: FunDeps GHC Generics - GetImports + HeaderInfo HsBinds HsDecls HsExpr diff --git a/ghc/compiler/parser/Lexer.x b/ghc/compiler/parser/Lexer.x index 6193c76..31acaa0 100644 --- a/ghc/compiler/parser/Lexer.x +++ b/ghc/compiler/parser/Lexer.x @@ -22,7 +22,7 @@ { module Lexer ( - Token(..), lexer, mkPState, PState(..), + Token(..), lexer, pragState, mkPState, PState(..), P(..), ParseResult(..), getSrcLoc, failLocMsgP, failSpanMsgP, srcParseFail, popContext, pushCurrentContext, setLastToken, setSrcLoc, @@ -158,7 +158,7 @@ $white_no_nl+ ; -- generate a matching '}' token. () { do_layout_left } -<0,glaexts> \n { begin bol } +<0,option_prags,glaexts> \n { begin bol } "{-#" $whitechar* (line|LINE) { begin line_prag2 } @@ -184,7 +184,7 @@ $white_no_nl+ ; "{-#" $whitechar* (RULES|rules) { token ITrules_prag } -<0,glaexts> { +<0,option_prags,glaexts> { "{-#" $whitechar* (INLINE|inline) { token (ITinline_prag True) } "{-#" $whitechar* (NO(T?)INLINE|no(t?)inline) { token (ITinline_prag False) } @@ -201,13 +201,20 @@ $white_no_nl+ ; "{-#" $whitechar* (SCC|scc) { token ITscc_prag } "{-#" $whitechar* (CORE|core) { token ITcore_prag } "{-#" $whitechar* (UNPACK|unpack) { token ITunpack_prag } - + "{-#" { nested_comment } -- ToDo: should only be valid inside a pragma: "#-}" { token ITclose_prag} } + { + "{-#" $whitechar* (OPTIONS|options) { lex_string_prag IToptions_prag } + "{-#" $whitechar* (OPTIONS_GHC|options_ghc) + { lex_string_prag IToptions_prag } + "{-#" $whitechar* (LANGUAGE|language) { token ITlanguage_prag } + "{-#" $whitechar* (INCLUDE|include) { lex_string_prag ITinclude_prag } +} -- '0' state: ordinary lexemes -- 'glaexts' state: glasgow extensions (postfix '#', etc.) @@ -248,7 +255,7 @@ $white_no_nl+ ; "|}" { token ITccurlybar } } -<0,glaexts> { +<0,option_prags,glaexts> { \( { special IToparen } \) { special ITcparen } \[ { special ITobrack } @@ -261,7 +268,7 @@ $white_no_nl+ ; \} { close_brace } } -<0,glaexts> { +<0,option_prags,glaexts> { @qual @varid { check_qvarid } @qual @conid { idtoken qconid } @varid { varid } @@ -377,6 +384,9 @@ data Token | ITcore_prag -- hdaume: core annotations | ITunpack_prag | ITclose_prag + | IToptions_prag String + | ITinclude_prag String + | ITlanguage_prag | ITdotdot -- reserved symbols | ITcolon @@ -851,6 +861,32 @@ setFile code span buf len = do pushLexState code lexToken + +-- ----------------------------------------------------------------------------- +-- Options, includes and language pragmas. + +lex_string_prag :: (String -> Token) -> Action +lex_string_prag mkTok span buf len + = do input <- getInput + start <- getSrcLoc + tok <- go [] input + end <- getSrcLoc + return (L (mkSrcSpan start end) tok) + where go acc input + = if isString input "#-}" + then do setInput input + return (mkTok (reverse acc)) + else case alexGetChar input of + Just (c,i) -> go (c:acc) i + Nothing -> err input + isString i [] = True + isString i (x:xs) + = case alexGetChar i of + Just (c,i') | c == x -> isString i' xs + _other -> False + err (AI end _ _) = failLocMsgP (srcSpanStart span) end "unterminated options pragma" + + -- ----------------------------------------------------------------------------- -- Strings & Chars @@ -1273,6 +1309,22 @@ ipEnabled flags = testBit flags ipBit tvEnabled flags = testBit flags tvBit bangPatEnabled flags = testBit flags bangPatBit +-- PState for parsing options pragmas +-- +pragState :: StringBuffer -> SrcLoc -> PState +pragState buf loc = + PState { + buffer = buf, + last_loc = mkSrcSpan loc loc, + last_offs = 0, + last_len = 0, + loc = loc, + extsBitmap = 0, + context = [], + lex_state = [bol, option_prags, 0] + } + + -- create a parse state -- mkPState :: StringBuffer -> SrcLoc -> DynFlags -> PState diff --git a/ghc/compiler/utils/StringBuffer.lhs b/ghc/compiler/utils/StringBuffer.lhs index 70d708d..e52e7e7 100644 --- a/ghc/compiler/utils/StringBuffer.lhs +++ b/ghc/compiler/utils/StringBuffer.lhs @@ -13,6 +13,8 @@ module StringBuffer -- * Creation\/destruction hGetStringBuffer, + hGetStringBufferBlock, + appendStringBuffers, stringToStringBuffer, -- * Inspection @@ -40,7 +42,8 @@ import Encoding import FastString ( FastString,mkFastString,mkFastStringBytes ) import Foreign -import System.IO ( hGetBuf, hFileSize,IOMode(ReadMode), hClose ) +import System.IO ( hGetBuf, hFileSize,IOMode(ReadMode), hClose + , Handle, hTell ) import GHC.Ptr ( Ptr(..) ) import GHC.Exts @@ -102,6 +105,32 @@ hGetStringBuffer fname = do -- sentinels for UTF-8 decoding return (StringBuffer buf size 0) +hGetStringBufferBlock :: Handle -> Int -> IO StringBuffer +hGetStringBufferBlock handle wanted + = do size_i <- hFileSize handle + offset_i <- hTell handle + let size = min wanted (fromIntegral $ size_i-offset_i) + buf <- mallocForeignPtrArray (size+3) + withForeignPtr buf $ \ptr -> + do r <- if size == 0 then return 0 else hGetBuf handle ptr size + if r /= size + then ioError (userError $ "short read of file: "++show(r,size,fromIntegral size_i,handle)) + else do pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0] + return (StringBuffer buf size 0) + +appendStringBuffers :: StringBuffer -> StringBuffer -> IO StringBuffer +appendStringBuffers sb1 sb2 + = do newBuf <- mallocForeignPtrArray (size+3) + withForeignPtr newBuf $ \ptr -> + withForeignPtr (buf sb1) $ \sb1Ptr -> + withForeignPtr (buf sb2) $ \sb2Ptr -> + do copyArray (sb1Ptr `advancePtr` cur sb1) ptr (calcLen sb1) + copyArray (sb2Ptr `advancePtr` cur sb2) (ptr `advancePtr` cur sb1) (calcLen sb2) + pokeArray (ptr `advancePtr` size) [0,0,0] + return (StringBuffer newBuf size 0) + where calcLen sb = len sb - cur sb + size = calcLen sb1 + calcLen sb2 + stringToStringBuffer :: String -> IO StringBuffer stringToStringBuffer str = do let size = utf8EncodedLength str