Main.hs 6.92 KB
Newer Older
1 2
{-# OPTIONS -W -fno-warn-incomplete-patterns #-}
-----------------------------------------------------------------------------
3
-- $Id: Main.hs,v 1.4 2000/10/11 15:26:18 simonmar Exp $
4 5 6 7 8 9 10 11 12 13 14 15
--
-- GHC Driver program
--
-- (c) Simon Marlow 2000
--
-----------------------------------------------------------------------------

-- with path so that ghc -M can find config.h
#include "../includes/config.h"

module Main (main) where

16 17
#include "HsVersions.h"

18 19 20 21 22
import DriverPipeline
import DriverState
import DriverFlags
import DriverMkDepend
import DriverUtil
23 24
import TmpFiles
import Config
25 26
import Util
import Panic
27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42

import Concurrent
#ifndef mingw32_TARGET_OS
import Posix
#endif
import Directory
import IOExts
import Exception
import Dynamic

import IO
import Monad
import List
import System
import Maybe

43 44 45 46 47 48
-----------------------------------------------------------------------------
-- Changes:

-- * -fglasgow-exts NO LONGER IMPLIES -package lang!!!  (-fglasgow-exts is a
--   dynamic flag whereas -package is a static flag.)

49 50 51 52 53 54 55 56 57 58 59 60 61
-----------------------------------------------------------------------------
-- ToDo:

-- new mkdependHS doesn't support all the options that the old one did (-X et al.)
-- time commands when run with -v
-- split marker
-- mkDLL
-- java generation
-- user ways
-- 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
-- -H, -K, -Rghc-timing
62
-- hi-diffs
63 64 65 66 67 68 69 70 71 72 73 74 75 76 77

-----------------------------------------------------------------------------
-- Differences vs. old driver:

-- 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 hi diffs (could be added later)
-- no -Ofile

-----------------------------------------------------------------------------
-- Main loop

main =
  -- all error messages are propagated as exceptions
78
  handleDyn (\dyn -> case dyn of
79 80 81 82
			  PhaseFailed _phase code -> exitWith code
			  Interrupted -> exitWith (ExitFailure 1)
			  _ -> do hPutStrLn stderr (show (dyn :: BarfKind))
			          exitWith (ExitFailure 1)
83
	      ) $ do
84

85 86 87 88 89
   -- make sure we clean up after ourselves
   later (do  forget_it <- readIORef keep_tmp_files
	      unless forget_it $ do
	      verb <- readIORef verbose
	      cleanTempFiles verb
90
     ) $ do
91 92 93 94 95 96 97 98
	-- exceptions will be blocked while we clean the temporary files,
	-- so there shouldn't be any difficulty if we receive further
	-- signals.

	-- install signal handlers
   main_thread <- myThreadId

#ifndef mingw32_TARGET_OS
99
   let sig_handler = Catch (throwTo main_thread 
100 101 102 103 104 105 106 107 108 109 110 111
				(DynException (toDyn Interrupted)))
   installHandler sigQUIT sig_handler Nothing 
   installHandler sigINT  sig_handler Nothing
#endif

   pgm    <- getProgName
   writeIORef prog_name pgm

   argv   <- getArgs

	-- grab any -B options from the command line first
   argv'  <- setTopDir argv
112 113 114 115 116 117 118 119 120 121 122 123 124
   top_dir <- readIORef topDir

   let installed s = top_dir ++ s
       inplace s   = top_dir ++ '/':cCURRENT_DIR ++ '/':s

       installed_pkgconfig = installed ("package.conf")
       inplace_pkgconfig   = inplace (cGHC_DRIVER_DIR ++ "/package.conf.inplace")

	-- discover whether we're running in a build tree or in an installation,
	-- by looking for the package configuration file.
   am_installed <- doesFileExist installed_pkgconfig

   if am_installed
125
	then writeIORef path_package_config installed_pkgconfig
126 127
	else do am_inplace <- doesFileExist inplace_pkgconfig
	        if am_inplace
128 129
		    then writeIORef path_package_config inplace_pkgconfig
		    else throwDyn (OtherError "can't find package.conf")
130 131 132 133 134 135 136 137 138

	-- 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_C (installed "hsc")
		writeIORef pgm_m (installed "ghc-asm")
		writeIORef pgm_s (installed "ghc-split")

139
	else do writeIORef path_usage (inplace (cGHC_DRIVER_DIR ++ "/ghc-usage.txt"))
140 141 142 143
		writeIORef pgm_L (inplace cGHC_UNLIT)
		writeIORef pgm_C (inplace cGHC_HSC)
		writeIORef pgm_m (inplace cGHC_MANGLER)
		writeIORef pgm_s (inplace cGHC_SPLIT)
144 145

	-- read the package configuration
146
   conf_file <- readIORef path_package_config
147 148 149 150
   contents <- readFile conf_file
   writeIORef package_details (read contents)

	-- find the phase to stop after (i.e. -E, -C, -c, -S flags)
151 152
   (flags2, mode, stop_flag) <- getGhcMode argv'
   writeIORef v_GhcMode mode
153 154

	-- process all the other arguments, and get the source files
155
   non_static <- processArgs static_flags flags2 []
156 157 158

	-- find the build tag, and re-process the build-specific options
   more_opts <- findBuildTag
159
   _ <- processArgs static_flags more_opts []
160 161 162 163 164 165 166 167 168 169
 
	-- give the static flags to hsc
   build_hsc_opts

	-- the rest of the arguments are "dynamic"
   srcs <- processArgs dynamic_flags non_static []

    	-- complain about any unknown flags
   let unknown_flags = [ f | ('-':f) <- srcs ]
   mapM unknownFlagErr unknown_flags
170 171 172 173

	-- get the -v flag
   verb <- readIORef verbose

174 175 176
   when verb (do hPutStr stderr "Glasgow Haskell Compiler, Version "
 	         hPutStr stderr version_str
	         hPutStr stderr ", for Haskell 98, compiled by GHC version "
177
	         hPutStrLn stderr booter_version)
178

179 180 181
   when verb (hPutStrLn stderr ("Using package config file: " ++ conf_file))

	-- mkdependHS is special
182
   when (mode == DoMkDependHS) beginMkDependHS
183

184
	-- make is special
185
   when (mode == DoMake) beginMake
186

187
	-- for each source file, find which phases to run
188
   pipelines <- mapM (genPipeline mode stop_flag) srcs
189 190 191
   let src_pipelines = zip srcs pipelines

   o_file <- readIORef output_file
192
   if isJust o_file && mode /= DoLink && length srcs > 1
193 194 195 196 197 198 199 200 201 202 203
	then throwDyn (UsageError "can't apply -o option to multiple source files")
	else do

   if null srcs then throwDyn (UsageError "no input 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

   let compileFile (src, phases) = do
204
	  r <- runPipeline phases src (mode==DoLink) True
205 206 207 208 209
	  writeIORef driver_state saved_driver_state
	  return r

   o_files <- mapM compileFile src_pipelines

210
   when (mode == DoMkDependHS) endMkDependHS
211

212
   when (mode == DoLink) (doLink o_files)
213

214 215 216 217 218 219 220 221 222
	-- grab the last -B option on the command line, and
	-- set topDir to its value.
setTopDir :: [String] -> IO [String]
setTopDir args = do
  let (minusbs, others) = partition (prefixMatch "-B") args
  (case minusbs of
    []   -> writeIORef topDir clibdir
    some -> writeIORef topDir (drop 2 (last some)))
  return others
223

224
beginMake = panic "`ghc --make' unimplemented"
225 226 227 228 229 230 231

-----------------------------------------------------------------------------
-- compatibility code

#if __GLASGOW_HASKELL__ <= 408
catchJust = catchIO
ioErrors  = justIoErrors
232
throwTo   = raiseInThread
233 234 235 236 237
#endif

#ifdef mingw32_TARGET_OS
foreign import "_getpid" getProcessID :: IO Int 
#endif