-----------------------------------------------------------------------------
--- $Id: DriverFlags.hs,v 1.8 2000/10/24 16:08:16 simonmar Exp $
+-- $Id: DriverFlags.hs,v 1.9 2000/10/26 16:21:02 sewardj Exp $
--
-- Driver flags
--
exitWith ExitSuccess))
------- verbosity ----------------------------------------------------
- , ( "v" , NoArg (writeIORef verbose True) )
- , ( "n" , NoArg (writeIORef dry_run True) )
+ , ( "v" , NoArg (writeIORef v_Verbose True) )
+ , ( "n" , NoArg (writeIORef v_Dry_run True) )
------- recompilation checker --------------------------------------
- , ( "recomp" , NoArg (writeIORef recomp True) )
- , ( "no-recomp" , NoArg (writeIORef recomp False) )
+ , ( "recomp" , NoArg (writeIORef v_Recomp True) )
+ , ( "no-recomp" , NoArg (writeIORef v_Recomp False) )
------- ways --------------------------------------------------------
- , ( "prof" , NoArg (addNoDups ways WayProf) )
- , ( "unreg" , NoArg (addNoDups ways WayUnreg) )
- , ( "dll" , NoArg (addNoDups ways WayDll) )
- , ( "ticky" , NoArg (addNoDups ways WayTicky) )
- , ( "parallel" , NoArg (addNoDups ways WayPar) )
- , ( "gransim" , NoArg (addNoDups ways WayGran) )
- , ( "smp" , NoArg (addNoDups ways WaySMP) )
- , ( "debug" , NoArg (addNoDups ways WayDebug) )
+ , ( "prof" , NoArg (addNoDups v_Ways WayProf) )
+ , ( "unreg" , NoArg (addNoDups v_Ways WayUnreg) )
+ , ( "dll" , NoArg (addNoDups v_Ways WayDll) )
+ , ( "ticky" , NoArg (addNoDups v_Ways WayTicky) )
+ , ( "parallel" , NoArg (addNoDups v_Ways WayPar) )
+ , ( "gransim" , NoArg (addNoDups v_Ways WayGran) )
+ , ( "smp" , NoArg (addNoDups v_Ways WaySMP) )
+ , ( "debug" , NoArg (addNoDups v_Ways WayDebug) )
-- ToDo: user ways
------ Debugging ----------------------------------------------------
- , ( "dppr-noprags", PassFlag (add opt_C) )
- , ( "dppr-debug", PassFlag (add opt_C) )
- , ( "dppr-user-length", AnySuffix (add opt_C) )
+ , ( "dppr-noprags", PassFlag (add v_Opt_C) )
+ , ( "dppr-debug", PassFlag (add v_Opt_C) )
+ , ( "dppr-user-length", AnySuffix (add v_Opt_C) )
-- rest of the debugging flags are dynamic
------- Interface files ---------------------------------------------
- , ( "hi" , NoArg (writeIORef produceHi True) )
- , ( "nohi" , NoArg (writeIORef produceHi False) )
+ , ( "hi" , NoArg (writeIORef v_ProduceHi True) )
+ , ( "nohi" , NoArg (writeIORef v_ProduceHi False) )
--------- Profiling --------------------------------------------------
- , ( "auto-dicts" , NoArg (add opt_C "-fauto-sccs-on-dicts") )
- , ( "auto-all" , NoArg (add opt_C "-fauto-sccs-on-all-toplevs") )
- , ( "auto" , NoArg (add opt_C "-fauto-sccs-on-exported-toplevs") )
- , ( "caf-all" , NoArg (add opt_C "-fauto-sccs-on-individual-cafs") )
+ , ( "auto-dicts" , NoArg (add v_Opt_C "-fauto-sccs-on-dicts") )
+ , ( "auto-all" , NoArg (add v_Opt_C "-fauto-sccs-on-all-toplevs") )
+ , ( "auto" , NoArg (add v_Opt_C "-fauto-sccs-on-exported-toplevs") )
+ , ( "caf-all" , NoArg (add v_Opt_C "-fauto-sccs-on-individual-cafs") )
-- "ignore-sccs" doesn't work (ToDo)
- , ( "no-auto-dicts" , NoArg (add anti_opt_C "-fauto-sccs-on-dicts") )
- , ( "no-auto-all" , NoArg (add anti_opt_C "-fauto-sccs-on-all-toplevs") )
- , ( "no-auto" , NoArg (add anti_opt_C "-fauto-sccs-on-exported-toplevs") )
- , ( "no-caf-all" , NoArg (add anti_opt_C "-fauto-sccs-on-individual-cafs") )
+ , ( "no-auto-dicts" , NoArg (add v_Anti_opt_C "-fauto-sccs-on-dicts") )
+ , ( "no-auto-all" , NoArg (add v_Anti_opt_C "-fauto-sccs-on-all-toplevs") )
+ , ( "no-auto" , NoArg (add v_Anti_opt_C "-fauto-sccs-on-exported-toplevs") )
+ , ( "no-caf-all" , NoArg (add v_Anti_opt_C "-fauto-sccs-on-individual-cafs") )
------- Miscellaneous -----------------------------------------------
, ( "no-link-chk" , NoArg (return ()) ) -- ignored for backwards compat
------- Output Redirection ------------------------------------------
- , ( "odir" , HasArg (writeIORef output_dir . Just) )
- , ( "o" , SepArg (writeIORef output_file . Just) )
- , ( "osuf" , HasArg (writeIORef output_suf . Just) )
- , ( "hisuf" , HasArg (writeIORef hi_suf) )
+ , ( "odir" , HasArg (writeIORef v_Output_dir . Just) )
+ , ( "o" , SepArg (writeIORef v_Output_file . Just) )
+ , ( "osuf" , HasArg (writeIORef v_Output_suf . Just) )
+ , ( "hisuf" , HasArg (writeIORef v_Hi_suf) )
, ( "tmpdir" , HasArg (writeIORef v_TmpDir . (++ "/")) )
, ( "ohi" , HasArg (\s -> case s of
- "-" -> writeIORef hi_on_stdout True
- _ -> writeIORef output_hi (Just s)) )
+ "-" -> writeIORef v_Hi_on_stdout True
+ _ -> writeIORef v_Output_hi (Just s)) )
-- -odump?
- , ( "keep-hc-file" , AnySuffix (\_ -> writeIORef keep_hc_files True) )
- , ( "keep-s-file" , AnySuffix (\_ -> writeIORef keep_s_files True) )
- , ( "keep-raw-s-file", AnySuffix (\_ -> writeIORef keep_raw_s_files True) )
- , ( "keep-tmp-files" , AnySuffix (\_ -> writeIORef keep_tmp_files True) )
+ , ( "keep-hc-file" , AnySuffix (\_ -> writeIORef v_Keep_hc_files True) )
+ , ( "keep-s-file" , AnySuffix (\_ -> writeIORef v_Keep_s_files True) )
+ , ( "keep-raw-s-file", AnySuffix (\_ -> writeIORef v_Keep_raw_s_files True) )
+ , ( "keep-tmp-files" , AnySuffix (\_ -> writeIORef v_Keep_tmp_files True) )
, ( "split-objs" , NoArg (if can_split
- then do writeIORef split_object_files True
- add opt_C "-fglobalise-toplev-names"
+ then do writeIORef v_Split_object_files True
+ add v_Opt_C "-fglobalise-toplev-names"
-- TODO!!!!! add opt_c "-DUSE_SPLIT_MARKERS"
else hPutStrLn stderr
"warning: don't know how to split \
) )
------- Include/Import Paths ----------------------------------------
- , ( "i" , OptPrefix (addToDirList import_paths) )
- , ( "I" , Prefix (addToDirList include_paths) )
+ , ( "i" , OptPrefix (addToDirList v_Import_paths) )
+ , ( "I" , Prefix (addToDirList v_Include_paths) )
------- Libraries ---------------------------------------------------
- , ( "L" , Prefix (addToDirList library_paths) )
- , ( "l" , Prefix (add cmdline_libraries) )
+ , ( "L" , Prefix (addToDirList v_Library_paths) )
+ , ( "l" , Prefix (add v_Cmdline_libraries) )
------- Packages ----------------------------------------------------
- , ( "package-name" , HasArg (\s -> add opt_C ("-inpackage="++s)) )
+ , ( "package-name" , HasArg (\s -> add v_Opt_C ("-inpackage="++s)) )
, ( "package" , HasArg (addPackage) )
, ( "syslib" , HasArg (addPackage) ) -- for compatibility w/ old vsns
, ( "-delete-package" , SepArg (deletePackage) )
------- Specific phases --------------------------------------------
- , ( "pgmL" , HasArg (writeIORef pgm_L) )
- , ( "pgmP" , HasArg (writeIORef pgm_P) )
- , ( "pgmc" , HasArg (writeIORef pgm_c) )
- , ( "pgmm" , HasArg (writeIORef pgm_m) )
- , ( "pgms" , HasArg (writeIORef pgm_s) )
- , ( "pgma" , HasArg (writeIORef pgm_a) )
- , ( "pgml" , HasArg (writeIORef pgm_l) )
-
- , ( "optdep" , HasArg (add opt_dep) )
- , ( "optl" , HasArg (add opt_l) )
- , ( "optdll" , HasArg (add opt_dll) )
+ , ( "pgmL" , HasArg (writeIORef v_Pgm_L) )
+ , ( "pgmP" , HasArg (writeIORef v_Pgm_P) )
+ , ( "pgmc" , HasArg (writeIORef v_Pgm_c) )
+ , ( "pgmm" , HasArg (writeIORef v_Pgm_m) )
+ , ( "pgms" , HasArg (writeIORef v_Pgm_s) )
+ , ( "pgma" , HasArg (writeIORef v_Pgm_a) )
+ , ( "pgml" , HasArg (writeIORef v_Pgm_l) )
+
+ , ( "optdep" , HasArg (add v_Opt_dep) )
+ , ( "optl" , HasArg (add v_Opt_l) )
+ , ( "optdll" , HasArg (add v_Opt_dll) )
------ Warning opts -------------------------------------------------
- , ( "W" , NoArg (writeIORef warning_opt W_) )
- , ( "Wall" , NoArg (writeIORef warning_opt W_all) )
- , ( "Wnot" , NoArg (writeIORef warning_opt W_not) )
- , ( "w" , NoArg (writeIORef warning_opt W_not) )
+ , ( "W" , NoArg (writeIORef v_Warning_opt W_) )
+ , ( "Wall" , NoArg (writeIORef v_Warning_opt W_all) )
+ , ( "Wnot" , NoArg (writeIORef v_Warning_opt W_not) )
+ , ( "w" , NoArg (writeIORef v_Warning_opt W_not) )
----- Linker --------------------------------------------------------
- , ( "static" , NoArg (writeIORef static True) )
+ , ( "static" , NoArg (writeIORef v_Static True) )
------ Compiler flags -----------------------------------------------
, ( "O2-for-C" , NoArg (writeIORef v_minus_o2_for_C True) )
, ( "O" , OptPrefix (setOptLevel) )
- , ( "fasm" , OptPrefix (\_ -> writeIORef hsc_lang HscAsm) )
+ , ( "fasm" , OptPrefix (\_ -> writeIORef v_Hsc_Lang HscAsm) )
- , ( "fvia-c" , NoArg (writeIORef hsc_lang HscC) )
- , ( "fvia-C" , NoArg (writeIORef hsc_lang HscC) )
+ , ( "fvia-c" , NoArg (writeIORef v_Hsc_Lang HscC) )
+ , ( "fvia-C" , NoArg (writeIORef v_Hsc_Lang HscC) )
- , ( "fno-asm-mangling" , NoArg (writeIORef do_asm_mangling False) )
+ , ( "fno-asm-mangling" , NoArg (writeIORef v_Do_asm_mangling False) )
, ( "fmax-simplifier-iterations",
Prefix (writeIORef v_MaxSimplifierIterations . read) )
, ( "fusagesp" , NoArg (do writeIORef v_UsageSPInf True
- add opt_C "-fusagesp-on") )
+ add v_Opt_C "-fusagesp-on") )
- , ( "fexcess-precision" , NoArg (do writeIORef excess_precision True
- add opt_C "-fexcess-precision"))
+ , ( "fexcess-precision" , NoArg (do writeIORef v_Excess_precision True
+ add v_Opt_C "-fexcess-precision"))
-- flags that are "active negatives"
- , ( "fno-implicit-prelude" , PassFlag (add opt_C) )
- , ( "fno-prune-tydecls" , PassFlag (add opt_C) )
- , ( "fno-prune-instdecls" , PassFlag (add opt_C) )
- , ( "fno-pre-inlining" , PassFlag (add opt_C) )
+ , ( "fno-implicit-prelude" , PassFlag (add v_Opt_C) )
+ , ( "fno-prune-tydecls" , PassFlag (add v_Opt_C) )
+ , ( "fno-prune-instdecls" , PassFlag (add v_Opt_C) )
+ , ( "fno-pre-inlining" , PassFlag (add v_Opt_C) )
-- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
, ( "fno-", PrefixPred (\s -> isStaticHscFlag ("f"++s))
- (\s -> add anti_opt_C ("-f"++s)) )
+ (\s -> add v_Anti_opt_C ("-f"++s)) )
-- Pass all remaining "-f<blah>" options to hsc
- , ( "f", AnySuffixPred (isStaticHscFlag) (add opt_C) )
+ , ( "f", AnySuffixPred (isStaticHscFlag) (add v_Opt_C) )
]
-----------------------------------------------------------------------------
buildStaticHscOpts :: IO [String]
buildStaticHscOpts = do
- opt_C_ <- getStaticOpts opt_C -- misc hsc opts
+ opt_C_ <- getStaticOpts v_Opt_C -- misc hsc opts
-- optimisation
minus_o <- readIORef v_OptLevel
-- take into account -fno-* flags by removing the equivalent -f*
-- flag from our list.
- anti_flags <- getStaticOpts anti_opt_C
+ anti_flags <- getStaticOpts v_Anti_opt_C
let basic_opts = opt_C_ ++ optimisation_opts ++ stg_opts
filtered_opts = filter (`notElem` anti_flags) basic_opts
verb <- is_verbose
let hi_vers = "-fhi-version="++cProjectVersionInt
- static <- (do s <- readIORef static; if s then return "-static"
- else return "")
+ static <- (do s <- readIORef v_Static; if s then return "-static"
+ else return "")
return ( filtered_opts ++ [ hi_vers, static, verb ] )
-----------------------------------------------------------------------------
--- $Id: DriverMkDepend.hs,v 1.2 2000/10/17 13:22:10 simonmar Exp $
+-- $Id: DriverMkDepend.hs,v 1.3 2000/10/26 16:21:02 sewardj Exp $
--
-- GHC Driver
--
-- mkdependHS
-- flags
-GLOBAL_VAR(dep_makefile, "Makefile", String);
-GLOBAL_VAR(dep_include_prelude, False, Bool);
-GLOBAL_VAR(dep_ignore_dirs, [], [String]);
-GLOBAL_VAR(dep_suffixes, [], [String]);
-GLOBAL_VAR(dep_warnings, True, Bool);
+GLOBAL_VAR(v_Dep_makefile, "Makefile", String);
+GLOBAL_VAR(v_Dep_include_prelude, False, Bool);
+GLOBAL_VAR(v_Dep_ignore_dirs, [], [String]);
+GLOBAL_VAR(v_Dep_suffixes, [], [String]);
+GLOBAL_VAR(v_Dep_warnings, True, Bool);
-- global vars
-GLOBAL_VAR(dep_makefile_hdl, error "dep_makefile_hdl", Maybe Handle);
-GLOBAL_VAR(dep_tmp_file, error "dep_tmp_file", String);
-GLOBAL_VAR(dep_tmp_hdl, error "dep_tmp_hdl", Handle);
-GLOBAL_VAR(dep_dir_contents, error "dep_dir_contents", [(String,[String])]);
+GLOBAL_VAR(v_Dep_makefile_hdl, error "dep_makefile_hdl", Maybe Handle);
+GLOBAL_VAR(v_Dep_tmp_file, error "dep_tmp_file", String);
+GLOBAL_VAR(v_Dep_tmp_hdl, error "dep_tmp_hdl", Handle);
+GLOBAL_VAR(v_Dep_dir_contents, error "dep_dir_contents", [(String,[String])]);
depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies"
depEndMarker = "# DO NOT DELETE: End of Haskell dependencies"
-- for compatibility with the old mkDependHS, we accept options of the form
-- -optdep-f -optdep.depend, etc.
dep_opts = [
- ( "s", SepArg (add dep_suffixes) ),
- ( "f", SepArg (writeIORef dep_makefile) ),
- ( "w", NoArg (writeIORef dep_warnings False) ),
- ( "-include-prelude", NoArg (writeIORef dep_include_prelude True) ),
- ( "X", Prefix (addToDirList dep_ignore_dirs) ),
- ( "-exclude-directory=", Prefix (addToDirList dep_ignore_dirs) )
+ ( "s", SepArg (add v_Dep_suffixes) ),
+ ( "f", SepArg (writeIORef v_Dep_makefile) ),
+ ( "w", NoArg (writeIORef v_Dep_warnings False) ),
+ ( "-include-prelude", NoArg (writeIORef v_Dep_include_prelude True) ),
+ ( "X", Prefix (addToDirList v_Dep_ignore_dirs) ),
+ ( "-exclude-directory=", Prefix (addToDirList v_Dep_ignore_dirs) )
]
beginMkDependHS :: IO ()
beginMkDependHS = do
-- slurp in the mkdependHS-style options
- flags <- getStaticOpts opt_dep
+ flags <- getStaticOpts v_Opt_dep
_ <- processArgs dep_opts flags []
-- open a new temp file in which to stuff the dependency info
-- as we go along.
dep_file <- newTempName "dep"
- writeIORef dep_tmp_file dep_file
+ writeIORef v_Dep_tmp_file dep_file
tmp_hdl <- openFile dep_file WriteMode
- writeIORef dep_tmp_hdl tmp_hdl
+ writeIORef v_Dep_tmp_hdl tmp_hdl
-- open the makefile
- makefile <- readIORef dep_makefile
+ makefile <- readIORef v_Dep_makefile
exists <- doesFileExist makefile
if not exists
then do
- writeIORef dep_makefile_hdl Nothing
+ writeIORef v_Dep_makefile_hdl Nothing
return ()
else do
makefile_hdl <- openFile makefile ReadMode
- writeIORef dep_makefile_hdl (Just makefile_hdl)
+ writeIORef v_Dep_makefile_hdl (Just makefile_hdl)
-- slurp through until we get the magic start string,
-- copying the contents into dep_makefile
-- cache the contents of all the import directories, for future
-- reference.
- import_dirs <- readIORef import_paths
+ import_dirs <- readIORef v_Import_paths
pkg_import_dirs <- getPackageImportPath
import_dir_contents <- mapM getDirectoryContents import_dirs
pkg_import_dir_contents <- mapM getDirectoryContents pkg_import_dirs
- writeIORef dep_dir_contents
+ writeIORef v_Dep_dir_contents
(zip import_dirs import_dir_contents ++
zip pkg_import_dirs pkg_import_dir_contents)
-- ignore packages unless --include-prelude is on
- include_prelude <- readIORef dep_include_prelude
+ include_prelude <- readIORef v_Dep_include_prelude
when (not include_prelude) $
- mapM_ (add dep_ignore_dirs) pkg_import_dirs
+ mapM_ (add v_Dep_ignore_dirs) pkg_import_dirs
return ()
endMkDependHS :: IO ()
endMkDependHS = do
- makefile <- readIORef dep_makefile
- makefile_hdl <- readIORef dep_makefile_hdl
- tmp_file <- readIORef dep_tmp_file
- tmp_hdl <- readIORef dep_tmp_hdl
+ makefile <- readIORef v_Dep_makefile
+ makefile_hdl <- readIORef v_Dep_makefile_hdl
+ tmp_file <- readIORef v_Dep_tmp_file
+ tmp_hdl <- readIORef v_Dep_tmp_hdl
-- write the magic marker into the tmp file
hPutStrLn tmp_hdl depEndMarker
findDependency :: String -> ModImport -> IO (Maybe (String, Bool))
findDependency mod imp = do
- dir_contents <- readIORef dep_dir_contents
- ignore_dirs <- readIORef dep_ignore_dirs
- hisuf <- readIORef hi_suf
+ dir_contents <- readIORef v_Dep_dir_contents
+ ignore_dirs <- readIORef v_Dep_ignore_dirs
+ hisuf <- readIORef v_Hi_suf
let
(imp_mod, is_source) =
-----------------------------------------------------------------------------
--- $Id: DriverPipeline.hs,v 1.7 2000/10/26 14:38:42 simonmar Exp $
+-- $Id: DriverPipeline.hs,v 1.8 2000/10/26 16:21:02 sewardj Exp $
--
-- GHC Driver
--
import CmdLineOpts
import Config
import Util
+import MkIface ( pprIface )
import Posix
import Directory
genPipeline todo stop_flag filename
= do
- split <- readIORef split_object_files
- mangle <- readIORef do_asm_mangling
- lang <- readIORef hsc_lang
- keep_hc <- readIORef keep_hc_files
- keep_raw_s <- readIORef keep_raw_s_files
- keep_s <- readIORef keep_s_files
+ split <- readIORef v_Split_object_files
+ mangle <- readIORef v_Do_asm_mangling
+ lang <- readIORef v_Hsc_Lang
+ keep_hc <- readIORef v_Keep_hc_files
+ keep_raw_s <- readIORef v_Keep_raw_s_files
+ keep_s <- readIORef v_Keep_s_files
let
----------- ----- ---- --- -- -- - - -
where
outputFileName last_phase keep suffix
- = do o_file <- readIORef output_file
+ = do o_file <- readIORef v_Output_file
if last_phase && not do_linking && use_ofile && isJust o_file
then case o_file of
Just s -> return s
-- Unlit phase
run_phase Unlit _basename _suff input_fn output_fn
- = do unlit <- readIORef pgm_L
+ = do unlit <- readIORef v_Pgm_L
unlit_flags <- getOpts opt_L
run_something "Literate pre-processor"
("echo '# 1 \"" ++input_fn++"\"' > "++output_fn++" && "
do_cpp <- readState cpp_flag
if do_cpp
then do
- cpp <- readIORef pgm_P
+ cpp <- readIORef v_Pgm_P
hscpp_opts <- getOpts opt_P
- hs_src_cpp_opts <- readIORef hs_source_cpp_opts
+ hs_src_cpp_opts <- readIORef v_Hs_source_cpp_opts
- cmdline_include_paths <- readIORef include_paths
+ cmdline_include_paths <- readIORef v_Include_paths
pkg_include_dirs <- getPackageIncludePath
let include_paths = map (\p -> "-I"++p) (cmdline_include_paths
++ pkg_include_dirs)
deps <- mapM (findDependency basename) imports
- osuf_opt <- readIORef output_suf
+ osuf_opt <- readIORef v_Output_suf
let osuf = case osuf_opt of
Nothing -> "o"
Just s -> s
- extra_suffixes <- readIORef dep_suffixes
+ extra_suffixes <- readIORef v_Dep_suffixes
let suffixes = osuf : map (++ ('_':osuf)) extra_suffixes
ofiles = map (\suf -> basename ++ '.':suf) suffixes
objs <- mapM odir_ify ofiles
- hdl <- readIORef dep_tmp_hdl
+ hdl <- readIORef v_Dep_tmp_hdl
-- std dependeny of the object(s) on the source file
hPutStrLn hdl (unwords objs ++ " : " ++ basename ++ '.':suff)
let genDep (dep, False {- not an hi file -}) =
hPutStrLn hdl (unwords objs ++ " : " ++ dep)
genDep (dep, True {- is an hi file -}) = do
- hisuf <- readIORef hi_suf
+ hisuf <- readIORef v_Hi_suf
let dep_base = remove_suffix '.' dep
deps = (dep_base ++ hisuf)
: map (\suf -> dep_base ++ suf ++ '_':hisuf) extra_suffixes
-- what gcc does, and it's probably what you want.
let current_dir = getdir basename
- paths <- readIORef include_paths
- writeIORef include_paths (current_dir : paths)
+ paths <- readIORef v_Include_paths
+ writeIORef v_Include_paths (current_dir : paths)
-- figure out where to put the .hi file
- ohi <- readIORef output_hi
- hisuf <- readIORef hi_suf
+ ohi <- readIORef v_Output_hi
+ hisuf <- readIORef v_Hi_suf
let hifile = case ohi of
Nothing -> current_dir ++ {-ToDo: modname!!-}basename
++ hisuf
-- changed (which the compiler itself figures out).
-- Setting source_unchanged to "" tells the compiler that M.o is out of
-- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
- do_recomp <- readIORef recomp
+ do_recomp <- readIORef v_Recomp
todo <- readIORef v_GhcMode
o_file <- odir_ify (basename ++ '.':phaseInputExt Ln)
source_unchanged <-
Nothing -- no iface
emptyModuleEnv -- HomeSymbolTable
emptyModuleEnv -- HomeIfaceTable
- emptyModuleEnv -- PackageIfaceTable
pcs
case result of {
HscOK details maybe_iface maybe_stub_h maybe_stub_c
_maybe_interpreted_code pcs -> do
- -- generate the interface file
- case maybe_iface of
- Nothing -> -- compilation not required
- do run_something "Touching object file" ("touch " ++ o_file)
- return False
-
- Just iface -> do
- -- discover the filename for the .hi file in a roundabout way
- let mod = moduleString (mi_module iface)
- ohi <- readIORef output_hi
- hifile <- case ohi of
- Just fn -> fn
- Nothing -> do hisuf <- readIORef hi_suf
- return (current_dir ++
- '/'mod ++ '.':hisuf)
- -- write out the interface...
- if_hdl <- openFile hifile WriteMode
- printForIface if_hdl (pprIface iface)
- hClose if_hdl
-
-- deal with stubs
maybe_stub_o <- dealWithStubs basename maybe_stub_h maybe_stub_c
case maybe_stub_o of
Nothing -> return ()
- Just stub_o -> add ld_inputs stub_o
+ Just stub_o -> add v_Ld_inputs stub_o
return True
}
run_phase cc_phase _basename _suff input_fn output_fn
| cc_phase == Cc || cc_phase == HCc
- = do cc <- readIORef pgm_c
+ = do cc <- readIORef v_Pgm_c
cc_opts <- (getOpts opt_c)
- cmdline_include_dirs <- readIORef include_paths
+ cmdline_include_dirs <- readIORef v_Include_paths
let hcc = cc_phase == HCc
ccout <- newTempName "ccout"
- mangle <- readIORef do_asm_mangling
+ mangle <- readIORef v_Do_asm_mangling
(md_c_flags, md_regd_c_flags) <- machdepCCOpts
verb <- is_verbose
pkg_extra_cc_opts <- getPackageExtraCcOpts
- excessPrecision <- readIORef excess_precision
+ excessPrecision <- readIORef v_Excess_precision
run_something "C Compiler"
(unwords ([ cc, "-x", "c", cc_help, "-o", output_fn ]
-- Mangle phase
run_phase Mangle _basename _suff input_fn output_fn
- = do mangler <- readIORef pgm_m
+ = do mangler <- readIORef v_Pgm_m
mangler_opts <- getOpts opt_m
machdep_opts <-
if (prefixMatch "i386" cTARGETPLATFORM)
-- Splitting phase
run_phase SplitMangle _basename _suff input_fn _output_fn
- = do splitter <- readIORef pgm_s
+ = do splitter <- readIORef v_Pgm_s
-- this is the prefix used for the split .s files
tmp_pfx <- readIORef v_TmpDir
x <- getProcessID
let split_s_prefix = tmp_pfx ++ "/ghc" ++ show x
- writeIORef split_prefix split_s_prefix
+ writeIORef v_Split_prefix split_s_prefix
addFilesToClean [split_s_prefix ++ "__*"] -- d:-)
-- allocate a tmp file to put the no. of split .s files in (sigh)
-- save the number of split files for future references
s <- readFile n_files
let n = read s :: Int
- writeIORef n_split_files n
+ writeIORef v_N_split_files n
return True
-----------------------------------------------------------------------------
-- As phase
run_phase As _basename _suff input_fn output_fn
- = do as <- readIORef pgm_a
+ = do as <- readIORef v_Pgm_a
as_opts <- getOpts opt_a
- cmdline_include_paths <- readIORef include_paths
+ cmdline_include_paths <- readIORef v_Include_paths
let cmdline_include_flags = map (\p -> "-I"++p) cmdline_include_paths
run_something "Assembler"
(unwords (as : as_opts
return True
run_phase SplitAs basename _suff _input_fn _output_fn
- = do as <- readIORef pgm_a
+ = do as <- readIORef v_Pgm_a
as_opts <- getOpts opt_a
- split_s_prefix <- readIORef split_prefix
- n <- readIORef n_split_files
+ split_s_prefix <- readIORef v_Split_prefix
+ n <- readIORef v_N_split_files
- odir <- readIORef output_dir
+ odir <- readIORef v_Output_dir
let real_odir = case odir of
Nothing -> basename
Just d -> d
doLink :: [String] -> IO ()
doLink o_files = do
- ln <- readIORef pgm_l
+ ln <- readIORef v_Pgm_l
verb <- is_verbose
- o_file <- readIORef output_file
+ o_file <- readIORef v_Output_file
let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
pkg_lib_paths <- getPackageLibraryPath
let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
- lib_paths <- readIORef library_paths
+ lib_paths <- readIORef v_Library_paths
let lib_path_opts = map ("-L"++) lib_paths
pkg_libs <- getPackageLibraries
let pkg_lib_opts = map (\lib -> "-l"++lib) pkg_libs
- libs <- readIORef cmdline_libraries
+ libs <- readIORef v_Cmdline_libraries
let lib_opts = map ("-l"++) (reverse libs)
-- reverse because they're added in reverse order from the cmd line
pkg_extra_ld_opts <- getPackageExtraLdOpts
-- probably _stub.o files
- extra_ld_inputs <- readIORef ld_inputs
+ extra_ld_inputs <- readIORef v_Ld_inputs
-- opts from -optl-<blah>
- extra_ld_opts <- getStaticOpts opt_l
+ extra_ld_opts <- getStaticOpts v_Opt_l
run_something "Linker"
(unwords
compile :: Finder -- to find modules
-> ModSummary -- summary, including source
-> Maybe ModIface -- old interface, if available
- -> HomeSymbolTable -- for home module ModDetails
+ -> HomeSymbolTable -- for home module ModDetails
+ -> HomeIfaceTable -- for home module Ifaces
-> PersistentCompilerState -- persistent compiler state
-> IO CompResult
| CompErrs PersistentCompilerState -- updated PCS
-compile finder summary old_iface hst pcs = do
- verb <- readIORef verbose
- when verb (hPutStrLn stderr ("compile: compiling " ++
- name_of_summary summary))
+compile finder summary old_iface hst hit pcs = do
+ verb <- readIORef v_Verbose
+ when verb (hPutStrLn stderr
+ (showSDoc (text "compile: compiling"
+ <+> ppr (name_of_summary summary))))
init_dyn_flags <- readIORef v_InitDynFlags
writeIORef v_DynFlags init_dyn_flags
processArgs dynamic_flags opts []
dyn_flags <- readIORef v_DynFlags
+ hsc_lang <- readIORef v_Hsc_Lang
output_fn <- case hsc_lang of
HscAsm -> newTempName (phaseInputExt As)
HscC -> newTempName (phaseInputExt HCc)
HscInterpreted -> return (error "no output file")
-- run the compiler
- hsc_result <- hscMain dyn_flags summary old_iface output_fn hst pcs
+ hsc_result <- hscMain dyn_flags{ hscOutName = output_fn }
+ finder summary old_iface hst hit pcs
case hsc_result of {
HscFail pcs -> return (CompErrs pcs);
HscOK details maybe_iface
- maybe_stub_h maybe_stub_c maybe_interpreted_code pcs warns -> do
+ maybe_stub_h maybe_stub_c maybe_interpreted_code pcs -> do
-- if no compilation happened, bail out early
case maybe_iface of {
- Nothing -> return (CompOK details Nothing pcs warns);
+ Nothing -> return (CompOK details Nothing pcs);
Just iface -> do
let (basename, _) = splitFilename (hs_file (ms_location summary))
maybe_stub_o <- dealWithStubs basename maybe_stub_h maybe_stub_c
- stub_unlinked <- case maybe_stub_o of
- Nothing -> []
- Just stub_o -> [ DotO stub_o ]
+ let stub_unlinked = case maybe_stub_o of
+ Nothing -> []
+ Just stub_o -> [ DotO stub_o ]
hs_unlinked <-
case hsc_lang of
-- as our "unlinked" object.
HscInterpreted ->
case maybe_interpreted_code of
- Just code -> return (Trees code)
- Nothing -> panic "compile: no interpreted code"
+ Just (code,itbl_env) -> return [Trees code itbl_env]
+ Nothing -> panic "compile: no interpreted code"
-- we're in batch mode: finish the compilation pipeline.
_other -> do pipe <- genPipeline (StopBefore Ln) "" output_fn
let linkable = LM (moduleName (ms_mod summary))
(hs_unlinked ++ stub_unlinked)
- return (CompOK details (Just (iface, linkable)) pcs warns)
+ return (CompOK details (Just (iface, linkable)) pcs)
}
}
-----------------------------------------------------------------------------
--- $Id: DriverState.hs,v 1.6 2000/10/24 16:08:16 simonmar Exp $
+-- $Id: DriverState.hs,v 1.7 2000/10/26 16:21:02 sewardj Exp $
--
-- Settings for the driver
--
opt_m = [],
}
-GLOBAL_VAR(driver_state, initDriverState, DriverState)
+GLOBAL_VAR(v_Driver_state, initDriverState, DriverState)
readState :: (DriverState -> a) -> IO a
-readState f = readIORef driver_state >>= return . f
+readState f = readIORef v_Driver_state >>= return . f
updateState :: (DriverState -> DriverState) -> IO ()
-updateState f = readIORef driver_state >>= writeIORef driver_state . f
+updateState f = readIORef v_Driver_state >>= writeIORef v_Driver_state . f
addOpt_L a = updateState (\s -> s{opt_L = a : opt_L s})
addOpt_P a = updateState (\s -> s{opt_P = a : opt_P s})
-----------------------------------------------------------------------------
-- Global compilation flags
+GLOBAL_VAR(v_Static_hsc_opts, [], [String])
+
-- location of compiler-related files
-GLOBAL_VAR(topDir, clibdir, String)
-GLOBAL_VAR(inplace, False, Bool)
+GLOBAL_VAR(v_TopDir, clibdir, String)
+GLOBAL_VAR(v_Inplace, False, Bool)
-- Cpp-related flags
-hs_source_cpp_opts = global
+v_Hs_source_cpp_opts = global
[ "-D__HASKELL1__="++cHaskell1Version
, "-D__GLASGOW_HASKELL__="++cProjectVersionInt
, "-D__HASKELL98__"
, "-D__CONCURRENT_HASKELL__"
]
+{-# NOINLINE v_Hs_source_cpp_opts #-}
-- Verbose
-GLOBAL_VAR(verbose, False, Bool)
-is_verbose = do v <- readIORef verbose; if v then return "-v" else return ""
+GLOBAL_VAR(v_Verbose, False, Bool)
+is_verbose = do v <- readIORef v_Verbose; if v then return "-v" else return ""
-- where to keep temporary files
GLOBAL_VAR(v_TmpDir, cDEFAULT_TMPDIR, String )
-- Keep output from intermediate phases
-GLOBAL_VAR(keep_hi_diffs, False, Bool)
-GLOBAL_VAR(keep_hc_files, False, Bool)
-GLOBAL_VAR(keep_s_files, False, Bool)
-GLOBAL_VAR(keep_raw_s_files, False, Bool)
-GLOBAL_VAR(keep_tmp_files, False, Bool)
+GLOBAL_VAR(v_Keep_hi_diffs, False, Bool)
+GLOBAL_VAR(v_Keep_hc_files, False, Bool)
+GLOBAL_VAR(v_Keep_s_files, False, Bool)
+GLOBAL_VAR(v_Keep_raw_s_files, False, Bool)
+GLOBAL_VAR(v_Keep_tmp_files, False, Bool)
-- Misc
-GLOBAL_VAR(scale_sizes_by, 1.0, Double)
-GLOBAL_VAR(dry_run, False, Bool)
+GLOBAL_VAR(v_Scale_sizes_by, 1.0, Double)
+GLOBAL_VAR(v_Dry_run, False, Bool)
#if !defined(HAVE_WIN32_DLL_SUPPORT) || defined(DONT_WANT_WIN32_DLL_SUPPORT)
-GLOBAL_VAR(static, True, Bool)
+GLOBAL_VAR(v_Static, True, Bool)
#else
-GLOBAL_VAR(static, False, Bool)
+GLOBAL_VAR(v_Static, False, Bool)
#endif
-GLOBAL_VAR(recomp, True, Bool)
-GLOBAL_VAR(collect_ghc_timing, False, Bool)
-GLOBAL_VAR(do_asm_mangling, True, Bool)
-GLOBAL_VAR(excess_precision, False, Bool)
+GLOBAL_VAR(v_Recomp, True, Bool)
+GLOBAL_VAR(v_Collect_ghc_timing, False, Bool)
+GLOBAL_VAR(v_Do_asm_mangling, True, Bool)
+GLOBAL_VAR(v_Excess_precision, False, Bool)
-----------------------------------------------------------------------------
-- Splitting object files (for libraries)
-GLOBAL_VAR(split_object_files, False, Bool)
-GLOBAL_VAR(split_prefix, "", String)
-GLOBAL_VAR(n_split_files, 0, Int)
+GLOBAL_VAR(v_Split_object_files, False, Bool)
+GLOBAL_VAR(v_Split_prefix, "", String)
+GLOBAL_VAR(v_N_split_files, 0, Int)
can_split :: Bool
can_split = prefixMatch "i386" cTARGETPLATFORM
-----------------------------------------------------------------------------
-- Compiler output options
-GLOBAL_VAR(hsc_lang, if cGhcWithNativeCodeGen == "YES" &&
+GLOBAL_VAR(v_Hsc_Lang, if cGhcWithNativeCodeGen == "YES" &&
(prefixMatch "i386" cTARGETPLATFORM ||
prefixMatch "sparc" cTARGETPLATFORM)
then HscAsm
else HscC,
HscLang)
-GLOBAL_VAR(output_dir, Nothing, Maybe String)
-GLOBAL_VAR(output_suf, Nothing, Maybe String)
-GLOBAL_VAR(output_file, Nothing, Maybe String)
-GLOBAL_VAR(output_hi, Nothing, Maybe String)
+GLOBAL_VAR(v_Output_dir, Nothing, Maybe String)
+GLOBAL_VAR(v_Output_suf, Nothing, Maybe String)
+GLOBAL_VAR(v_Output_file, Nothing, Maybe String)
+GLOBAL_VAR(v_Output_hi, Nothing, Maybe String)
-GLOBAL_VAR(ld_inputs, [], [String])
+GLOBAL_VAR(v_Ld_inputs, [], [String])
odir_ify :: String -> IO String
odir_ify f = do
- odir_opt <- readIORef output_dir
+ odir_opt <- readIORef v_Output_dir
case odir_opt of
Nothing -> return f
Just d -> return (newdir d f)
osuf_ify :: String -> IO String
osuf_ify f = do
- osuf_opt <- readIORef output_suf
+ osuf_opt <- readIORef v_Output_suf
case osuf_opt of
Nothing -> return f
Just s -> return (newsuf s f)
-----------------------------------------------------------------------------
-- Hi Files
-GLOBAL_VAR(produceHi, True, Bool)
-GLOBAL_VAR(hi_on_stdout, False, Bool)
-GLOBAL_VAR(hi_suf, "hi", String)
+GLOBAL_VAR(v_ProduceHi, True, Bool)
+GLOBAL_VAR(v_Hi_on_stdout, False, Bool)
+GLOBAL_VAR(v_Hi_suf, "hi", String)
-----------------------------------------------------------------------------
-- Warnings & sanity checking
]
data WarningState = W_default | W_ | W_all | W_not
-GLOBAL_VAR(warning_opt, W_default, WarningState)
+GLOBAL_VAR(v_Warning_opt, W_default, WarningState)
-----------------------------------------------------------------------------
-- Compiler optimisation options
setOptLevel s = unknownFlagErr ("-O"++s)
go_via_C = do
- l <- readIORef hsc_lang
- case l of { HscAsm -> writeIORef hsc_lang HscC;
+ l <- readIORef v_Hsc_Lang
+ case l of { HscAsm -> writeIORef v_Hsc_Lang HscC;
_other -> return () }
GLOBAL_VAR(v_minus_o2_for_C, False, Bool)
| otherwise = [ ]
-- STG passes
- ways_ <- readIORef ways
+ ways_ <- readIORef v_Ways
let flags2 | WayProf `elem` ways_ = StgDoMassageForProfiling : flags1
| otherwise = flags1
split_marker = ':' -- not configurable (ToDo)
-import_paths, include_paths, library_paths :: IORef [String]
-GLOBAL_VAR(import_paths, ["."], [String])
-GLOBAL_VAR(include_paths, ["."], [String])
-GLOBAL_VAR(library_paths, [], [String])
+v_Import_paths, v_Include_paths, v_Library_paths :: IORef [String]
+GLOBAL_VAR(v_Import_paths, ["."], [String])
+GLOBAL_VAR(v_Include_paths, ["."], [String])
+GLOBAL_VAR(v_Library_paths, [], [String])
-GLOBAL_VAR(cmdline_libraries, [], [String])
+GLOBAL_VAR(v_Cmdline_libraries, [], [String])
addToDirList :: IORef [String] -> String -> IO ()
addToDirList ref path
-----------------------------------------------------------------------------
-- Packages
-GLOBAL_VAR(path_package_config, error "path_package_config", String)
+GLOBAL_VAR(v_Path_package_config, error "path_package_config", String)
-- package list is maintained in dependency order
-packages = global ["std", "rts", "gmp"] :: IORef [String]
--- comma in value, so can't use macro, grrr
-{-# NOINLINE packages #-}
+GLOBAL_VAR(v_Packages, ("std":"rts":"gmp":[]), [String])
addPackage :: String -> IO ()
addPackage package
- = do pkg_details <- readIORef package_details
+ = do pkg_details <- readIORef v_Package_details
case lookupPkg package pkg_details of
Nothing -> throwDyn (OtherError ("unknown package name: " ++ package))
Just details -> do
- ps <- readIORef packages
+ ps <- readIORef v_Packages
unless (package `elem` ps) $ do
mapM_ addPackage (package_deps details)
- ps <- readIORef packages
- writeIORef packages (package:ps)
+ ps <- readIORef v_Packages
+ writeIORef v_Packages (package:ps)
getPackageImportPath :: IO [String]
getPackageImportPath = do
- ps <- readIORef packages
+ ps <- readIORef v_Packages
ps' <- getPackageDetails ps
return (nub (concat (map import_dirs ps')))
getPackageIncludePath :: IO [String]
getPackageIncludePath = do
- ps <- readIORef packages
+ ps <- readIORef v_Packages
ps' <- getPackageDetails ps
return (nub (filter (not.null) (concatMap include_dirs ps')))
-- includes are in reverse dependency order (i.e. rts first)
getPackageCIncludes :: IO [String]
getPackageCIncludes = do
- ps <- readIORef packages
+ ps <- readIORef v_Packages
ps' <- getPackageDetails ps
return (reverse (nub (filter (not.null) (concatMap c_includes ps'))))
getPackageLibraryPath :: IO [String]
getPackageLibraryPath = do
- ps <- readIORef packages
+ ps <- readIORef v_Packages
ps' <- getPackageDetails ps
return (nub (concat (map library_dirs ps')))
getPackageLibraries :: IO [String]
getPackageLibraries = do
- ps <- readIORef packages
+ ps <- readIORef v_Packages
ps' <- getPackageDetails ps
- tag <- readIORef build_tag
+ tag <- readIORef v_Build_tag
let suffix = if null tag then "" else '_':tag
return (concat (
map (\p -> map (++suffix) (hs_libraries p) ++ extra_libraries p) ps'
getPackageExtraGhcOpts :: IO [String]
getPackageExtraGhcOpts = do
- ps <- readIORef packages
+ ps <- readIORef v_Packages
ps' <- getPackageDetails ps
return (concatMap extra_ghc_opts ps')
getPackageExtraCcOpts :: IO [String]
getPackageExtraCcOpts = do
- ps <- readIORef packages
+ ps <- readIORef v_Packages
ps' <- getPackageDetails ps
return (concatMap extra_cc_opts ps')
getPackageExtraLdOpts :: IO [String]
getPackageExtraLdOpts = do
- ps <- readIORef packages
+ ps <- readIORef v_Packages
ps' <- getPackageDetails ps
return (concatMap extra_ld_opts ps')
getPackageDetails :: [String] -> IO [Package]
getPackageDetails ps = do
- pkg_details <- readIORef package_details
+ pkg_details <- readIORef v_Package_details
return [ pkg | p <- ps, Just pkg <- [ lookupPkg p pkg_details ] ]
-GLOBAL_VAR(package_details, (error "package_details"), [Package])
+GLOBAL_VAR(v_Package_details, (error "package_details"), [Package])
lookupPkg :: String -> [Package] -> Maybe Package
lookupPkg nm ps
-- becomes the suffix used to find .hi files and libraries used in
-- this compilation.
-GLOBAL_VAR(build_tag, "", String)
+GLOBAL_VAR(v_Build_tag, "", String)
data WayName
= WayProf
| WayUser_B
deriving (Eq,Ord)
-GLOBAL_VAR(ways, [] ,[WayName])
+GLOBAL_VAR(v_Ways, [] ,[WayName])
-- ToDo: allow WayDll with any other allowed combination
findBuildTag :: IO [String] -- new options
findBuildTag = do
- way_names <- readIORef ways
+ way_names <- readIORef v_Ways
case sort way_names of
- [] -> do writeIORef build_tag ""
+ [] -> do writeIORef v_Build_tag ""
return []
[w] -> do let details = lkupWay w
- writeIORef build_tag (wayTag details)
+ writeIORef v_Build_tag (wayTag details)
return (wayOpts details)
ws -> if ws `notElem` allowed_combinations
tag = concat (map wayTag stuff)
flags = map wayOpts stuff
in do
- writeIORef build_tag tag
+ writeIORef v_Build_tag tag
return (concat flags)
lkupWay w =
-----------------------------------------------------------------------------
-- Programs for particular phases
-GLOBAL_VAR(pgm_L, error "pgm_L", String)
-GLOBAL_VAR(pgm_P, cRAWCPP, String)
-GLOBAL_VAR(pgm_c, cGCC, String)
-GLOBAL_VAR(pgm_m, error "pgm_m", String)
-GLOBAL_VAR(pgm_s, error "pgm_s", String)
-GLOBAL_VAR(pgm_a, cGCC, String)
-GLOBAL_VAR(pgm_l, cGCC, String)
+GLOBAL_VAR(v_Pgm_L, error "pgm_L", String)
+GLOBAL_VAR(v_Pgm_P, cRAWCPP, String)
+GLOBAL_VAR(v_Pgm_c, cGCC, String)
+GLOBAL_VAR(v_Pgm_m, error "pgm_m", String)
+GLOBAL_VAR(v_Pgm_s, error "pgm_s", String)
+GLOBAL_VAR(v_Pgm_a, cGCC, String)
+GLOBAL_VAR(v_Pgm_l, cGCC, String)
-GLOBAL_VAR(opt_dep, [], [String])
-GLOBAL_VAR(anti_opt_C, [], [String])
-GLOBAL_VAR(opt_C, [], [String])
-GLOBAL_VAR(opt_l, [], [String])
-GLOBAL_VAR(opt_dll, [], [String])
+GLOBAL_VAR(v_Opt_dep, [], [String])
+GLOBAL_VAR(v_Anti_opt_C, [], [String])
+GLOBAL_VAR(v_Opt_C, [], [String])
+GLOBAL_VAR(v_Opt_l, [], [String])
+GLOBAL_VAR(v_Opt_dll, [], [String])
getStaticOpts :: IORef [String] -> IO [String]
getStaticOpts ref = readIORef ref >>= return . reverse
-- -fomit-frame-pointer : *must* in .hc files; because we're stealing
-- the fp (%ebp) for our register maps.
= do n_regs <- readState stolen_x86_regs
- sta <- readIORef static
+ sta <- readIORef v_Static
return ( [ if sta then "-DDONT_WANT_WIN32_DLL_SUPPORT" else "" ],
[ "-fno-defer-pop", "-fomit-frame-pointer",
"-DSTOLEN_X86_REGS="++show n_regs ]
run_something phase_name cmd
= do
- verb <- readIORef verbose
+ verb <- readIORef v_Verbose
when verb $ do
putStr phase_name
putStrLn ":"
hFlush stdout
-- test for -n flag
- n <- readIORef dry_run
+ n <- readIORef v_Dry_run
unless n $ do
-- and run it!
-----------------------------------------------------------------------------
--- $Id: DriverUtil.hs,v 1.3 2000/10/11 15:26:18 simonmar Exp $
+-- $Id: DriverUtil.hs,v 1.4 2000/10/26 16:21:02 sewardj Exp $
--
-- Utils for the driver
--
short_usage = "Usage: For basic information, try the `--help' option."
-GLOBAL_VAR(path_usage, "", String)
+GLOBAL_VAR(v_Path_usage, "", String)
long_usage = do
- usage_path <- readIORef path_usage
+ usage_path <- readIORef v_Path_usage
usage <- readFile usage_path
dump usage
exitWith ExitSuccess
| OtherError String -- just prints the error message
deriving Eq
-GLOBAL_VAR(prog_name, "ghc", String)
+GLOBAL_VAR(v_Prog_name, "ghc", String)
-get_prog_name = unsafePerformIO (readIORef prog_name) -- urk!
+get_prog_name = unsafePerformIO (readIORef v_Prog_name) -- urk!
instance Show BarfKind where
showsPrec _ e = showString get_prog_name . showString ": " . showBarf e
\begin{code}
-- caches contents of package directories, never expunged
-GLOBAL_VAR(pkgDirCache, Nothing, Maybe (FiniteMap String (PackageName, FilePath)))
+GLOBAL_VAR(v_PkgDirCache, Nothing, Maybe (FiniteMap String (PackageName, FilePath)))
-- caches contents of home directories, expunged whenever we
-- create a new finder.
-GLOBAL_VAR(homeDirCache, emptyFM, FiniteMap String FilePath)
+GLOBAL_VAR(v_HomeDirCache, emptyFM, FiniteMap String FilePath)
-- caches finder mapping, expunged whenever we create a new finder.
-GLOBAL_VAR(finderMapCache, emptyFM, FiniteMap ModuleName Module)
+GLOBAL_VAR(v_FinderMapCache, emptyFM, FiniteMap ModuleName Module)
newFinder :: PackageConfigInfo -> IO Finder
newFinder (PackageConfigInfo pkgs) = do
-- expunge our caches
- writeIORef homeDirCache emptyFM
- writeIORef finderMapCache emptyFM
+ writeIORef v_HomeDirCache emptyFM
+ writeIORef v_FinderMapCache emptyFM
-- populate the home dir cache, using the import path (the import path
-- is changed by -i flags on the command line, and defaults to ["."]).
- home_imports <- readIORef import_paths
+ home_imports <- readIORef v_Import_paths
let extendFM fm path = do
contents <- getDirectoryContents' path
return (addListToFM fm (zip contents (repeat path)))
home_map <- foldM extendFM emptyFM home_imports
- writeIORef homeDirCache home_map
+ writeIORef v_HomeDirCache home_map
-- populate the package cache, if necessary
- pkg_cache <- readIORef pkgDirCache
+ pkg_cache <- readIORef v_PkgDirCache
case pkg_cache of
Nothing -> do
foldM addDir fm dirs
pkg_map <- foldM extendFM emptyFM pkgs
- writeIORef pkgDirCache (Just pkg_map)
+ writeIORef v_PkgDirCache (Just pkg_map)
Just _ ->
return ()
maybeHomeModule :: ModuleName -> IO (Maybe (Module, ModuleLocation))
maybeHomeModule mod_name = do
- home_cache <- readIORef homeDirCache
+ home_cache <- readIORef v_HomeDirCache
let basename = moduleNameString mod_name
hs = basename ++ ".hs"
-- figure out the .hi file name: it lives in the same dir as the
-- source, unless there's a -ohi flag on the command line.
- ohi <- readIORef output_hi
- hisuf <- readIORef hi_suf
+ ohi <- readIORef v_Output_hi
+ hisuf <- readIORef v_Hi_suf
let hifile = case ohi of
Nothing -> basename ++ '.':hisuf
Just fn -> fn
maybePackageModule :: ModuleName -> IO (Maybe (Module, ModuleLocation))
maybePackageModule mod_name = do
- maybe_pkg_cache <- readIORef pkgDirCache
+ maybe_pkg_cache <- readIORef v_PkgDirCache
case maybe_pkg_cache of {
Nothing -> panic "maybePackageModule: no pkg_cache";
Just pkg_cache -> do
-- hi-suffix for packages depends on the build tag.
package_hisuf <-
- do tag <- readIORef build_tag
+ do tag <- readIORef v_Build_tag
if null tag
then return "hi"
else return (tag ++ "_hi")
-> Maybe ModIface -- old interface, if available
-> HomeSymbolTable -- for home module ModDetails
-> HomeIfaceTable
- -> PackageIfaceTable
-> PersistentCompilerState -- IN: persistent compiler state
-> IO HscResult
-hscMain dflags finder summary maybe_old_iface hst hit pit pcs
+hscMain dflags finder summary maybe_old_iface hst hit pcs
= do {
-- ????? source_unchanged :: Bool -- extracted from summary?
let source_unchanged = trace "WARNING: source_unchanged?!" False
| otherwise = hscNoRecomp
;
what_next dflags finder summary maybe_checked_iface
- hst hit pit pcs_ch
+ hst hit pcs_ch
}}
-hscNoRecomp dflags finder summary maybe_checked_iface hst hit pit pcs_ch
+hscNoRecomp dflags finder summary maybe_checked_iface hst hit pcs_ch
= do {
-- we definitely expect to have the old interface available
let old_iface = case maybe_checked_iface of
}}}}
-hscRecomp dflags finder summary maybe_checked_iface hst hit pit pcs_ch
+hscRecomp dflags finder summary maybe_checked_iface hst hit pcs_ch
= do {
-- what target are we shooting for?
let toInterp = dopt_HscLang dflags == HscInterpreted
= case maybe_final_iface_and_sdoc of
Just (fif, sdoc) -> Just fif; Nothing -> Nothing
;
- -- SimonM does this, higher up
- -- -- Write the interface file
- -- writeIface finder maybe_final_iface
- -- ;
+ -- Write the interface file
+ writeIface finder maybe_final_iface
+ ;
-- do the rest of code generation/emission
(maybe_stub_h_filename, maybe_stub_c_filename, maybe_ibinds)
<- restOfCodeGeneration dflags toInterp summary
{-# OPTIONS -W -fno-warn-incomplete-patterns #-}
-----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.9 2000/10/26 14:38:42 simonmar Exp $
+-- $Id: Main.hs,v 1.10 2000/10/26 16:21:02 sewardj Exp $
--
-- GHC Driver program
--
import DriverFlags
import DriverMkDepend
import DriverUtil
+import DriverPhases ( Phase(..) )
+import CmdLineOpts ( HscLang(..), DynFlags(..) )
import TmpFiles
import Config
import Util
) $ do
-- make sure we clean up after ourselves
- later (do forget_it <- readIORef keep_tmp_files
+ later (do forget_it <- readIORef v_Keep_tmp_files
unless forget_it $ do
- verb <- readIORef verbose
+ verb <- readIORef v_Verbose
cleanTempFiles verb
) $ do
-- exceptions will be blocked while we clean the temporary files,
#endif
pgm <- getProgName
- writeIORef prog_name pgm
+ writeIORef v_Prog_name pgm
argv <- getArgs
-- grab any -B options from the command line first
argv' <- setTopDir argv
- top_dir <- readIORef topDir
+ top_dir <- readIORef v_TopDir
let installed s = top_dir ++ s
inplace s = top_dir ++ '/':cCURRENT_DIR ++ '/':s
am_installed <- doesFileExist installed_pkgconfig
if am_installed
- then writeIORef path_package_config installed_pkgconfig
+ then writeIORef v_Path_package_config installed_pkgconfig
else do am_inplace <- doesFileExist inplace_pkgconfig
if am_inplace
- then writeIORef path_package_config inplace_pkgconfig
+ then writeIORef v_Path_package_config inplace_pkgconfig
else throwDyn (OtherError "can't find package.conf")
-- set the location of our various files
if am_installed
- then do writeIORef path_usage (installed "ghc-usage.txt")
- writeIORef pgm_L (installed "unlit")
- writeIORef pgm_m (installed "ghc-asm")
- writeIORef pgm_s (installed "ghc-split")
+ then do writeIORef v_Path_usage (installed "ghc-usage.txt")
+ writeIORef v_Pgm_L (installed "unlit")
+ writeIORef v_Pgm_m (installed "ghc-asm")
+ writeIORef v_Pgm_s (installed "ghc-split")
- else do writeIORef path_usage (inplace (cGHC_DRIVER_DIR ++ "/ghc-usage.txt"))
- writeIORef pgm_L (inplace cGHC_UNLIT)
- writeIORef pgm_m (inplace cGHC_MANGLER)
- writeIORef pgm_s (inplace cGHC_SPLIT)
+ else do writeIORef v_Path_usage (inplace (cGHC_DRIVER_DIR ++ "/ghc-usage.txt"))
+ writeIORef v_Pgm_L (inplace cGHC_UNLIT)
+ writeIORef v_Pgm_m (inplace cGHC_MANGLER)
+ writeIORef v_Pgm_s (inplace cGHC_SPLIT)
-- read the package configuration
- conf_file <- readIORef path_package_config
+ conf_file <- readIORef v_Path_package_config
contents <- readFile conf_file
- writeIORef package_details (read contents)
+ writeIORef v_Package_details (read contents)
-- find the phase to stop after (i.e. -E, -C, -c, -S flags)
(flags2, mode, stop_flag) <- getGhcMode argv'
writeIORef v_GhcMode mode
-- force lang to "C" if the -C flag was given
- case mode of StopBefore HCc -> writeIORef hsc_lang HscC
+ case mode of StopBefore HCc -> writeIORef v_Hsc_Lang HscC
_ -> return ()
-- process all the other arguments, and get the source files
-- give the static flags to hsc
static_opts <- buildStaticHscOpts
- writeIORef static_hsc_opts static_opts
+ writeIORef v_Static_hsc_opts static_opts
-- warnings
- warn_level <- readIORef warning_opt
- let warn_opts = case warn_level of
+ warn_level <- readIORef v_Warning_opt
+
+ let warn_opts = case warn_level of
W_default -> standardWarnings
W_ -> minusWOpts
W_all -> minusWallOpts
core_todo <- buildCoreToDo
stg_todo <- buildStgToDo
- lang <- readIORef hsc_lang
+ lang <- readIORef v_Hsc_Lang
writeIORef v_DynFlags
DynFlags{ coreToDo = core_todo,
stgToDo = stg_todo,
srcs <- processArgs dynamic_flags non_static []
-- save the "initial DynFlags" away
dyn_flags <- readIORef v_DynFlags
- writeIORef v_InitDynFlags
+ writeIORef v_InitDynFlags dyn_flags
-- complain about any unknown flags
let unknown_flags = [ f | ('-':f) <- srcs ]
mapM unknownFlagErr unknown_flags
-- get the -v flag
- verb <- readIORef verbose
+ verb <- readIORef v_Verbose
when verb (do hPutStr stderr "Glasgow Haskell Compiler, Version "
hPutStr stderr version_str
pipelines <- mapM (genPipeline mode stop_flag) srcs
let src_pipelines = zip srcs pipelines
- o_file <- readIORef output_file
+ o_file <- readIORef v_Output_file
if isJust o_file && mode /= DoLink && length srcs > 1
then throwDyn (UsageError "can't apply -o option to multiple source files")
else do
-- save the flag state, because this could be modified by OPTIONS pragmas
-- during the compilation, and we'll need to restore it before starting
-- the next compilation.
- saved_driver_state <- readIORef driver_state
+ saved_driver_state <- readIORef v_Driver_state
let compileFile (src, phases) = do
r <- runPipeline phases src (mode==DoLink) True
- writeIORef driver_state saved_driver_state
+ writeIORef v_Driver_state saved_driver_state
return r
o_files <- mapM compileFile src_pipelines
setTopDir args = do
let (minusbs, others) = partition (prefixMatch "-B") args
(case minusbs of
- [] -> writeIORef topDir clibdir
- some -> writeIORef topDir (drop 2 (last some)))
+ [] -> writeIORef v_TopDir clibdir
+ some -> writeIORef v_TopDir (drop 2 (last some)))
return others
beginMake = panic "`ghc --make' unimplemented"
-----------------------------------------------------------------------------
--- $Id: PackageMaintenance.hs,v 1.2 2000/10/11 15:26:18 simonmar Exp $
+-- $Id: PackageMaintenance.hs,v 1.3 2000/10/26 16:21:02 sewardj Exp $
--
-- GHC Driver program
--
listPackages :: IO ()
listPackages = do
- details <- readIORef package_details
+ details <- readIORef v_Package_details
hPutStr stdout (listPkgs details)
hPutChar stdout '\n'
exitWith ExitSuccess
newPackage :: IO ()
newPackage = do
checkConfigAccess
- details <- readIORef package_details
+ details <- readIORef v_Package_details
hPutStr stdout "Reading package info from stdin... "
stuff <- getContents
let new_pkg = read stuff :: Package
then throwDyn (OtherError ("package `" ++ name new_pkg ++
"' already installed"))
else do
- conf_file <- readIORef path_package_config
+ conf_file <- readIORef v_Path_package_config
savePackageConfig conf_file
maybeRestoreOldConfig conf_file $ do
writeNewConfig conf_file ( ++ [new_pkg])
deletePackage :: String -> IO ()
deletePackage pkg = do
checkConfigAccess
- details <- readIORef package_details
+ details <- readIORef v_Package_details
if (pkg `notElem` map name details)
then throwDyn (OtherError ("package `" ++ pkg ++ "' not installed"))
else do
- conf_file <- readIORef path_package_config
+ conf_file <- readIORef v_Path_package_config
savePackageConfig conf_file
maybeRestoreOldConfig conf_file $ do
writeNewConfig conf_file (filter ((/= pkg) . name))
checkConfigAccess :: IO ()
checkConfigAccess = do
- conf_file <- readIORef path_package_config
+ conf_file <- readIORef v_Path_package_config
access <- getPermissions conf_file
unless (writable access)
(throwDyn (OtherError "you don't have permission to modify the package configuration file"))
writeNewConfig :: String -> ([Package] -> [Package]) -> IO ()
writeNewConfig conf_file fn = do
hPutStr stdout "Writing new package config file... "
- old_details <- readIORef package_details
+ old_details <- readIORef v_Package_details
h <- openFile conf_file WriteMode
hPutStr h (dumpPackages (fn old_details))
hClose h
projects / ghc-hetmet.git / commitdiff