[project @ 2000-10-11 15:26:18 by simonmar]

all compiles now; not quite hooked up to hscMain yet though.

ghc/compiler/main/DriverFlags.hs

 -----------------------------------------------------------------------------
--- $Id: DriverFlags.hs,v 1.1 2000/10/11 11:54:58 simonmar Exp $
+-- $Id: DriverFlags.hs,v 1.2 2000/10/11 15:26:18 simonmar Exp $
 --
 -- Driver flags
 --
@@ -399,3 +399,95 @@ decodeSize str
 floatOpt :: IORef Double -> String -> IO ()
 floatOpt ref str
   = writeIORef ref (read str :: Double)
+
+-----------------------------------------------------------------------------
+-- Build the Hsc static command line opts
+
+build_hsc_opts :: IO [String]
+build_hsc_opts = do
+  opt_C_ <- getStaticOpts opt_C		-- misc hsc opts
+
+	-- warnings
+  warn_level <- readIORef warning_opt
+  let warn_opts =  case warn_level of
+		  	W_default -> standardWarnings
+		  	W_        -> minusWOpts
+		  	W_all	  -> minusWallOpts
+		  	W_not     -> []
+
+	-- optimisation
+  minus_o <- readIORef opt_level
+  optimisation_opts <-
+        case minus_o of
+	    0 -> hsc_minusNoO_flags
+	    1 -> hsc_minusO_flags
+	    2 -> hsc_minusO2_flags
+	    _ -> error "unknown opt level"
+	    -- ToDo: -Ofile
+ 
+	-- STG passes
+  ways_ <- readIORef ways
+  let stg_massage | WayProf `elem` ways_ =  "-fmassage-stg-for-profiling"
+	          | otherwise            = ""
+
+  stg_stats <- readIORef opt_StgStats
+  let stg_stats_flag | stg_stats = "-dstg-stats"
+		     | otherwise = ""
+
+  let stg_opts = [ stg_massage, stg_stats_flag, "-flet-no-escape" ]
+	-- let-no-escape always on for now
+
+	-- take into account -fno-* flags by removing the equivalent -f*
+	-- flag from our list.
+  anti_flags <- getStaticOpts anti_opt_C
+  let basic_opts = opt_C_ ++ warn_opts ++ 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 "")
+
+  l <- readIORef hsc_lang
+  let lang = case l of
+		HscC    -> "-olang=C"
+		HscAsm  -> "-olang=asm"
+		HscJava -> "-olang=java"
+
+  -- get hi-file suffix
+  hisuf <- readIORef hi_suf
+
+  -- hi-suffix for packages depends on the build tag.
+  package_hisuf <-
+	do tag <- readIORef build_tag
+	   if null tag
+		then return "hi"
+		else return (tag ++ "_hi")
+
+  import_dirs <- readIORef import_paths
+  package_import_dirs <- getPackageImportPath
+  
+  let hi_map = "-himap=" ++
+		makeHiMap import_dirs hisuf 
+			 package_import_dirs package_hisuf
+		   	 split_marker
+
+      hi_map_sep = "-himap-sep=" ++ [split_marker]
+
+  return 
+	(  
+	filtered_opts
+	++ [ hi_vers, static, verb, lang, hi_map, hi_map_sep ]
+	)
+
+makeHiMap 
+  (import_dirs         :: [String])
+  (hi_suffix           :: String)
+  (package_import_dirs :: [String])
+  (package_hi_suffix   :: String)   
+  (split_marker        :: Char)
+  = foldr (add_dir hi_suffix) 
+	(foldr (add_dir package_hi_suffix) "" package_import_dirs)
+	import_dirs
+  where
+     add_dir hisuf dir str = dir ++ "%." ++ hisuf ++ split_marker : str

ghc/compiler/main/DriverState.hs

 -----------------------------------------------------------------------------
--- $Id: DriverState.hs,v 1.2 2000/10/11 14:08:52 simonmar Exp $
+-- $Id: DriverState.hs,v 1.3 2000/10/11 15:26:18 simonmar Exp $
 --
 -- Settings for the driver
 --
@@ -671,6 +671,9 @@ GLOBAL_VAR(opt_C,      [], [String])
 GLOBAL_VAR(opt_l,      [], [String])
 GLOBAL_VAR(opt_dll,    [], [String])
 
+getStaticOpts :: IORef [String] -> IO [String]
+getStaticOpts ref = readIORef ref >>= return . reverse
+
 -----------------------------------------------------------------------------
 -- Via-C compilation stuff
 
@@ -756,17 +759,3 @@ run_something phase_name cmd
 	else do when verb (putStr "\n")
 	        return ()
 
------------------------------------------------------------------------------
--- File suffixes & things
-
--- the output suffix for a given phase is uniquely determined by
--- the input requirements of the next phase.
-
-unlitInputExt       = "lhs"
-cppInputExt         = "lpp"
-hscInputExt         = "cpp"
-hccInputExt         = "hc"
-ccInputExt          = "c"
-mangleInputExt      = "raw_s"
-asInputExt          = "s"
-lnInputExt          = "o"

ghc/compiler/main/DriverUtil.hs

 -----------------------------------------------------------------------------
--- $Id: DriverUtil.hs,v 1.2 2000/10/11 14:08:52 simonmar Exp $
+-- $Id: DriverUtil.hs,v 1.3 2000/10/11 15:26:18 simonmar Exp $
 --
 -- Utils for the driver
 --
@@ -21,7 +21,6 @@ import RegexString
 
 import IO
 import System
-import Directory
 import List
 import Char
 import Monad
@@ -133,6 +132,12 @@ addNoDups var x = do
   xs <- readIORef var
   unless (x `elem` xs) $ writeIORef var (x:xs)
 
+splitFilename :: String -> (String,String)
+splitFilename f = (reverse (stripDot rev_basename), reverse rev_ext)
+  where (rev_ext, rev_basename) = span ('.' /=) (reverse f)
+        stripDot ('.':xs) = xs
+        stripDot xs       = xs
+
 remove_suffix :: Char -> String -> String
 remove_suffix c s
   | null pre  = reverse suf

ghc/compiler/main/PackageMaintenance.hs

 -----------------------------------------------------------------------------
--- $Id: PackageMaintenance.hs,v 1.1 2000/10/11 11:54:58 simonmar Exp $
+-- $Id: PackageMaintenance.hs,v 1.2 2000/10/11 15:26:18 simonmar Exp $
 --
 -- GHC Driver program
 --
@@ -46,7 +46,7 @@ newPackage = do
 	then throwDyn (OtherError ("package `" ++ name new_pkg ++ 
 					"' already installed"))
 	else do
-  conf_file <- readIORef package_config
+  conf_file <- readIORef path_package_config
   savePackageConfig conf_file
   maybeRestoreOldConfig conf_file $ do
   writeNewConfig conf_file ( ++ [new_pkg])
@@ -59,7 +59,7 @@ deletePackage pkg = do
   if (pkg `notElem` map name details)
 	then throwDyn (OtherError ("package `" ++ pkg ++ "' not installed"))
 	else do
-  conf_file <- readIORef package_config
+  conf_file <- readIORef path_package_config
   savePackageConfig conf_file
   maybeRestoreOldConfig conf_file $ do
   writeNewConfig conf_file (filter ((/= pkg) . name))
@@ -67,7 +67,7 @@ deletePackage pkg = do
 
 checkConfigAccess :: IO ()
 checkConfigAccess = do
-  conf_file <- readIORef package_config
+  conf_file <- readIORef path_package_config
   access <- getPermissions conf_file
   unless (writable access)
 	(throwDyn (OtherError "you don't have permission to modify the package configuration file"))

ghc/compiler/main/PreProcess.hs

------------------------------------------------------------------------------
--- $Id: PreProcess.hs,v 1.1 2000/10/11 11:54:58 simonmar Exp $
---
--- Pre-process source files
---
--- (c) The University of Glasgow 2000
---
------------------------------------------------------------------------------
-
-module PreProcess (
-	preprocess -- :: FilePath -> IO FilePath
-   ) where
-
-import TmpFiles
-import DriverState
-import DriverUtil
-
-import IOExts
-
------------------------------------------------------------------------------
--- preprocess takes a haskell source file and generates a raw .hs
--- file.  This involves passing the file through 'unlit', 'cpp', or both.
-
-preprocess :: FilePath -> IO FilePath
-preprocess filename = do
-  let (basename, suffix) = splitFilename filename
-
-  unlit_file <- unlit filename
-  cpp_file   <- cpp unlit_file
-  return cpp_file
-
--------------------------------------------------------------------------------
--- Unlit phase 
-
-unlit :: FilePath -> IO FilePath
-unlit input_fn
-  | suffix /= unlitInputExt = return input_fn
-  | otherwise =
-     do output_fn <- newTempName cppInputExt
-  	unlit <- readIORef pgm_L
-     	unlit_flags <- getOpts opt_L
-     	run_something "Literate pre-processor"
-	   ("echo '# 1 \"" ++input_fn++"\"' > "++output_fn++" && "
-	   ++ unlit ++ ' ':input_fn ++ " - >> " ++ output_fn)
-	return output_fn
-   where
-	(filename, suffix) = splitFilename input_fn
-
--------------------------------------------------------------------------------
--- Cpp phase 
-
-cpp :: FilePath -> IO FilePath
-cpp input_fn
-  = do src_opts <- getOptionsFromSource input_fn
-       _ <- processArgs dynamic_flags src_opts []
-
-       output_fn <- newTempName hscInputExt
-
-       do_cpp <- readState cpp_flag
-       if do_cpp
-          then do
-
-       	    cpp <- readIORef pgm_P
-	    hscpp_opts <- getOpts opt_P
-       	    hs_src_cpp_opts <- readIORef hs_source_cpp_opts
-
-	    cmdline_include_paths <- readIORef include_paths
-	    pkg_include_dirs <- getPackageIncludePath
-	    let include_paths = map (\p -> "-I"++p) (cmdline_include_paths
-							++ pkg_include_dirs)
-
-	    verb <- is_verbose
-	    run_something "C pre-processor" 
-		(unwords
-       	    	   (["echo '{-# LINE 1 \"" ++ input_fn ++ "\" -}'", ">", output_fn, "&&",
-		     cpp, verb] 
-		    ++ include_paths
-		    ++ hs_src_cpp_opts
-	    	    ++ hscpp_opts
-		    ++ [ "-x", "c", input_fn, ">>", output_fn ]
-		   ))
-	  else do
-	    run_something "Ineffective C pre-processor"
-	           ("echo '{-# LINE 1 \""  ++ input_fn ++ "\" -}' > " 
-		    ++ output_fn ++ " && cat " ++ input_fn
-		    ++ " >> " ++ output_fn)
-       return True
-
------------------------------------------------------------------------------
--- utils
-
-splitFilename :: String -> (String,String)
-splitFilename f = (reverse (stripDot rev_basename), reverse rev_ext)
-  where (rev_ext, rev_basename) = span ('.' /=) (reverse f)
-        stripDot ('.':xs) = xs
-        stripDot xs       = xs
-