[project @ 2005-04-13 21:42:17 by wolfgang]

[ghc-hetmet.git] / ghc / compiler / main / DriverPipeline.hs

diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs
index fea6651..c36e008 100644 (file)
--- a/ghc/compiler/main/DriverPipeline.hs
+++ b/ghc/compiler/main/DriverPipeline.hs
@@ -20,7 +20,9 @@ module DriverPipeline (
    link, 
 
         -- DLL building
-   doMkDLL
+   doMkDLL,
+
+   getOptionsFromStringBuffer, -- used in module GHC
   ) where
 
 #include "HsVersions.h"
@@ -46,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
@@ -86,9 +89,11 @@ preprocess dflags filename =
 -- NB.  No old interface can also mean that the source has changed.
 
 compile :: HscEnv
+       -> (Messages -> IO ())  -- error message callback
        -> ModSummary
        -> Maybe Linkable       -- Just linkable <=> source unchanged
         -> Maybe ModIface       -- Old interface, if available
+        -> Int -> Int
         -> IO CompResult
 
 data CompResult
@@ -99,7 +104,7 @@ data CompResult
    | CompErrs 
 
 
-compile hsc_env mod_summary maybe_old_linkable old_iface = do 
+compile hsc_env msg_act mod_summary maybe_old_linkable old_iface mod_index nmods = do 
 
    let dflags0     = hsc_dflags hsc_env
        this_mod    = ms_mod mod_summary
@@ -111,17 +116,17 @@ compile hsc_env mod_summary maybe_old_linkable old_iface = do
 
    showPass dflags0 ("Compiling " ++ showModMsg have_object mod_summary)
 
-   let verb      = verbosity dflags0
    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)
 
-   when (verb >= 2) (hPutStrLn stderr ("compile: input file " ++ input_fnpp))
+   debugTraceMsg dflags0 2 ("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
 
@@ -154,8 +159,9 @@ compile hsc_env mod_summary maybe_old_linkable old_iface = do
        hsc_env' = hsc_env { hsc_dflags = dflags' }
 
    -- run the compiler
-   hsc_result <- hscMain hsc_env' printErrorsAndWarnings mod_summary
+   hsc_result <- hscMain hsc_env' msg_act mod_summary
                         source_unchanged have_object old_iface
+                         (Just (mod_index, nmods))
 
    case hsc_result of
       HscFail -> return CompErrs
@@ -172,7 +178,6 @@ compile hsc_env mod_summary maybe_old_linkable old_iface = do
 
        | otherwise             -- Normal Haskell source files
        -> do
-          let 
           maybe_stub_o <- compileStub dflags' stub_c_exists
           let stub_unlinked = case maybe_stub_o of
                                  Nothing -> []
@@ -247,6 +252,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 
@@ -259,19 +267,16 @@ link BatchCompile dflags batch_attempt_linking hpt
            -- the linkables to link
            linkables = map (fromJust.hm_linkable) home_mod_infos
 
-        when (verb >= 3) $ do
-            hPutStrLn stderr "link: linkables are ..."
-             hPutStrLn stderr (showSDoc (vcat (map ppr linkables)))
+        debugTraceMsg dflags 3 "link: linkables are ..."
+        debugTraceMsg dflags 3 (showSDoc (vcat (map ppr linkables)))
 
        -- check for the -no-link flag
        if isNoLink (ghcLink dflags)
-         then do when (verb >= 3) $
-                   hPutStrLn stderr "link(batch): linking omitted (-c flag given)."
+         then do debugTraceMsg dflags 3 "link(batch): linking omitted (-c flag given)."
                  return Succeeded
          else do
 
-       when (verb >= 1) $
-             hPutStrLn stderr "Linking ..."
+       debugTraceMsg dflags 1 "Linking ..."
 
        let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
            obj_files = concatMap getOfiles linkables
@@ -279,18 +284,15 @@ link BatchCompile dflags batch_attempt_linking hpt
        -- Don't showPass in Batch mode; doLink will do that for us.
         staticLink dflags obj_files pkg_deps
 
-        when (verb >= 3) (hPutStrLn stderr "link: done")
+        debugTraceMsg dflags 3 "link: done"
 
        -- staticLink only returns if it succeeds
         return Succeeded
 
    | otherwise
-   = do when (verb >= 3) $ do
-           hPutStrLn stderr "link(batch): upsweep (partially) failed OR"
-            hPutStrLn stderr "   Main.main not exported; not linking."
+   = do debugTraceMsg dflags 3 "link(batch): upsweep (partially) failed OR"
+        debugTraceMsg dflags 3 "   Main.main not exported; not linking."
         return Succeeded
-   where
-      verb = verbosity dflags
       
 
 -- -----------------------------------------------------------------------------
@@ -702,6 +704,7 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma
                          mod_summary source_unchanged 
                          False         -- No object file
                          Nothing       -- No iface
+                          Nothing       -- No "module i of n" progress info
 
        case result of
 
@@ -1304,6 +1307,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