X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FDriverPipeline.hs;h=2dbee8841f5432720bdc04bc0565dc331aaf920a;hb=4a3042fcc68554ef59966430d2c6f1b70470d222;hp=80f85fa67d1528398afb5a3fb676db25713cd7d4;hpb=d1545b69b5fbcad3a95b86d9da389235da832b6d;p=ghc-hetmet.git diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index 80f85fa..2dbee88 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 @@ -47,16 +45,10 @@ import Util import StringBuffer ( hGetStringBuffer ) import BasicTypes ( SuccessFlag(..) ) import Maybes ( expectJust ) -import Ctype ( is_ident ) -import StringBuffer ( StringBuffer(..), lexemeToString ) import ParserCoreUtils ( getCoreModuleName ) -import SrcLoc ( srcLocSpan, mkSrcLoc ) -import FastString ( mkFastString ) -import Bag ( listToBag, emptyBag ) +import SrcLoc ( unLoc ) import SrcLoc ( Located(..) ) -import Distribution.Compiler ( extensionsToGHCFlag ) - import EXCEPTION import DATA_IOREF ( readIORef, writeIORef, IORef ) import GLAEXTS ( Int(..) ) @@ -112,7 +104,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,32 +116,21 @@ 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) + let hsc_lang = hscTarget dflags -- ... and what the next phase should be let next_phase = hscNextPhase dflags src_flavour hsc_lang -- ... and what file to generate the output into @@ -223,8 +204,6 @@ compile hsc_env mod_summary maybe_old_linkable old_iface mod_index nmods = do HscInterpreted | not (isHsBoot src_flavour) -- We can't compile boot files to -- bytecode so don't even try. -> runCompiler hscCompileInteractive handleInterpreted - HscNothing - -> runCompiler hscCompileNothing handleBatch _other -> runCompiler hscCompileBatch handleBatch @@ -603,8 +582,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 +681,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, @@ -737,7 +717,7 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma else return False -- get the DynFlags - let hsc_lang = hscMaybeAdjustTarget dflags stop src_flavour (hscTarget dflags) + let hsc_lang = hscTarget dflags let next_phase = hscNextPhase dflags src_flavour hsc_lang output_fn <- get_output_fn next_phase (Just location4) @@ -785,7 +765,7 @@ runPhase CmmCpp stop dflags basename suff input_fn get_output_fn maybe_loc runPhase Cmm stop dflags basename suff input_fn get_output_fn maybe_loc = do - let hsc_lang = hscMaybeAdjustTarget dflags stop HsSrcFile (hscTarget dflags) + let hsc_lang = hscTarget dflags let next_phase = hscNextPhase dflags HsSrcFile hsc_lang output_fn <- get_output_fn next_phase maybe_loc @@ -1385,113 +1365,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. @@ -1503,27 +1376,8 @@ hscNextPhase dflags other hsc_lang = HscC -> HCc HscAsm | dopt Opt_SplitObjs dflags -> SplitMangle | otherwise -> As - HscNothing -> StopLn - HscInterpreted -> StopLn + HscNothing -> HCc _other -> StopLn - -hscMaybeAdjustTarget :: DynFlags -> Phase -> HscSource -> HscTarget -> HscTarget -hscMaybeAdjustTarget dflags stop HsBootFile current_hsc_lang - = HscNothing -- No output (other than Foo.hi-boot) for hs-boot files -hscMaybeAdjustTarget dflags stop other current_hsc_lang - = hsc_lang - where - keep_hc = dopt Opt_KeepHcFiles dflags - hsc_lang - -- don't change the lang if we're interpreting - | current_hsc_lang == HscInterpreted = current_hsc_lang - - -- force -fvia-C if we are being asked for a .hc file - | HCc <- stop = HscC - | keep_hc = HscC - -- otherwise, stick to the plan - | otherwise = current_hsc_lang - GLOBAL_VAR(v_Split_info, ("",0), (String,Int)) -- The split prefix and number of files