From 6f57245bd52f902080e003bffe0d511f89b15592 Mon Sep 17 00:00:00 2001 From: simonmar Date: Fri, 4 Jan 2002 16:02:05 +0000 Subject: [PATCH] [project @ 2002-01-04 16:02:03 by simonmar] Some driver cleanups; in particular -fno-code should work in a more reasonable way (it is now a "mode flag" like -C, -c, --make etc.). --- ghc/compiler/compMan/CompManager.lhs | 6 +-- ghc/compiler/main/CmdLineOpts.lhs | 19 +++++++++ ghc/compiler/main/DriverFlags.hs | 48 +++++++++++---------- ghc/compiler/main/DriverPhases.hs | 6 +-- ghc/compiler/main/DriverPipeline.hs | 78 +++++++++++++--------------------- ghc/compiler/main/DriverState.hs | 28 +++++++----- ghc/compiler/main/Main.hs | 55 +++++++++--------------- ghc/compiler/rename/RnHiFiles.lhs | 5 +-- 8 files changed, 119 insertions(+), 126 deletions(-) diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index b627dfc..96421dd 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -46,7 +46,6 @@ where import CmLink import CmTypes import DriverPipeline -import DriverFlags ( getDynFlags ) import DriverState ( v_Output_file ) import DriverPhases import DriverUtil @@ -59,7 +58,7 @@ import HscMain ( initPersistentCompilerState ) import HscTypes import Name ( Name, NamedThing(..), nameRdrName, nameModule, isHomePackageName ) -import RdrName ( lookupRdrEnv, emptyRdrEnv ) +import RdrName ( emptyRdrEnv ) import Module import GetImports import UniqFM @@ -70,11 +69,12 @@ import SysTools ( cleanTempFilesExcept ) import Util import Outputable import Panic -import CmdLineOpts ( DynFlags(..) ) +import CmdLineOpts ( DynFlags(..), getDynFlags ) import IOExts #ifdef GHCI +import RdrName ( lookupRdrEnv ) import Id ( idType, idName ) import NameEnv import Type ( tidyType ) diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 6fb17e8..529bbae 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -26,6 +26,9 @@ module CmdLineOpts ( dopt_StgToDo, -- DynFlags -> [StgToDo] dopt_HscLang, -- DynFlags -> HscLang dopt_OutName, -- DynFlags -> String + getOpts, -- (DynFlags -> [a]) -> IO [a] + setLang, + getVerbFlag, -- Manipulating the DynFlags state getDynFlags, -- IO DynFlags @@ -383,6 +386,22 @@ dopt_set dfs f = dfs{ flags = f : flags dfs } dopt_unset :: DynFlags -> DynFlag -> DynFlags dopt_unset dfs f = dfs{ flags = filter (/= f) (flags dfs) } + +getOpts :: (DynFlags -> [a]) -> IO [a] + -- We add to the options from the front, so we need to reverse the list +getOpts opts = dynFlag opts >>= return . reverse + +-- we can only switch between HscC, HscAsmm, and HscILX with dynamic flags +-- (-fvia-C, -fasm, -filx respectively). +setLang l = updDynFlags (\ dfs -> case hscLang dfs of + HscC -> dfs{ hscLang = l } + HscAsm -> dfs{ hscLang = l } + HscILX -> dfs{ hscLang = l } + _ -> dfs) + +getVerbFlag = do + verb <- dynFlag verbosity + if verb >= 3 then return "-v" else return "" \end{code} ----------------------------------------------------------------------------- diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs index 19f4d5c..8927080 100644 --- a/ghc/compiler/main/DriverFlags.hs +++ b/ghc/compiler/main/DriverFlags.hs @@ -1,7 +1,7 @@ {-# OPTIONS -#include "hschooks.h" #-} ----------------------------------------------------------------------------- --- $Id: DriverFlags.hs,v 1.83 2001/12/20 11:19:07 simonpj Exp $ +-- $Id: DriverFlags.hs,v 1.84 2002/01/04 16:02:04 simonmar Exp $ -- -- Driver flags -- @@ -11,8 +11,7 @@ module DriverFlags ( processArgs, OptKind(..), static_flags, dynamic_flags, - getDynFlags, dynFlag, - getOpts, getVerbFlag, addCmdlineHCInclude, + addCmdlineHCInclude, buildStaticHscOpts, machdepCCOpts ) where @@ -21,6 +20,7 @@ module DriverFlags ( #include "../includes/config.h" import DriverState +import DriverPhases import DriverUtil import SysTools import CmdLineOpts @@ -166,6 +166,22 @@ static_flags = ------- verbosity ---------------------------------------------------- , ( "n" , NoArg setDryRun ) + ------- primary modes ------------------------------------------------ + , ( "M" , PassFlag (setMode DoMkDependHS)) + , ( "E" , PassFlag (setMode (StopBefore Hsc))) + , ( "C" , PassFlag (\f -> do setMode (StopBefore HCc) f + setLang HscC)) + , ( "S" , PassFlag (setMode (StopBefore As))) + , ( "c" , PassFlag (setMode (StopBefore Ln))) + , ( "-make" , PassFlag (setMode DoMake)) + , ( "-interactive" , PassFlag (setMode DoInteractive)) + , ( "-mk-dll" , PassFlag (setMode DoMkDLL)) + + -- -fno-code says to stop after Hsc but don't generate any code. + , ( "fno-code" , PassFlag (\f -> do setMode (StopBefore HCc) f + setLang HscNothing + writeIORef v_Recomp False)) + ------- GHCi ------------------------------------------------------- , ( "ignore-dot-ghci", NoArg (writeIORef v_Read_DotGHCi False) ) , ( "read-dot-ghci" , NoArg (writeIORef v_Read_DotGHCi True) ) @@ -268,7 +284,9 @@ static_flags = ------ Compiler flags ----------------------------------------------- , ( "O2-for-C" , NoArg (writeIORef v_minus_o2_for_C True) ) - , ( "O" , OptPrefix (setOptLevel) ) + , ( "O" , NoArg (setOptLevel 1)) + , ( "Onot" , NoArg (setOptLevel 0)) + , ( "O" , PrefixPred (all isDigit) (setOptLevel . read)) , ( "fno-asm-mangling" , NoArg (writeIORef v_Do_asm_mangling False) ) @@ -397,7 +415,6 @@ dynamic_flags = [ , ( "fvia-c", NoArg (setLang HscC) ) , ( "fvia-C", NoArg (setLang HscC) ) , ( "filx", NoArg (setLang HscILX) ) - , ( "fno-code", NoArg (setLang HscNothing) ) -- "active negatives" , ( "fno-implicit-prelude", NoArg (setDynFlag Opt_NoImplicitPrelude) ) @@ -547,7 +564,8 @@ machdepCCOpts | otherwise = return ( [], [] ) - +----------------------------------------------------------------------------- +-- local utils addOpt_L a = updDynFlags (\s -> s{opt_L = a : opt_L s}) addOpt_P a = updDynFlags (\s -> s{opt_P = a : opt_P s}) @@ -560,25 +578,9 @@ addOpt_I a = updDynFlags (\s -> s{opt_I = a : opt_I s}) addOpt_i a = updDynFlags (\s -> s{opt_i = a : opt_i s}) #endif -addCmdlineHCInclude a = updDynFlags (\s -> s{cmdlineHcIncludes = a : cmdlineHcIncludes s}) - -getOpts :: (DynFlags -> [a]) -> IO [a] - -- We add to the options from the front, so we need to reverse the list -getOpts opts = dynFlag opts >>= return . reverse - --- we can only change HscC to HscAsm and vice-versa with dynamic flags --- (-fvia-C and -fasm). We can also set the new lang to ILX, via -filx. -setLang l = updDynFlags (\ dfs -> case hscLang dfs of - HscC -> dfs{ hscLang = l } - HscAsm -> dfs{ hscLang = l } - HscILX -> dfs{ hscLang = l } - _ -> dfs) - setVerbosity "" = updDynFlags (\dfs -> dfs{ verbosity = 3 }) setVerbosity n | all isDigit n = updDynFlags (\dfs -> dfs{ verbosity = read n }) | otherwise = throwDyn (UsageError "can't parse verbosity flag (-v)") -getVerbFlag = do - verb <- dynFlag verbosity - if verb >= 3 then return "-v" else return "" +addCmdlineHCInclude a = updDynFlags (\s -> s{cmdlineHcIncludes = a : cmdlineHcIncludes s}) diff --git a/ghc/compiler/main/DriverPhases.hs b/ghc/compiler/main/DriverPhases.hs index 4b6687c..f212947 100644 --- a/ghc/compiler/main/DriverPhases.hs +++ b/ghc/compiler/main/DriverPhases.hs @@ -1,9 +1,9 @@ ----------------------------------------------------------------------------- --- $Id: DriverPhases.hs,v 1.14 2001/10/29 11:31:51 simonmar Exp $ +-- $Id: DriverPhases.hs,v 1.15 2002/01/04 16:02:04 simonmar Exp $ -- -- GHC Driver -- --- (c) Simon Marlow 2000 +-- (c) The University of Glasgow 2002 -- ----------------------------------------------------------------------------- @@ -42,7 +42,7 @@ data Phase | Unlit | Cpp | HsPp - | Hsc -- ToDo: HscTargetLang + | Hsc | Cc | HCc -- Haskellised C (as opposed to vanilla C) compilation | Mangle -- assembly mangling, now done by a separate script. diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index c43381c..f233358 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -2,7 +2,7 @@ -- -- GHC Driver -- --- (c) Simon Marlow 2000 +-- (c) The University of Glasgow 2002 -- ----------------------------------------------------------------------------- @@ -11,7 +11,6 @@ module DriverPipeline ( -- interfaces for the batch-mode driver - GhcMode(..), getGhcMode, v_GhcMode, genPipeline, runPipeline, pipeLoop, -- interfaces for the compilation manager (interpreted/batch-mode) @@ -60,33 +59,6 @@ import PackedString import MatchPS ----------------------------------------------------------------------------- --- GHC modes of operation - -modeFlag :: String -> Maybe GhcMode -modeFlag "-M" = Just $ DoMkDependHS -modeFlag "--mk-dll" = Just $ DoMkDLL -modeFlag "-E" = Just $ StopBefore Hsc -modeFlag "-C" = Just $ StopBefore HCc -modeFlag "-S" = Just $ StopBefore As -modeFlag "-c" = Just $ StopBefore Ln -modeFlag "--make" = Just $ DoMake -modeFlag "--interactive" = Just $ DoInteractive -modeFlag _ = Nothing - -getGhcMode :: [String] - -> IO ( [String] -- rest of command line - , GhcMode - , String -- "GhcMode" flag - ) -getGhcMode flags - = case my_partition modeFlag flags of - ([] , rest) -> return (rest, DoLink, "") -- default is to do linking - ([(flag,one)], rest) -> return (rest, one, flag) - (_ , _ ) -> - throwDyn (UsageError - "only one of the flags -M, -E, -C, -S, -c, --make, --interactive, --mk-dll is allowed") - ------------------------------------------------------------------------------ -- genPipeline -- -- Herein is all the magic about which phases to run in which order, whether @@ -161,29 +133,34 @@ genPipeline todo stop_flag persistent_output lang (filename,suffix) let ----------- ----- ---- --- -- -- - - - - pipeline - | todo == DoMkDependHS = [ Unlit, Cpp, HsPp, MkDependHS ] + pipeline = preprocess ++ compile + + preprocess + | haskellish = [ Unlit, Cpp, HsPp ] + | otherwise = [ ] + + compile + | todo == DoMkDependHS = [ MkDependHS ] + + | cish = [ Cc, As ] | haskellish = case real_lang of - HscC | split && mangle -> [ Unlit, Cpp, HsPp, Hsc, HCc, Mangle, - SplitMangle, SplitAs ] - | mangle -> [ Unlit, Cpp, HsPp, Hsc, HCc, Mangle, As ] + HscC | split && mangle -> [ Hsc, HCc, Mangle, SplitMangle, SplitAs ] + | mangle -> [ Hsc, HCc, Mangle, As ] | split -> not_valid - | otherwise -> [ Unlit, Cpp, HsPp, Hsc, HCc, As ] + | otherwise -> [ Hsc, HCc, As ] - HscAsm | split -> [ Unlit, Cpp, HsPp, Hsc, SplitMangle, SplitAs ] - | otherwise -> [ Unlit, Cpp, HsPp, Hsc, As ] + HscAsm | split -> [ Hsc, SplitMangle, SplitAs ] + | otherwise -> [ Hsc, As ] HscJava | split -> not_valid | otherwise -> error "not implemented: compiling via Java" #ifdef ILX HscILX | split -> not_valid - | otherwise -> [ Unlit, Cpp, HsPp, Hsc, Ilx2Il, Ilasm ] + | otherwise -> [ Hsc, Ilx2Il, Ilasm ] #endif - HscNothing -> [ Unlit, Cpp, HsPp, Hsc ] - - | cish = [ Cc, As ] + HscNothing -> [ Hsc, HCc ] -- HCc is a dummy stop phase | otherwise = [ ] -- just pass this file through to the linker @@ -212,8 +189,9 @@ genPipeline todo stop_flag persistent_output lang (filename,suffix) when (start_phase `elem` pipeline && (stop_phase /= Ln && stop_phase `notElem` pipeline)) (throwDyn (UsageError - ("flag " ++ stop_flag - ++ " is incompatible with source file `" ++ filename ++ "'"))) + ("flag `" ++ stop_flag + ++ "' is incompatible with source file `" + ++ filename ++ "'" ++ show pipeline ++ show stop_phase))) let -- .o and .hc suffixes can be overriden by command-line options: myPhaseInputExt Ln | Just s <- osuf = s @@ -635,12 +613,17 @@ run_phase cc_phase basename suff input_fn output_fn pkg_extra_cc_opts <- getPackageExtraCcOpts split_objs <- readIORef v_Split_object_files - let split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ] - | otherwise = [ ] excessPrecision <- readIORef v_Excess_precision - SysTools.runCc ([ SysTools.Option "-x", SysTools.Option "c" - , SysTools.FileOption "" input_fn + + -- force the C compiler to interpret this file as C when + -- compiling .hc files, by adding the -x c option. + let langopt + | cc_phase == HCc = [ SysTools.Option "-x", SysTools.Option "c"] + | otherwise = [ ] + + SysTools.runCc (langopt ++ + [ SysTools.FileOption "" input_fn , SysTools.Option "-o" , SysTools.FileOption "" output_fn ] @@ -652,7 +635,6 @@ run_phase cc_phase basename suff input_fn output_fn ++ [ verb, "-S", "-Wimplicit", opt_flag ] ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ] ++ cc_opts - ++ split_opt ++ (if excessPrecision then [] else [ "-ffloat-store" ]) ++ include_paths ++ pkg_extra_cc_opts diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs index 409835e..2daa817 100644 --- a/ghc/compiler/main/DriverState.hs +++ b/ghc/compiler/main/DriverState.hs @@ -1,9 +1,9 @@ ----------------------------------------------------------------------------- --- $Id: DriverState.hs,v 1.65 2001/12/15 12:03:08 panne Exp $ +-- $Id: DriverState.hs,v 1.66 2002/01/04 16:02:04 simonmar Exp $ -- -- Settings for the driver -- --- (c) The University of Glasgow 2000 +-- (c) The University of Glasgow 2002 -- ----------------------------------------------------------------------------- @@ -46,7 +46,18 @@ data GhcMode | DoLink -- [ the default ] deriving (Eq) -GLOBAL_VAR(v_GhcMode, error "mode not set", GhcMode) +GLOBAL_VAR(v_GhcMode, DoLink, GhcMode) +GLOBAL_VAR(v_GhcModeFlag, "", String) + +setMode :: GhcMode -> String -> IO () +setMode m flag = do + old_mode <- readIORef v_GhcMode + old_flag <- readIORef v_GhcModeFlag + when (not (null (old_flag))) $ + throwDyn (UsageError + ("cannot use `" ++ old_flag ++ "' with `" ++ flag ++ "'")) + writeIORef v_GhcMode m + writeIORef v_GhcModeFlag flag isCompManagerMode DoMake = True isCompManagerMode DoInteractive = True @@ -146,13 +157,10 @@ osuf_ify f = do GLOBAL_VAR(v_OptLevel, 0, Int) -setOptLevel :: String -> IO () -setOptLevel "" = do { writeIORef v_OptLevel 1 } -setOptLevel "not" = writeIORef v_OptLevel 0 -setOptLevel [c] | isDigit c = do - let level = ord c - ord '0' - writeIORef v_OptLevel level -setOptLevel s = unknownFlagErr ("-O"++s) +setOptLevel :: Int -> IO () +setOptLevel n = do + when (n >= 1) $ setLang HscC -- turn on -fvia-C with -O + writeIORef v_OptLevel n GLOBAL_VAR(v_minus_o2_for_C, False, Bool) GLOBAL_VAR(v_MaxSimplifierIterations, 4, Int) diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index a9dbccf..43b104f 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -1,11 +1,11 @@ {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-} ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.93 2002/01/04 11:35:13 simonmar Exp $ +-- $Id: Main.hs,v 1.94 2002/01/04 16:02:04 simonmar Exp $ -- -- GHC Driver program -- --- (c) Simon Marlow 2000 +-- (c) The University of Glasgow 2002 -- ----------------------------------------------------------------------------- @@ -29,17 +29,16 @@ import Config ( cBooterVersion, cGhcUnregisterised, cProjectVersion ) import SysTools ( getPackageConfigPath, initSysTools, cleanTempFiles ) import Packages ( showPackages ) -import DriverPipeline ( GhcMode(..), doLink, doMkDLL, genPipeline, - getGhcMode, pipeLoop, v_GhcMode - ) +import DriverPipeline ( doLink, doMkDLL, genPipeline, pipeLoop ) import DriverState ( buildCoreToDo, buildStgToDo, defaultHscLang, findBuildTag, getPackageInfo, unregFlags, + v_GhcMode, v_GhcModeFlag, GhcMode(..), v_Cmdline_libraries, v_Keep_tmp_files, v_Ld_inputs, v_OptLevel, v_Output_file, v_Output_hi, v_Package_details, v_Ways, getPackageExtraGhcOpts, readPackageConf ) -import DriverFlags ( dynFlag, getDynFlags, buildStaticHscOpts, +import DriverFlags ( buildStaticHscOpts, dynamic_flags, processArgs, static_flags) import DriverMkDepend ( beginMkDependHS, endMkDependHS ) @@ -48,10 +47,9 @@ import DriverPhases ( Phase(HsPp, Hsc, HCc), haskellish_src_file, objish_file ) import DriverUtil ( add, handle, handleDyn, later, splitFilename, unknownFlagErr, getFileSuffix ) import CmdLineOpts ( dynFlag, defaultDynFlags, restoreDynFlags, - saveDynFlags, setDynFlags, + saveDynFlags, setDynFlags, getDynFlags, dynFlag, DynFlags(..), HscLang(..), v_Static_hsc_opts ) - import Outputable import Util import Panic ( GhcException(..), panic ) @@ -79,13 +77,6 @@ import Posix ( Handler(Catch), installHandler, sigINT, sigQUIT ) import Dynamic ( toDyn ) #endif - ------------------------------------------------------------------------------ --- Changes: - --- * -fglasgow-exts NO LONGER IMPLIES -package lang!!! (-fglasgow-exts is a --- dynamic flag whereas -package is a static flag.) - ----------------------------------------------------------------------------- -- ToDo: @@ -104,7 +95,6 @@ import Dynamic ( toDyn ) -- No more "Enter your Haskell program, end with ^D (on a line of its own):" -- consistency checking removed (may do this properly later) --- removed -noC -- no -Ofile ----------------------------------------------------------------------------- @@ -158,12 +148,10 @@ main = conf_file <- getPackageConfigPath readPackageConf conf_file - -- find the phase to stop after (i.e. -E, -C, -c, -S flags) - (flags2, mode, stop_flag) <- getGhcMode argv' - writeIORef v_GhcMode mode - -- process all the other arguments, and get the source files - non_static <- processArgs static_flags flags2 [] + non_static <- processArgs static_flags argv' [] + mode <- readIORef v_GhcMode + stop_flag <- readIORef v_GhcModeFlag -- -O and --interactive are not a good combination -- ditto with any kind of way selection @@ -199,23 +187,18 @@ main = -- set the "global" HscLang. The HscLang can be further adjusted on a module -- by module basis, using only the -fvia-C and -fasm flags. If the global -- HscLang is not HscC or HscAsm, -fvia-C and -fasm have no effect. - opt_level <- readIORef v_OptLevel - - + dyn_flags <- getDynFlags let lang = case mode of - StopBefore HCc -> HscC DoInteractive -> HscInterpreted - _other | opt_level >= 1 -> HscC -- -O implies -fvia-C - | otherwise -> defaultHscLang - - setDynFlags (defaultDynFlags{ coreToDo = core_todo, - stgToDo = stg_todo, - hscLang = lang, - -- leave out hscOutName for now - hscOutName = panic "Main.main:hscOutName not set", - - verbosity = 1 - }) + _other -> hscLang dyn_flags + + setDynFlags (dyn_flags{ coreToDo = core_todo, + stgToDo = stg_todo, + hscLang = lang, + -- leave out hscOutName for now + hscOutName = panic "Main.main:hscOutName not set", + verbosity = 1 + }) -- the rest of the arguments are "dynamic" srcs <- processArgs dynamic_flags (extra_non_static ++ non_static) [] diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index 45fb805..da57f29 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -16,7 +16,7 @@ module RnHiFiles ( #include "HsVersions.h" -import DriverState ( GhcMode(..), v_GhcMode ) +import DriverState ( GhcMode(..), v_GhcMode, isCompManagerMode ) import DriverUtil ( splitFilename ) import CmdLineOpts ( opt_IgnoreIfacePragmas ) import HscTypes ( ModuleLocation(..), @@ -497,8 +497,7 @@ findAndReadIface doc_str mod_name hi_boot_file -- and start up GHCi - it won't complain that all the modules it tries -- to load are found in the home location. ioToRnM_no_fail (readIORef v_GhcMode) `thenRn` \ mode -> - let home_allowed = hi_boot_file || - mode `notElem` [ DoInteractive, DoMake ] + let home_allowed = hi_boot_file || not (isCompManagerMode mode) in ioToRnM (if home_allowed -- 1.7.10.4