--
-----------------------------------------------------------------------------
+-- with path so that ghc -M can find config.h
+#include "../includes/config.h"
+
module Main (main) where
import Package
import RegexString
import Concurrent
+#ifndef mingw32_TARGET_OS
import Posix
+#endif
+import Directory
import IOExts
import Exception
import Dynamic
import Maybe
import Char
+#ifdef mingw32_TARGET_OS
+foreign import "_getpid" getProcessID :: IO Int
+#endif
+
#define GLOBAL_VAR(name,value,ty) \
name = global (value) :: IORef (ty); \
{-# NOINLINE name #-}
-- mkDLL
-- java generation
-- user ways
--- Win32 support
+-- Win32 support: proper signal handling
-- make sure OPTIONS in .hs file propogate to .hc file if -C or -keep-hc-file-too
-- reading the package configuration file is too slow
exitWith ExitSuccess
long_usage = do
- let usage_filename = "ghc-usage.txt"
- usage_dir = findFile usage_filename cGHC_DRIVER_DIR
- usage <- readFile (usage_dir ++ "/" ++ usage_filename)
+ let usage_file = "ghc-usage.txt"
+ usage_path = findFile usage_file (cGHC_DRIVER_DIR ++ '/':usage_file)
+ usage <- readFile usage_path
dump usage
exitWith ExitSuccess
where
-- Temporary files
GLOBAL_VAR(files_to_clean, [], [String])
+GLOBAL_VAR(keep_tmp_files, False, Bool)
cleanTempFiles :: IO ()
cleanTempFiles = do
+ forget_it <- readIORef keep_tmp_files
+ unless forget_it $ do
+
fs <- readIORef files_to_clean
verb <- readIORef verbose
let blowAway f =
(do on verb (hPutStrLn stderr ("removing: " ++ f))
if '*' `elem` f then system ("rm -f " ++ f) >> return ()
- else removeLink f)
+ else removeFile f)
`catchAllIO`
(\e -> on verb (hPutStrLn stderr
("warning: can't remove tmp file" ++ f)))
GLOBAL_VAR(recomp, True, Bool)
GLOBAL_VAR(tmp_prefix, cTMPDIR, String)
GLOBAL_VAR(stolen_x86_regs, 4, Int)
-GLOBAL_VAR(static, True, Bool) -- ToDo: not for mingw32
+#if !defined(HAVE_WIN32_DLL_SUPPORT) || defined(DONT_WANT_WIN32_DLL_SUPPORT)
+GLOBAL_VAR(static, True, Bool)
+#else
+GLOBAL_VAR(static, False, Bool)
+#endif
GLOBAL_VAR(collect_ghc_timing, False, Bool)
GLOBAL_VAR(do_asm_mangling, True, Bool)
| HscJava
GLOBAL_VAR(hsc_lang, if cGhcWithNativeCodeGen == "YES" &&
- prefixMatch "i386" cTARGETPLATFORM
+ (prefixMatch "i386" cTARGETPLATFORM ||
+ prefixMatch "sparc" cTARGETPLATFORM)
then HscAsm
else HscC,
HscLang)
checkConfigAccess :: IO ()
checkConfigAccess = do
conf_file <- readIORef package_config
- access <- fileAccess conf_file True True False
- if not access
- then throwDyn (OtherError "you don't have permission to modify the package configuration file")
- else return ()
+ access <- getPermissions conf_file
+ unless (writable access)
+ (throwDyn (OtherError "you don't have permission to modify the package configuration file"))
maybeRestoreOldConfig :: String -> IO () -> IO ()
maybeRestoreOldConfig conf_file io
Nothing -> throwDyn (UnknownPackage package)
Just details -> do
ps <- readIORef packages
- if package `elem` ps
- then return ()
- else do mapM_ addPackage (package_deps details)
- ps <- readIORef packages
- writeIORef packages (package:ps)
+ unless (package `elem` ps) $ do
+ mapM_ addPackage (package_deps details)
+ ps <- readIORef packages
+ writeIORef packages (package:ps)
getPackageImportPath :: IO [String]
getPackageImportPath = do
getPackageIncludePath = do
ps <- readIORef packages
ps' <- getPackageDetails ps
- return (nub (filter (not.null) (map include_dir 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' <- getPackageDetails ps
- return (reverse (nub (filter (not.null) (map c_include ps'))))
+ return (reverse (nub (filter (not.null) (concatMap c_includes ps'))))
getPackageLibraryPath :: IO [String]
getPackageLibraryPath = do
getPackageExtraGhcOpts = do
ps <- readIORef packages
ps' <- getPackageDetails ps
- return (map extra_ghc_opts ps')
+ return (concatMap extra_ghc_opts ps')
getPackageExtraCcOpts :: IO [String]
getPackageExtraCcOpts = do
ps <- readIORef packages
ps' <- getPackageDetails ps
- return (map extra_cc_opts ps')
+ return (concatMap extra_cc_opts ps')
getPackageExtraLdOpts :: IO [String]
getPackageExtraLdOpts = do
ps <- readIORef packages
ps' <- getPackageDetails ps
- return (map extra_ld_opts ps')
+ return (concatMap extra_ld_opts ps')
+getPackageDetails :: [String] -> IO [Package]
getPackageDetails ps = do
pkg_details <- readIORef package_details
- let getDetails p = case lookup p pkg_details of
- Just details -> return details
- Nothing -> error "getPackageDetails"
- mapM getDetails ps
+ return [ pkg | p <- ps, Just pkg <- [ lookup p pkg_details ] ]
GLOBAL_VAR(package_details, (error "package_details"), [(String,Package)])
do
-- install signal handlers
main_thread <- myThreadId
+
+#ifndef mingw32_TARGET_OS
let sig_handler = Catch (raiseInThread main_thread
(DynException (toDyn Interrupted)))
installHandler sigQUIT sig_handler Nothing
installHandler sigINT sig_handler Nothing
+#endif
pgm <- getProgName
writeIORef prog_name pgm
o_files <- mapM compileFile phase_srcs
- if do_linking
- then do_link o_files unknown_srcs
- else return ()
+ when do_linking $
+ do_link o_files unknown_srcs
-- The following compilation pipeline algorithm is fairly hacky. A
Ln -> True
Mangle | keep_raw_s -> True -- first enhancement :)
As | keep_s -> True
- Cc | keep_hc -> True
+ HCc | keep_hc -> True
_other -> False
output_fn <-
-- sadly, ghc -E is supposed to write the file to stdout. We
-- generate <file>.cpp, so we also have to cat the file here.
- if (next_phase > last_phase && last_phase == Cpp)
- then run_something "Dump pre-processed file to stdout"
- ("cat " ++ output_fn)
- else return ()
+ when (next_phase > last_phase && last_phase == Cpp) $
+ run_something "Dump pre-processed file to stdout"
+ ("cat " ++ output_fn)
run_pipeline last_phase do_linking use_ofile
orig_basename (next_phase, output_fn)
findTempName tmp_dir x
where findTempName tmp_dir x = do
let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
- b <- fileExist filename
+ b <- doesFileExist filename
if b then findTempName tmp_dir (x+1)
else return filename
let stub_c = basename ++ "_stub.c"
-- copy .h_stub file into current dir if present
- b <- fileExist tmp_stub_h
+ b <- doesFileExist tmp_stub_h
on b (do
run_something "Copy stub .h file"
("cp " ++ tmp_stub_h ++ ' ':stub_h)
run_phase cc_phase basename input_fn output_fn
| cc_phase == Cc || cc_phase == HCc
= do cc <- readIORef pgm_c
- cc_opts <- getOpts opt_c
+ cc_opts <- (getOpts opt_c)
cmdline_include_dirs <- readIORef include_paths
- -- ToDo: $c_flags .= " -mno-cygwin" if ( $TargetPlatform =~ /-mingw32$/ );
let hcc = cc_phase == HCc
++ [ verb, "-S", "-Wimplicit", opt_flag ]
++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
++ cc_opts
+#ifdef mingw32_TARGET_OS
+ ++ [" -mno-cygwin"]
+#endif
++ include_paths
++ pkg_extra_cc_opts
-- ++ [">", ccout]
run_something phase_name cmd
= do
verb <- readIORef verbose
- if verb then do
+ when verb $ do
putStr phase_name
putStrLn ":"
putStrLn cmd
- else
- return ()
-- test for -n flag
n <- readIORef dry_run
- if n then return () else do
+ unless n $ do
-- and run it!
- exit_code <- system cmd `catchAllIO`
+ exit_code <- system ("sh -c \"" ++ cmd ++ "\"") `catchAllIO`
(\e -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
if exit_code /= ExitSuccess
, ( "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) )
, ( "split-objs" , NoArg (if can_split
then do writeIORef split_object_files True
- writeIORef hsc_lang HscC
add opt_C "-fglobalise-toplev-names"
add opt_c "-DUSE_SPLIT_MARKERS"
else hPutStrLn stderr
, ( "fasm" , OptPrefix (\_ -> writeIORef hsc_lang HscAsm) )
+ , ( "fvia-c" , NoArg (writeIORef hsc_lang HscC) )
, ( "fvia-C" , NoArg (writeIORef hsc_lang HscC) )
, ( "fno-asm-mangling" , NoArg (writeIORef do_asm_mangling False) )
, ( "fmax-simplifier-iterations",
Prefix (writeIORef opt_MaxSimplifierIterations . read) )
- , ( "fusagesp", NoArg (do writeIORef opt_UsageSPInf True
- add opt_C "-fusagesp-on") )
+ , ( "fusagesp" , NoArg (do writeIORef opt_UsageSPInf True
+ add opt_C "-fusagesp-on") )
+
+ , ( "fstrictfp" , NoArg (do add opt_C "-fstrictfp"
+ add opt_c "-ffloat-store"))
-- flags that are "active negatives"
, ( "fno-implicit-prelude" , PassFlag (add opt_C) )
writeSizeOpt :: IORef Integer -> Integer -> IO ()
writeSizeOpt ref new = do
current <- readIORef ref
- if (new > current)
- then writeIORef ref new
- else return ()
+ when (new > current) $
+ writeIORef ref new
floatOpt :: IORef Double -> String -> IO ()
floatOpt ref str
top_dir <- readIORef topDir
let installed_file = top_dir ++ '/':name
let inplace_file = top_dir ++ '/':cCURRENT_DIR ++ '/':alt_path
- b <- fileExist inplace_file
+ b <- doesFileExist inplace_file
if b then return inplace_file
else return installed_file
)
global a = unsafePerformIO (newIORef a)
split_filename :: String -> (String,String)
-split_filename f = (reverse rev_basename, reverse rev_ext)
- where (rev_ext, '.':rev_basename) = span ('.' /=) (reverse f)
+split_filename f = (reverse (stripDot rev_basename), reverse rev_ext)
+ where (rev_ext, rev_basename) = span ('.' /=) (reverse f)
+ stripDot ('.':xs) = xs
+ stripDot xs = xs
split :: Char -> String -> [String]
split c s = case rest of
addNoDups :: Eq a => IORef [a] -> a -> IO ()
addNoDups var x = do
xs <- readIORef var
- if x `elem` xs then return () else writeIORef var (x:xs)
+ unless (x `elem` xs) $ writeIORef var (x:xs)
remove_suffix :: String -> Char -> String
remove_suffix s c
projects / ghc-hetmet.git / blobdiff