From 426e0396a790f7f65bdac142ab93761c46728045 Mon Sep 17 00:00:00 2001 From: simonmar Date: Thu, 31 Mar 2005 16:11:50 +0000 Subject: [PATCH] [project @ 2005-03-31 16:11:49 by simonmar] DriverPipeline.compile: we should be grabbing the OPTIONS from the StringBuffer, not reading the file again (duh!) SysTools: some message cleanups --- ghc/compiler/main/DriverPipeline.hs | 33 ++++++++++++++++++++++++++++----- ghc/compiler/main/GHC.hs | 35 +++++++---------------------------- ghc/compiler/main/SysTools.lhs | 5 +++-- 3 files changed, 38 insertions(+), 35 deletions(-) diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index 42797ac..fae03ac 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -22,7 +22,7 @@ module DriverPipeline ( -- DLL building doMkDLL, - matchOptions, -- used in module GHC + getOptionsFromStringBuffer, -- used in module GHC ) where #include "HsVersions.h" @@ -48,11 +48,12 @@ import StringBuffer ( hGetStringBuffer ) import BasicTypes ( SuccessFlag(..) ) import Maybes ( expectJust ) import Ctype ( is_ident ) - -import ParserCoreUtils ( getCoreModuleName ) +import StringBuffer ( StringBuffer(..), lexemeToString ) +import ParserCoreUtils ( getCoreModuleName ) import EXCEPTION import DATA_IOREF ( readIORef, writeIORef, IORef ) +import GLAEXTS ( Int(..) ) import Directory import System @@ -118,12 +119,13 @@ compile hsc_env mod_summary maybe_old_linkable old_iface = do let input_fn = expectJust "compile:hs" (ml_hs_file location) let input_fnpp = expectJust "compile:hspp" (ms_hspp_file mod_summary) - when (verb >= 2) (hPutStrLn stderr ("compile: input file " ++ input_fnpp)) + when (verb >= 2) (putMsg ("compile: input file " ++ 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 - opts <- getOptionsFromSource input_fnpp + let hspp_buf = expectJust "compile:hspp_buf" (ms_hspp_buf mod_summary) + opts = getOptionsFromStringBuffer hspp_buf (dflags1,unhandled_flags) <- parseDynamicFlags dflags0 opts checkProcessArgsResult unhandled_flags input_fn @@ -248,6 +250,9 @@ link Interactive dflags batch_attempt_linking hpt return Succeeded #endif +link JustTypecheck dflags batch_attempt_linking hpt + = return Succeeded + link BatchCompile dflags batch_attempt_linking hpt | batch_attempt_linking = do @@ -1305,6 +1310,24 @@ getOptionsFromSource file return (opts ++ rest) | otherwise -> return [] +getOptionsFromStringBuffer :: StringBuffer -> [String] +getOptionsFromStringBuffer buffer@(StringBuffer _ len# _) = + let + ls = lines (lexemeToString buffer (I# len#)) -- lazy, so it's ok + in + look ls + where + look [] = [] + look (l':ls) = do + let l = removeSpaces l' + case () of + () | null l -> look ls + | prefixMatch "#" l -> look ls + | prefixMatch "{-# LINE" l -> look ls -- -} + | Just opts <- matchOptions l + -> opts ++ look ls + | otherwise -> [] + -- detect {-# OPTIONS_GHC ... #-}. For the time being, we accept OPTIONS -- instead of OPTIONS_GHC, but that is deprecated. matchOptions s diff --git a/ghc/compiler/main/GHC.hs b/ghc/compiler/main/GHC.hs index 3214a41..89b600b 100644 --- a/ghc/compiler/main/GHC.hs +++ b/ghc/compiler/main/GHC.hs @@ -122,10 +122,10 @@ import Module import FiniteMap import Panic import Digraph -import ErrUtils ( showPass, Messages ) +import ErrUtils ( showPass, Messages, putMsg ) import qualified ErrUtils import Util -import StringBuffer ( StringBuffer(..), hGetStringBuffer, lexemeToString ) +import StringBuffer ( StringBuffer, hGetStringBuffer ) import Outputable import SysTools ( cleanTempFilesExcept ) import BasicTypes ( SuccessFlag(..), succeeded, failed ) @@ -140,7 +140,6 @@ import Monad ( unless, when, foldM ) import System ( exitWith, ExitCode(..) ) import Time ( ClockTime ) import EXCEPTION as Exception hiding (handle) -import GLAEXTS ( Int(..) ) import DATA_IOREF import IO import Prelude hiding (init) @@ -480,8 +479,7 @@ load s@(Session ref) how_much then -- Easy; just relink it all. - do when (verb >= 2) $ - hPutStrLn stderr "Upsweep completely successful." + do when (verb >= 2) $ putMsg "Upsweep completely successful." -- Clean up after ourselves cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone) @@ -504,7 +502,7 @@ load s@(Session ref) how_much when (ghci_mode == BatchCompile && isJust ofile && not do_linking && verb > 0) $ - hPutStrLn stderr ("Warning: output was redirected with -o, " ++ + putMsg ("Warning: output was redirected with -o, " ++ "but no output will be generated\n" ++ "because there is no " ++ main_mod ++ " module.") @@ -517,8 +515,7 @@ load s@(Session ref) how_much -- Tricky. We need to back out the effects of compiling any -- half-done cycles, both so as to clean up the top level envs -- and to avoid telling the interactive linker to link them. - do when (verb >= 2) $ - hPutStrLn stderr "Upsweep partially successful." + do when (verb >= 2) $ putMsg "Upsweep partially successful." let modsDone_names = map ms_mod modsDone @@ -613,7 +610,8 @@ checkModule session@(Session ref) mod msg_act = do unload :: HscEnv -> [Linkable] -> IO () unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' = case ghcMode (hsc_dflags hsc_env) of - BatchCompile -> return () + BatchCompile -> return () + JustTypecheck -> return () #ifdef GHCI Interactive -> Linker.unload (hsc_dflags hsc_env) stable_linkables #else @@ -1335,25 +1333,6 @@ preprocessFile dflags src_fn (Just (buf, time)) return (dflags', "", buf) --- code adapted from the file-based version in DriverUtil -getOptionsFromStringBuffer :: StringBuffer -> [String] -getOptionsFromStringBuffer buffer@(StringBuffer _ len# _) = - let - ls = lines (lexemeToString buffer (I# len#)) -- lazy, so it's ok - in - look ls - where - look [] = [] - look (l':ls) = do - let l = removeSpaces l' - case () of - () | null l -> look ls - | prefixMatch "#" l -> look ls - | prefixMatch "{-# LINE" l -> look ls -- -} - | Just opts <- matchOptions l - -> opts ++ look ls - | otherwise -> [] - ----------------------------------------------------------------------------- -- Error messages ----------------------------------------------------------------------------- diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs index d919bcf..1033f6a 100644 --- a/ghc/compiler/main/SysTools.lhs +++ b/ghc/compiler/main/SysTools.lhs @@ -47,6 +47,7 @@ module SysTools ( import DriverPhases ( isHaskellUserSrcFilename ) import Config import Outputable +import ErrUtils ( putMsg ) import Panic ( GhcException(..) ) import Util ( Suffix, global, notNull, consIORef, normalisePath, pgmPath, platformPath ) @@ -621,8 +622,8 @@ traceCmd :: DynFlags -> String -> String -> IO () -> IO () -- b) don't do it at all if dry-run is set traceCmd dflags phase_name cmd_line action = do { let verb = verbosity dflags - ; when (verb >= 2) $ hPutStrLn stderr ("*** " ++ phase_name) - ; when (verb >= 3) $ hPutStrLn stderr cmd_line + ; when (verb >= 2) $ putMsg ("*** " ++ phase_name) + ; when (verb >= 3) $ putMsg cmd_line ; hFlush stderr -- Test for -n flag -- 1.7.10.4