From: simonmar Date: Mon, 16 May 2005 13:47:58 +0000 (+0000) Subject: [project @ 2005-05-16 13:47:57 by simonmar] X-Git-Tag: Initial_conversion_from_CVS_complete~544 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;ds=sidebyside;h=34c2b1b2cdc009b62402bd1c31ffc1ae17df8969;p=ghc-hetmet.git [project @ 2005-05-16 13:47:57 by simonmar] Implement -x flag to override the suffix of a filename for the purposes of determinig how it should be compiled. The usage is similar to gcc, except that we just use a suffix rather than a name for the language. eg. ghc -c -x hs hello.blah will pretend hello.blah is a .hs file. Another possible use is -x hspp, which skips preprocessing. This works for one-shot compilation, --make, GHCi, and ghc -e. The original idea was to make it possible to use runghc on a file that doesn't end in .hs, so changes to runghc will follow. Also, I made it possible to specify .c files and other kinds of files on the --make command line; these will be compiled to objects as normal and linked into the final executable. GHC API change: I had to extend the Target type to include an optional start phase, and also GHC.guessTarget now takes a (Maybe Phase) argument. I thought this would be half an hour, in fact it took half a day, and I still haven't documented it. Sigh. --- diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 282ad93..b33bd95 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -17,7 +17,7 @@ module InteractiveUI ( import qualified GHC import GHC ( Session, verbosity, dopt, DynFlag(..), mkModule, pprModule, Type, Module, SuccessFlag(..), - TyThing(..), Name, LoadHowMuch(..), + TyThing(..), Name, LoadHowMuch(..), Phase, GhcException(..), showGhcException, CheckedModule(..) ) import Outputable @@ -163,7 +163,7 @@ helpText = " (eg. -v2, -fglasgow-exts, etc.)\n" -interactiveUI :: Session -> [FilePath] -> Maybe String -> IO () +interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO () interactiveUI session srcs maybe_expr = do -- HACK! If we happen to get into an infinite loop (eg the user @@ -214,7 +214,7 @@ interactiveUI session srcs maybe_expr = do return () -runGHCi :: [FilePath] -> Maybe String -> GHCi () +runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi () runGHCi paths maybe_expr = do let read_dot_files = not opt_IgnoreDotGhci @@ -660,7 +660,7 @@ addModule :: [FilePath] -> GHCi () addModule files = do io (revertCAFs) -- always revert CAFs on load/add. files <- mapM expandPath files - targets <- mapM (io . GHC.guessTarget) files + targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files session <- getSession io (mapM_ (GHC.addTarget session) targets) ok <- io (GHC.load session LoadAllTargets) @@ -722,13 +722,13 @@ undefineMacro macro_name = do io (writeIORef commands (filter ((/= macro_name) . fst) cmds)) -loadModule :: [FilePath] -> GHCi SuccessFlag +loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag loadModule fs = timeIt (loadModule' fs) loadModule_ :: [FilePath] -> GHCi () -loadModule_ fs = do loadModule fs; return () +loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return () -loadModule' :: [FilePath] -> GHCi SuccessFlag +loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag loadModule' files = do session <- getSession @@ -737,8 +737,10 @@ loadModule' files = do io (GHC.load session LoadAllTargets) -- expand tildes - files <- mapM expandPath files - targets <- io (mapM GHC.guessTarget files) + let (filenames, phases) = unzip files + exp_filenames <- mapM expandPath filenames + let files' = zip exp_filenames phases + targets <- io (mapM (uncurry GHC.guessTarget) files') -- NOTE: we used to do the dependency anal first, so that if it -- fails we didn't throw away the current set of modules. This would diff --git a/ghc/compiler/main/DriverMkDepend.hs b/ghc/compiler/main/DriverMkDepend.hs index bd0be6f..c8fb955 100644 --- a/ghc/compiler/main/DriverMkDepend.hs +++ b/ghc/compiler/main/DriverMkDepend.hs @@ -55,7 +55,7 @@ doMkDependHS session srcs ; files <- beginMkDependHS dflags -- Do the downsweep to find all the modules - ; targets <- mapM GHC.guessTarget srcs + ; targets <- mapM (\s -> GHC.guessTarget s Nothing) srcs ; GHC.setTargets session targets ; excl_mods <- readIORef v_Dep_exclude_mods ; GHC.depanal session excl_mods diff --git a/ghc/compiler/main/DriverPhases.hs b/ghc/compiler/main/DriverPhases.hs index 1b2972c..158f6dd 100644 --- a/ghc/compiler/main/DriverPhases.hs +++ b/ghc/compiler/main/DriverPhases.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverPhases.hs,v 1.36 2005/03/31 10:16:38 simonmar Exp $ +-- $Id: DriverPhases.hs,v 1.37 2005/05/16 13:47:58 simonmar Exp $ -- -- GHC Driver -- @@ -14,6 +14,15 @@ module DriverPhases ( startPhase, -- :: String -> Phase phaseInputExt, -- :: Phase -> String + isHaskellishSuffix, + isHaskellSrcSuffix, + isObjectSuffix, + isCishSuffix, + isExtCoreSuffix, + isDynLibSuffix, + isHaskellUserSrcSuffix, + isSourceSuffix, + isHaskellishFilename, isHaskellSrcFilename, isObjectFilename, @@ -74,7 +83,7 @@ data Phase -- The final phase is a pseudo-phase that tells the pipeline to stop. -- There is no runPhase case for it. | StopLn -- Stop, but linking will follow, so generate .o file - deriving (Show) + deriving (Eq, Show) anyHsc :: Phase anyHsc = Hsc (panic "anyHsc") @@ -197,15 +206,23 @@ dynlib_suffixes = ["dylib"] dynlib_suffixes = ["so"] #endif -isHaskellishFilename f = getFileSuffix f `elem` haskellish_suffixes -isHaskellSrcFilename f = getFileSuffix f `elem` haskellish_src_suffixes -isCishFilename f = getFileSuffix f `elem` cish_suffixes -isExtCoreFilename f = getFileSuffix f `elem` extcoreish_suffixes -isObjectFilename f = getFileSuffix f `elem` objish_suffixes -isHaskellUserSrcFilename f = getFileSuffix f `elem` haskellish_user_src_suffixes -isDynLibFilename f = getFileSuffix f `elem` dynlib_suffixes - -isSourceFilename :: FilePath -> Bool -isSourceFilename f = - isHaskellishFilename f || - isCishFilename f +isHaskellishSuffix s = s `elem` haskellish_suffixes +isHaskellSrcSuffix s = s `elem` haskellish_src_suffixes +isCishSuffix s = s `elem` cish_suffixes +isExtCoreSuffix s = s `elem` extcoreish_suffixes +isObjectSuffix s = s `elem` objish_suffixes +isHaskellUserSrcSuffix s = s `elem` haskellish_user_src_suffixes +isDynLibSuffix s = s `elem` dynlib_suffixes + +isSourceSuffix suff = isHaskellishSuffix suff || isCishSuffix suff + +isHaskellishFilename f = isHaskellishSuffix (getFileSuffix f) +isHaskellSrcFilename f = isHaskellSrcSuffix (getFileSuffix f) +isCishFilename f = isCishSuffix (getFileSuffix f) +isExtCoreFilename f = isExtCoreSuffix (getFileSuffix f) +isObjectFilename f = isObjectSuffix (getFileSuffix f) +isHaskellUserSrcFilename f = isHaskellUserSrcSuffix (getFileSuffix f) +isDynLibFilename f = isDynLibSuffix (getFileSuffix f) +isSourceFilename f = isSourceSuffix (getFileSuffix f) + + diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index fbd2d49..910d491 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -9,7 +9,7 @@ module DriverPipeline ( -- Run a series of compilation steps in a pipeline, for a -- collection of source files. - oneShot, + oneShot, compileFile, -- Interfaces for the batch-mode driver staticLink, @@ -75,10 +75,10 @@ import Maybe -- We return the augmented DynFlags, because they contain the result -- of slurping in the OPTIONS pragmas -preprocess :: DynFlags -> FilePath -> IO (DynFlags, FilePath) -preprocess dflags filename = - ASSERT2(isHaskellSrcFilename filename, text filename) - runPipeline anyHsc dflags filename Temporary Nothing{-no ModLocation-} +preprocess :: DynFlags -> (FilePath, Maybe Phase) -> IO (DynFlags, FilePath) +preprocess dflags (filename, mb_phase) = + ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename) + runPipeline anyHsc dflags (filename, mb_phase) Temporary Nothing{-no ModLocation-} -- --------------------------------------------------------------------------- -- Compile @@ -214,7 +214,7 @@ compile hsc_env msg_act mod_summary maybe_old_linkable old_iface mod_index nmods -- We're in --make mode: finish the compilation pipeline. _other - -> do runPipeline StopLn dflags output_fn Persistent + -> do runPipeline StopLn dflags (output_fn,Nothing) Persistent (Just location) -- The object filename comes from the ModLocation @@ -235,7 +235,7 @@ compileStub dflags stub_c_exists -- compile the _stub.c file w/ gcc let stub_c = hscStubCOutName dflags (_, stub_o) <- runPipeline StopLn dflags - stub_c Persistent Nothing{-no ModLocation-} + (stub_c,Nothing) Persistent Nothing{-no ModLocation-} return (Just stub_o) @@ -307,13 +307,13 @@ link BatchCompile dflags batch_attempt_linking hpt -- ----------------------------------------------------------------------------- -- Compile files in one-shot mode. -oneShot :: DynFlags -> Phase -> [String] -> IO () +oneShot :: DynFlags -> Phase -> [(String, Maybe Phase)] -> IO () oneShot dflags stop_phase srcs = do o_files <- mapM (compileFile dflags stop_phase) srcs doLink dflags stop_phase o_files -compileFile :: DynFlags -> Phase -> FilePath -> IO FilePath -compileFile dflags stop_phase src = do +compileFile :: DynFlags -> Phase -> (FilePath, Maybe Phase) -> IO FilePath +compileFile dflags stop_phase (src, mb_phase) = do exists <- doesFileExist src when (not exists) $ throwDyn (CmdLineError ("does not exist: " ++ src)) @@ -337,7 +337,7 @@ compileFile dflags stop_phase src = do other -> stop_phase (_, out_file) <- runPipeline stop_phase' dflags - src output Nothing{-no ModLocation-} + (src, mb_phase) output Nothing{-no ModLocation-} return out_file @@ -382,17 +382,21 @@ data PipelineOutput -- the output must go into the specified file. runPipeline - :: Phase -- When to stop - -> DynFlags -- Dynamic flags - -> FilePath -- Input filename - -> PipelineOutput -- Output filename - -> Maybe ModLocation -- A ModLocation, if this is a Haskell module + :: Phase -- When to stop + -> DynFlags -- Dynamic flags + -> (FilePath,Maybe Phase) -- Input filename (and maybe -x suffix) + -> PipelineOutput -- Output filename + -> Maybe ModLocation -- A ModLocation, if this is a Haskell module -> IO (DynFlags, FilePath) -- (final flags, output filename) -runPipeline stop_phase dflags input_fn output maybe_loc +runPipeline stop_phase dflags (input_fn, mb_phase) output maybe_loc = do let (basename, suffix) = splitFilename input_fn - start_phase = startPhase suffix + + -- If we were given a -x flag, then use that phase to start from + start_phase + | Just x_phase <- mb_phase = x_phase + | otherwise = startPhase suffix -- We want to catch cases of "you can't get there from here" before -- we start the pipeline, because otherwise it will just run off the @@ -500,7 +504,7 @@ getOutputFilename dflags stop_phase output basename | StopLn <- next_phase = return odir_persistent | otherwise = return persistent - persistent = basename ++ '.':suffix + persistent = basename `joinFileExt` suffix odir_persistent | Just loc <- maybe_location = ml_obj_file loc @@ -561,7 +565,7 @@ runPhase (Unlit sf) _stop dflags _basename _suff input_fn get_output_fn maybe_lo 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 - checkProcessArgsResult unhandled_flags (basename++'.':suff) + checkProcessArgsResult unhandled_flags (basename `joinFileExt` suff) if not (dopt Opt_Cpp dflags) then -- no need to preprocess CPP, just pass input file along @@ -582,7 +586,7 @@ runPhase (HsPp sf) _stop dflags basename suff input_fn get_output_fn maybe_loc return (Hsc sf, dflags, maybe_loc, input_fn) else do let hspp_opts = getOpts dflags opt_F - let orig_fn = basename ++ '.':suff + let orig_fn = basename `joinFileExt` suff output_fn <- get_output_fn (Hsc sf) maybe_loc SysTools.runPp dflags ( [ SysTools.Option orig_fn @@ -652,7 +656,7 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma | otherwise = location3 -- Make the ModSummary to hand to hscMain - src_timestamp <- getModificationTime (basename ++ '.':suff) + src_timestamp <- getModificationTime (basename `joinFileExt` suff) let unused_field = panic "runPhase:ModSummary field" -- Some fields are not looked at by hscMain @@ -815,12 +819,12 @@ runPhase cc_phase stop dflags basename suff input_fn get_output_fn maybe_loc | otherwise = As output_fn <- get_output_fn next_phase maybe_loc - -- force the C compiler to interpret this file as C when - -- compiling .hc files, by adding the -x c option. - let langopt | hcc = [ SysTools.Option "-x", SysTools.Option "c"] - | otherwise = [ ] - - SysTools.runCc dflags (langopt ++ + SysTools.runCc dflags ( + -- force the C compiler to interpret this file as C when + -- compiling .hc files, by adding the -x c option. + -- Also useful for plain .c files, just in case GHC saw a + -- -x c option. + [ SysTools.Option "-x", SysTools.Option "c"] ++ [ SysTools.FileOption "" input_fn , SysTools.Option "-o" , SysTools.FileOption "" output_fn diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs index 14ec482..0a461d1 100644 --- a/ghc/compiler/main/Finder.lhs +++ b/ghc/compiler/main/Finder.lhs @@ -288,7 +288,7 @@ searchPathExts paths mod exts (ext,fn) <- exts, let base | path == "." = basename | otherwise = path ++ '/':basename - file = base ++ '.':ext + file = base `joinFileExt` ext ] search [] = return (Failed (map fst to_search)) @@ -365,7 +365,7 @@ mkHomeModLocation2 dflags mod src_basename ext = do obj_fn <- mkObjPath dflags src_basename mod_basename hi_fn <- mkHiPath dflags src_basename mod_basename - return (ModLocation{ ml_hs_file = Just (src_basename ++ '.':ext), + return (ModLocation{ ml_hs_file = Just (src_basename `joinFileExt` ext), ml_hi_file = hi_fn, ml_obj_file = obj_fn }) @@ -374,7 +374,7 @@ hiOnlyModLocation dflags path basename hisuf = do let full_basename = path++'/':basename obj_fn <- mkObjPath dflags full_basename basename return ModLocation{ ml_hs_file = Nothing, - ml_hi_file = full_basename ++ '.':hisuf, + ml_hi_file = full_basename `joinFileExt` hisuf, -- Remove the .hi-boot suffix from -- hi_file, if it had one. We always -- want the name of the real .hi file @@ -397,7 +397,7 @@ mkObjPath dflags basename mod_basename obj_basename | Just dir <- odir = dir ++ '/':mod_basename | otherwise = basename - return (obj_basename ++ '.':osuf) + return (obj_basename `joinFileExt` osuf) -- | Constructs the filename of a .hi file for a given source file. -- Does /not/ check whether the .hi file exists @@ -414,7 +414,7 @@ mkHiPath dflags basename mod_basename hi_basename | Just dir <- hidir = dir ++ '/':mod_basename | otherwise = basename - return (hi_basename ++ '.':hisuf) + return (hi_basename `joinFileExt` hisuf) -- ----------------------------------------------------------------------------- diff --git a/ghc/compiler/main/GHC.hs b/ghc/compiler/main/GHC.hs index ab55fcc..ba47a72 100644 --- a/ghc/compiler/main/GHC.hs +++ b/ghc/compiler/main/GHC.hs @@ -23,7 +23,7 @@ module GHC ( setMsgHandler, -- * Targets - Target(..), TargetId(..), + Target(..), TargetId(..), Phase, setTargets, getTargets, addTarget, @@ -353,15 +353,21 @@ removeTarget s target_id -- then use that -- - otherwise interpret the string as a module name -- -guessTarget :: String -> IO Target -guessTarget file +guessTarget :: String -> Maybe Phase -> IO Target +guessTarget file (Just phase) + = return (Target (TargetFile file (Just phase)) Nothing) +guessTarget file Nothing | isHaskellSrcFilename file - = return (Target (TargetFile file) Nothing) + = return (Target (TargetFile file Nothing) Nothing) | otherwise = do exists <- doesFileExist hs_file - if exists then return (Target (TargetFile hs_file) Nothing) else do + if exists + then return (Target (TargetFile hs_file Nothing) Nothing) + else do exists <- doesFileExist lhs_file - if exists then return (Target (TargetFile lhs_file) Nothing) else do + if exists + then return (Target (TargetFile lhs_file Nothing) Nothing) + else do return (Target (TargetModule (mkModule file)) Nothing) where hs_file = file ++ ".hs" @@ -1212,11 +1218,11 @@ downsweep hsc_env old_summaries excl_mods old_summary_map = mkNodeMap old_summaries getRootSummary :: Target -> IO ModSummary - getRootSummary (Target (TargetFile file) maybe_buf) + getRootSummary (Target (TargetFile file mb_phase) maybe_buf) = do exists <- doesFileExist file if exists - then summariseFile hsc_env old_summaries file maybe_buf - else do + then summariseFile hsc_env old_summaries file mb_phase maybe_buf + else do throwDyn (CmdLineError ("can't find file: " ++ file)) getRootSummary (Target (TargetModule modl) maybe_buf) = do maybe_summary <- summariseModule hsc_env old_summary_map Nothing False @@ -1295,10 +1301,11 @@ summariseFile :: HscEnv -> [ModSummary] -- old summaries -> FilePath -- source file name + -> Maybe Phase -- start phase -> Maybe (StringBuffer,ClockTime) -> IO ModSummary -summariseFile hsc_env old_summaries file maybe_buf +summariseFile hsc_env old_summaries file mb_phase maybe_buf -- we can use a cached summary if one is available and the -- source file hasn't changed, But we have to look up the summary -- by source file, rather than module name as we do in summarise. @@ -1325,7 +1332,7 @@ summariseFile hsc_env old_summaries file maybe_buf let dflags = hsc_dflags hsc_env (dflags', hspp_fn, buf) - <- preprocessFile dflags file maybe_buf + <- preprocessFile dflags file mb_phase maybe_buf (srcimps,the_imps,mod) <- getImports dflags' buf hspp_fn @@ -1425,7 +1432,7 @@ summariseModule hsc_env old_summary_map cur_mod is_boot wanted_mod maybe_buf exc = do -- Preprocess the source file and get its imports -- The dflags' contains the OPTIONS pragmas - (dflags', hspp_fn, buf) <- preprocessFile dflags src_fn maybe_buf + (dflags', hspp_fn, buf) <- preprocessFile dflags src_fn Nothing maybe_buf (srcimps, the_imps, mod_name) <- getImports dflags' buf hspp_fn when (mod_name /= wanted_mod) $ @@ -1453,15 +1460,15 @@ getObjTimestamp location is_boot else modificationTimeIfExists (ml_obj_file location) -preprocessFile :: DynFlags -> FilePath -> Maybe (StringBuffer,ClockTime) +preprocessFile :: DynFlags -> FilePath -> Maybe Phase -> Maybe (StringBuffer,ClockTime) -> IO (DynFlags, FilePath, StringBuffer) -preprocessFile dflags src_fn Nothing +preprocessFile dflags src_fn mb_phase Nothing = do - (dflags', hspp_fn) <- preprocess dflags src_fn + (dflags', hspp_fn) <- preprocess dflags (src_fn, mb_phase) buf <- hGetStringBuffer hspp_fn return (dflags', hspp_fn, buf) -preprocessFile dflags src_fn (Just (buf, time)) +preprocessFile dflags src_fn mb_phase (Just (buf, time)) = do -- case we bypass the preprocessing stage? let @@ -1471,7 +1478,8 @@ preprocessFile dflags src_fn (Just (buf, time)) let needs_preprocessing - | Unlit _ <- startPhase src_fn = True + | Just (Unlit _) <- mb_phase = True + | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True -- note: local_opts is only required if there's no Unlit phase | dopt Opt_Cpp dflags' = True | dopt Opt_Pp dflags' = True diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 4fd33c4..2a6e899 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -86,7 +86,7 @@ import TyCon ( TyCon, tyConSelIds, tyConDataCons ) import DataCon ( dataConImplicitIds ) import Packages ( PackageIdH, PackageId, PackageConfig ) import DynFlags ( DynFlags(..), isOneShot ) -import DriverPhases ( HscSource(..), isHsBoot, hscSourceString ) +import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase ) import BasicTypes ( Version, initialVersion, IPName, Fixity, defaultFixity, DeprecTxt ) @@ -188,15 +188,20 @@ hscEPS hsc_env = readIORef (hsc_EPS hsc_env) data Target = Target TargetId (Maybe (StringBuffer,ClockTime)) data TargetId - = TargetModule Module -- ^ A module name: search for the file - | TargetFile FilePath -- ^ A filename: parse it to find the module name. + = TargetModule Module + -- ^ A module name: search for the file + | TargetFile FilePath (Maybe Phase) + -- ^ A filename: preprocess & parse it to find the module name. + -- If specified, the Phase indicates how to compile this file + -- (which phase to start from). Nothing indicates the starting phase + -- should be determined from the suffix of the filename. deriving Eq pprTarget :: Target -> SDoc pprTarget (Target id _) = pprTargetId id pprTargetId (TargetModule m) = ppr m -pprTargetId (TargetFile f) = text f +pprTargetId (TargetFile f _) = text f type FinderCache = ModuleEnv FinderCacheEntry type FinderCacheEntry = (ModLocation, Maybe (PackageConfig,Bool)) diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index f797899..422cfc9 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -19,7 +19,7 @@ import CmdLineParser -- Implementations of the various modes (--show-iface, mkdependHS. etc.) import MkIface ( showIface ) -import DriverPipeline ( oneShot ) +import DriverPipeline ( oneShot, compileFile ) import DriverMkDepend ( doMkDependHS ) import SysTools ( getTopDir, getUsageMsgPaths ) #ifdef GHCI @@ -29,7 +29,8 @@ import InteractiveUI ( ghciWelcomeMsg, interactiveUI ) -- Various other random stuff that we need import Config ( cProjectVersion, cBooterVersion, cProjectName ) import Packages ( dumpPackages, initPackages ) -import DriverPhases ( Phase(..), isSourceFilename, anyHsc ) +import DriverPhases ( Phase(..), isSourceSuffix, isSourceFilename, anyHsc, + startPhase, isHaskellSrcFilename ) import StaticFlags ( staticFlags, v_Ld_inputs ) import BasicTypes ( failed ) import Util @@ -113,32 +114,11 @@ main = GHC.setSessionDynFlags session dflags let - {- - We split out the object files (.o, .dll) and add them - to v_Ld_inputs for use by the linker. - - The following things should be considered compilation manager inputs: - - - haskell source files (strings ending in .hs, .lhs or other - haskellish extension), - - - module names (not forgetting hierarchical module names), - - - and finally we consider everything not containing a '.' to be - a comp manager input, as shorthand for a .hs or .lhs filename. - - Everything else is considered to be a linker object, and passed - straight through to the linker. - -} - looks_like_an_input m = isSourceFilename m - || looksLikeModuleName m - || '.' `notElem` m - -- To simplify the handling of filepaths, we normalise all filepaths right -- away - e.g., for win32 platforms, backslashes are converted -- into forward slashes. normal_fileish_paths = map normalisePath fileish_args - (srcs, objs) = partition looks_like_an_input normal_fileish_paths + (srcs, objs) = partition_args normal_fileish_paths [] [] -- Note: have v_Ld_inputs maintain the order in which 'objs' occurred on -- the command-line. @@ -162,7 +142,7 @@ main = ShowNumVersion -> putStrLn cProjectVersion ShowInterface f -> showIface f DoMake -> doMake session srcs - DoMkDependHS -> doMkDependHS session srcs + DoMkDependHS -> doMkDependHS session (map fst srcs) StopBefore p -> oneShot dflags p srcs DoInteractive -> interactiveUI session srcs Nothing DoEval expr -> interactiveUI session srcs (Just expr) @@ -174,15 +154,52 @@ interactiveUI _ _ _ = throwDyn (CmdLineError "not built for interactive use") #endif +-- ----------------------------------------------------------------------------- +-- Splitting arguments into source files and object files. This is where we +-- interpret the -x option, and attach a (Maybe Phase) to each source +-- file indicating the phase specified by the -x option in force, if any. + +partition_args [] srcs objs = (reverse srcs, reverse objs) +partition_args ("-x":suff:args) srcs objs + | "none" <- suff = partition_args args srcs objs + | StopLn <- phase = partition_args args srcs (slurp ++ objs) + | otherwise = partition_args rest (these_srcs ++ srcs) objs + where phase = startPhase suff + (slurp,rest) = break (== "-x") args + these_srcs = zip slurp (repeat (Just phase)) +partition_args (arg:args) srcs objs + | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs + | otherwise = partition_args args srcs (arg:objs) + + {- + We split out the object files (.o, .dll) and add them + to v_Ld_inputs for use by the linker. + + The following things should be considered compilation manager inputs: + + - haskell source files (strings ending in .hs, .lhs or other + haskellish extension), + + - module names (not forgetting hierarchical module names), + + - and finally we consider everything not containing a '.' to be + a comp manager input, as shorthand for a .hs or .lhs filename. + + Everything else is considered to be a linker object, and passed + straight through to the linker. + -} +looks_like_an_input m = isSourceFilename m + || looksLikeModuleName m + || '.' `notElem` m -- ----------------------------------------------------------------------------- -- Option sanity checks -checkOptions :: CmdLineMode -> DynFlags -> [String] -> [String] -> IO () +checkOptions :: CmdLineMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO () -- Final sanity checking before kicking off a compilation (pipeline). checkOptions cli_mode dflags srcs objs = do -- Complain about any unknown flags - let unknown_opts = [ f | f@('-':_) <- srcs ] + let unknown_opts = [ f | (f@('-':_), _) <- srcs ] when (notNull unknown_opts) (unknownFlagsErr unknown_opts) -- -prof and --interactive are not a good combination @@ -350,10 +367,20 @@ addFlag s = do -- ---------------------------------------------------------------------------- -- Run --make mode -doMake :: Session -> [String] -> IO () +doMake :: Session -> [(String,Maybe Phase)] -> IO () doMake sess [] = throwDyn (UsageError "no input files") doMake sess srcs = do - targets <- mapM GHC.guessTarget srcs + let (hs_srcs, non_hs_srcs) = partition haskellish srcs + + haskellish (f,Nothing) = looksLikeModuleName f || isHaskellSrcFilename f + haskellish (f,Just phase) = + phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn] + + dflags <- GHC.getSessionDynFlags sess + o_files <- mapM (compileFile dflags StopLn) non_hs_srcs + mapM_ (consIORef v_Ld_inputs) (reverse o_files) + + targets <- mapM (uncurry GHC.guessTarget) hs_srcs GHC.setTargets sess targets ok_flag <- GHC.load sess LoadAllTargets when (failed ok_flag) (exitWith (ExitFailure 1)) diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index fe877c8..9725f42 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -63,7 +63,7 @@ module Util ( -- Filename utils Suffix, - splitFilename, getFileSuffix, splitFilenameDir, + splitFilename, getFileSuffix, splitFilenameDir, joinFileExt, splitFilename3, removeSuffix, dropLongestPrefix, takeLongestPrefix, splitLongestPrefix, replaceFilenameSuffix, directoryOf, filenameOf, @@ -870,36 +870,35 @@ splitFilename f = splitLongestPrefix f (=='.') getFileSuffix :: String -> Suffix getFileSuffix f = dropLongestPrefix f (=='.') +joinFileExt :: String -> String -> FilePath +joinFileExt path "" = path +joinFileExt path ext = path ++ '.':ext + -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext") splitFilenameDir :: String -> (String,String) splitFilenameDir str - = let (dir, rest) = splitLongestPrefix str isPathSeparator - real_dir | null dir = "." - | otherwise = dir - in (real_dir, rest) + = let (dir, rest) = splitLongestPrefix str isPathSeparator + (dir', rest') | null rest = (".", dir) + | otherwise = (dir, rest) + in (dir', rest') -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext") splitFilename3 :: String -> (String,String,Suffix) splitFilename3 str = let (dir, rest) = splitLongestPrefix str isPathSeparator - (name, ext) = splitFilename rest - real_dir | null dir = "." - | otherwise = dir - in (real_dir, name, ext) + (dir', rest') | null rest = (".", dir) + | otherwise = (dir, rest) + (name, ext) = splitFilename rest' + in (dir', name, ext) removeSuffix :: Char -> String -> Suffix -removeSuffix c s - | null pre = s - | otherwise = reverse pre - where (suf,pre) = break (==c) (reverse s) +removeSuffix c s = takeLongestPrefix s (==c) dropLongestPrefix :: String -> (Char -> Bool) -> String -dropLongestPrefix s pred = reverse suf - where (suf,_pre) = break pred (reverse s) +dropLongestPrefix s pred = snd (splitLongestPrefix s pred) takeLongestPrefix :: String -> (Char -> Bool) -> String -takeLongestPrefix s pred = reverse pre - where (_suf,pre) = break pred (reverse s) +takeLongestPrefix s pred = fst (splitLongestPrefix s pred) -- split a string at the last character where 'pred' is True, -- returning a pair of strings. The first component holds the string @@ -913,7 +912,7 @@ takeLongestPrefix s pred = reverse pre splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) splitLongestPrefix s pred = case pre of - [] -> ([], reverse suf) + [] -> (reverse suf, []) (_:pre) -> (reverse pre, reverse suf) where (suf,pre) = break pred (reverse s)