summaryrefslogtreecommitdiff
path: root/ghc/compiler/main
diff options
context:
space:
mode:
Diffstat (limited to 'ghc/compiler/main')
-rw-r--r--ghc/compiler/main/CmdLineOpts.lhs6
-rw-r--r--ghc/compiler/main/CodeOutput.lhs38
-rw-r--r--ghc/compiler/main/Constants.lhs111
-rw-r--r--ghc/compiler/main/DriverFlags.hs8
-rw-r--r--ghc/compiler/main/DriverPhases.hs19
-rw-r--r--ghc/compiler/main/DriverPipeline.hs110
-rw-r--r--ghc/compiler/main/DriverState.hs8
-rw-r--r--ghc/compiler/main/DriverUtil.hs4
-rw-r--r--ghc/compiler/main/ErrUtils.lhs4
-rw-r--r--ghc/compiler/main/HscMain.lhs15
-rw-r--r--ghc/compiler/main/Main.hs10
-rw-r--r--ghc/compiler/main/SysTools.lhs2
12 files changed, 157 insertions, 178 deletions
diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs
index b68d236597..64ed4adaf5 100644
--- a/ghc/compiler/main/CmdLineOpts.lhs
+++ b/ghc/compiler/main/CmdLineOpts.lhs
@@ -210,7 +210,7 @@ data FloatOutSwitches
data DynFlag
-- debugging flags
- = Opt_D_dump_absC
+ = Opt_D_dump_cmm
| Opt_D_dump_asm
| Opt_D_dump_cpranal
| Opt_D_dump_deriv
@@ -220,7 +220,6 @@ data DynFlag
| Opt_D_dump_inlinings
| Opt_D_dump_occur_anal
| Opt_D_dump_parsed
- | Opt_D_dump_realC
| Opt_D_dump_rn
| Opt_D_dump_simpl
| Opt_D_dump_simpl_iterations
@@ -235,7 +234,7 @@ data DynFlag
| Opt_D_dump_worker_wrapper
| Opt_D_dump_rn_trace
| Opt_D_dump_rn_stats
- | Opt_D_dump_stix
+ | Opt_D_dump_opt_cmm
| Opt_D_dump_simpl_stats
| Opt_D_dump_tc_trace
| Opt_D_dump_if_trace
@@ -250,6 +249,7 @@ data DynFlag
| Opt_D_dump_minimal_imports
| Opt_DoCoreLinting
| Opt_DoStgLinting
+ | Opt_DoCmmLinting
| Opt_WarnIsError -- -Werror; makes warnings fatal
| Opt_WarnDuplicateExports
diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs
index 9a24fc07d2..7732497a64 100644
--- a/ghc/compiler/main/CodeOutput.lhs
+++ b/ghc/compiler/main/CodeOutput.lhs
@@ -24,25 +24,27 @@ import qualified PrintJava
import OccurAnal ( occurAnalyseBinds )
#endif
+import PprC ( writeCs )
+import CmmLint ( cmmLint )
import Packages
import DriverState ( getExplicitPackagesAnd, getPackageCIncludes )
import FastString ( unpackFS )
-import AbsCSyn ( AbstractC )
-import PprAbsC ( dumpRealC, writeRealC )
+import Cmm ( Cmm )
import HscTypes
import CmdLineOpts
-import ErrUtils ( dumpIfSet_dyn, showPass )
+import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit )
import Outputable
import Pretty ( Mode(..), printDoc )
import Module ( Module )
import ListSetOps ( removeDupsEq )
+import Maybes ( firstJust )
-import Directory ( doesFileExist )
+import Directory ( doesFileExist )
+import Data.List ( intersperse )
import Monad ( when )
import IO
\end{code}
-
%************************************************************************
%* *
\subsection{Steering}
@@ -54,7 +56,7 @@ codeOutput :: DynFlags
-> Module
-> ForeignStubs
-> Dependencies
- -> AbstractC -- Compiled abstract C
+ -> [Cmm] -- Compiled C--
-> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-})
codeOutput dflags this_mod foreign_stubs deps flat_abstractC
@@ -65,7 +67,17 @@ codeOutput dflags this_mod foreign_stubs deps flat_abstractC
-- Dunno if the above comment is still meaningful now. JRS 001024.
- do { showPass dflags "CodeOutput"
+ do { when (dopt Opt_DoCmmLinting dflags) $ do
+ { showPass dflags "CmmLint"
+ ; let lints = map cmmLint flat_abstractC
+ ; case firstJust lints of
+ Just err -> do { printDump err
+ ; ghcExit 1
+ }
+ Nothing -> return ()
+ }
+
+ ; showPass dflags "CodeOutput"
; let filenm = dopt_OutName dflags
; stubs_exist <- outputForeignStubs dflags foreign_stubs
; case dopt_HscLang dflags of {
@@ -104,8 +116,7 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
\begin{code}
outputC dflags filenm flat_absC
(stub_h_exists, _) dependencies foreign_stubs
- = do dumpIfSet_dyn dflags Opt_D_dump_realC "Real C" (dumpRealC flat_absC)
-
+ = do
-- figure out which header files to #include in the generated .hc file:
--
-- * extra_includes from packages
@@ -142,7 +153,7 @@ outputC dflags filenm flat_absC
hPutStr h cc_injects
when stub_h_exists $
hPutStrLn h ("#include \"" ++ (hscStubHOutName dflags) ++ "\"")
- writeRealC h flat_absC
+ writeCs h flat_absC
\end{code}
@@ -158,9 +169,8 @@ outputAsm dflags filenm flat_absC
#ifndef OMIT_NATIVE_CODEGEN
= do ncg_uniqs <- mkSplitUniqSupply 'n'
- let (stix_final, ncg_output_d) = _scc_ "NativeCodeGen"
- nativeCodeGen flat_absC ncg_uniqs
- dumpIfSet_dyn dflags Opt_D_dump_stix "Final stix code" stix_final
+ ncg_output_d <- _scc_ "NativeCodeGen"
+ nativeCodeGen dflags flat_absC ncg_uniqs
dumpIfSet_dyn dflags Opt_D_dump_asm "Asm code" (docToSDoc ncg_output_d)
_scc_ "OutputAsm" doOutput filenm $
\f -> printDoc LeftMode f ncg_output_d
@@ -247,7 +257,7 @@ outputForeignStubs dflags (ForeignStubs h_code c_code _ _)
stub_c_file_exists
<- outputForeignStubs_help (hscStubCOutName dflags) stub_c_output_w
("#define IN_STG_CODE 0\n" ++
- "#include \"RtsAPI.h\"\n" ++
+ "#include \"Rts.h\"\n" ++
rts_includes ++
cplusplus_hdr)
cplusplus_ftr
diff --git a/ghc/compiler/main/Constants.lhs b/ghc/compiler/main/Constants.lhs
index 9d6a7cc638..091a7de4dc 100644
--- a/ghc/compiler/main/Constants.lhs
+++ b/ghc/compiler/main/Constants.lhs
@@ -4,68 +4,7 @@
\section[Constants]{Info about this compilation}
\begin{code}
-module Constants (
- mAX_CONTEXT_REDUCTION_DEPTH,
- mAX_TUPLE_SIZE,
-
- mAX_SPEC_THUNK_SIZE,
- mAX_SPEC_FUN_SIZE,
- mAX_SPEC_CONSTR_SIZE,
- mAX_SPEC_SELECTEE_SIZE,
- mAX_SPEC_AP_SIZE,
-
- mIN_UPD_SIZE,
- mIN_SIZE_NonUpdHeapObject,
-
- sTD_HDR_SIZE,
- pROF_HDR_SIZE,
- gRAN_HDR_SIZE,
- aRR_WORDS_HDR_SIZE,
- aRR_PTRS_HDR_SIZE,
- rESERVED_C_STACK_BYTES,
- rESERVED_STACK_WORDS,
-
- sTD_ITBL_SIZE,
- rET_ITBL_SIZE,
- pROF_ITBL_SIZE,
- gRAN_ITBL_SIZE,
- tICKY_ITBL_SIZE,
-
- mAX_FAMILY_SIZE_FOR_VEC_RETURNS,
-
- uF_SIZE,
- pROF_UF_SIZE,
- gRAN_UF_SIZE, -- HWL
- uF_RET,
- uF_UPDATEE,
-
- mAX_Vanilla_REG,
- mAX_Float_REG,
- mAX_Double_REG,
- mAX_Long_REG,
-
- mAX_Real_Vanilla_REG,
- mAX_Real_Float_REG,
- mAX_Real_Double_REG,
- mAX_Real_Long_REG,
-
- mAX_INTLIKE, mIN_INTLIKE,
- mAX_CHARLIKE, mIN_CHARLIKE,
-
- spRelToInt,
-
- dOUBLE_SIZE,
- iNT64_SIZE,
- wORD64_SIZE,
-
- wORD_SIZE,
- wORD_SIZE_IN_BITS,
-
- bLOCK_SIZE,
- bLOCK_SIZE_W,
-
- bITMAP_BITS_SHIFT,
- ) where
+module Constants (module Constants) where
-- This magical #include brings in all the everybody-knows-these magic
-- constants unfortunately, we need to be *explicit* about which one
@@ -73,7 +12,7 @@ module Constants (
-- be in trouble.
#include "HsVersions.h"
-#include "../includes/config.h"
+#include "../includes/ghcconfig.h"
#include "../includes/MachRegs.h"
#include "../includes/Constants.h"
#include "../includes/MachDeps.h"
@@ -107,47 +46,20 @@ mIN_SIZE_NonUpdHeapObject = (MIN_NONUPD_SIZE::Int)
\end{code}
\begin{code}
-mIN_INTLIKE, mAX_INTLIKE :: Integer -- Only used to compare with (MachInt Integer)
+mIN_INTLIKE, mAX_INTLIKE :: Int
mIN_INTLIKE = MIN_INTLIKE
mAX_INTLIKE = MAX_INTLIKE
-mIN_CHARLIKE, mAX_CHARLIKE :: Int -- Only used to compare with (MachChar Int)
+mIN_CHARLIKE, mAX_CHARLIKE :: Int
mIN_CHARLIKE = MIN_CHARLIKE
mAX_CHARLIKE = MAX_CHARLIKE
\end{code}
-A little function that abstracts the stack direction. Note that most
-of the code generator is dependent on the stack direction anyway, so
-changing this on its own spells certain doom. ToDo: remove?
-
-\begin{code}
--- THIS IS DIRECTION SENSITIVE!
-
--- stack grows down, positive virtual offsets correspond to negative
--- additions to the stack pointer.
-
-spRelToInt :: Int{-VirtualSpOffset-} -> Int{-VirtualSpOffset-} -> Int
-spRelToInt sp off = sp - off
-\end{code}
-
A section of code-generator-related MAGIC CONSTANTS.
\begin{code}
mAX_FAMILY_SIZE_FOR_VEC_RETURNS = (MAX_VECTORED_RTN::Int) -- pretty arbitrary
-- If you change this, you may need to change runtimes/standard/Update.lhc
-
--- The update frame sizes
-uF_SIZE = (STD_UF_SIZE::Int)
-
--- Same again, with profiling
-pROF_UF_SIZE = (PROF_UF_SIZE::Int)
-
--- Same again, with gransim
-gRAN_UF_SIZE = (GRAN_UF_SIZE::Int)
-
--- Offsets in an update frame. They don't change with profiling!
-uF_RET = (UF_RET::Int)
-uF_UPDATEE = (UF_UPDATEE::Int)
\end{code}
\begin{code}
@@ -172,8 +84,6 @@ Closure header sizes.
sTD_HDR_SIZE = (STD_HDR_SIZE :: Int)
pROF_HDR_SIZE = (PROF_HDR_SIZE :: Int)
gRAN_HDR_SIZE = (GRAN_HDR_SIZE :: Int)
-aRR_WORDS_HDR_SIZE = (ARR_WORDS_HDR_SIZE :: Int)
-aRR_PTRS_HDR_SIZE = (ARR_PTRS_HDR_SIZE :: Int)
\end{code}
Info Table sizes.
@@ -189,8 +99,8 @@ tICKY_ITBL_SIZE = (TICKY_ITBL_SIZE :: Int)
Size of a double in StgWords.
\begin{code}
-dOUBLE_SIZE = (SIZEOF_DOUBLE `quot` SIZEOF_HSWORD :: Int)
-wORD64_SIZE = (8 `quot` SIZEOF_HSWORD :: Int)
+dOUBLE_SIZE = SIZEOF_DOUBLE :: Int
+wORD64_SIZE = 8 :: Int
iNT64_SIZE = wORD64_SIZE
\end{code}
@@ -219,7 +129,7 @@ Size of a storage manager block (in bytes).
\begin{code}
bLOCK_SIZE = (BLOCK_SIZE :: Int)
-bLOCK_SIZE_W = (bLOCK_SIZE `div` wORD_SIZE :: Int)
+bLOCK_SIZE_W = (bLOCK_SIZE `quot` wORD_SIZE :: Int)
\end{code}
Number of bits to shift a bitfield left by in an info table.
@@ -227,3 +137,10 @@ Number of bits to shift a bitfield left by in an info table.
\begin{code}
bITMAP_BITS_SHIFT = (BITMAP_BITS_SHIFT :: Int)
\end{code}
+
+Constants derived from headers in ghc/includes, generated by the program
+../includes/mkDerivedConstants.c.
+
+\begin{code}
+#include "../includes/GHCConstants.h"
+\end{code}
diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs
index 766da42b8f..c09e43ad2d 100644
--- a/ghc/compiler/main/DriverFlags.hs
+++ b/ghc/compiler/main/DriverFlags.hs
@@ -14,7 +14,7 @@ module DriverFlags (
) where
#include "HsVersions.h"
-#include "../includes/config.h"
+#include "../includes/ghcconfig.h"
import MkIface ( showIface )
import DriverState
@@ -347,7 +347,7 @@ dynamic_flags = [
------ Debugging ----------------------------------------------------
, ( "dstg-stats", NoArg (writeIORef v_StgStats True) )
- , ( "ddump-absC", NoArg (setDynFlag Opt_D_dump_absC) )
+ , ( "ddump-cmm", NoArg (setDynFlag Opt_D_dump_cmm) )
, ( "ddump-asm", NoArg (setDynFlag Opt_D_dump_asm) )
, ( "ddump-cpranal", NoArg (setDynFlag Opt_D_dump_cpranal) )
, ( "ddump-deriv", NoArg (setDynFlag Opt_D_dump_deriv) )
@@ -357,7 +357,6 @@ dynamic_flags = [
, ( "ddump-inlinings", NoArg (setDynFlag Opt_D_dump_inlinings) )
, ( "ddump-occur-anal", NoArg (setDynFlag Opt_D_dump_occur_anal) )
, ( "ddump-parsed", NoArg (setDynFlag Opt_D_dump_parsed) )
- , ( "ddump-realC", NoArg (setDynFlag Opt_D_dump_realC) )
, ( "ddump-rn", NoArg (setDynFlag Opt_D_dump_rn) )
, ( "ddump-simpl", NoArg (setDynFlag Opt_D_dump_simpl) )
, ( "ddump-simpl-iterations", NoArg (setDynFlag Opt_D_dump_simpl_iterations) )
@@ -376,7 +375,7 @@ dynamic_flags = [
, ( "ddump-tc-trace", NoArg (setDynFlag Opt_D_dump_tc_trace) )
, ( "ddump-splices", NoArg (setDynFlag Opt_D_dump_splices) )
, ( "ddump-rn-stats", NoArg (setDynFlag Opt_D_dump_rn_stats) )
- , ( "ddump-stix", NoArg (setDynFlag Opt_D_dump_stix) )
+ , ( "ddump-opt-cmm", NoArg (setDynFlag Opt_D_dump_opt_cmm) )
, ( "ddump-simpl-stats", NoArg (setDynFlag Opt_D_dump_simpl_stats) )
, ( "ddump-bcos", NoArg (setDynFlag Opt_D_dump_BCOs) )
, ( "dsource-stats", NoArg (setDynFlag Opt_D_source_stats) )
@@ -388,6 +387,7 @@ dynamic_flags = [
, ( "ddump-vect", NoArg (setDynFlag Opt_D_dump_vect) )
, ( "dcore-lint", NoArg (setDynFlag Opt_DoCoreLinting) )
, ( "dstg-lint", NoArg (setDynFlag Opt_DoStgLinting) )
+ , ( "dcmm-lint", NoArg (setDynFlag Opt_DoCmmLinting) )
------ Machine dependant (-m<blah>) stuff ---------------------------
diff --git a/ghc/compiler/main/DriverPhases.hs b/ghc/compiler/main/DriverPhases.hs
index c094663bcb..89a610021b 100644
--- a/ghc/compiler/main/DriverPhases.hs
+++ b/ghc/compiler/main/DriverPhases.hs
@@ -1,5 +1,5 @@
-----------------------------------------------------------------------------
--- $Id: DriverPhases.hs,v 1.28 2003/10/22 14:31:09 simonmar Exp $
+-- $Id: DriverPhases.hs,v 1.29 2004/08/13 13:06:57 simonmar Exp $
--
-- GHC Driver
--
@@ -7,7 +7,7 @@
--
-----------------------------------------------------------------------------
-#include "../includes/config.h"
+#include "../includes/ghcconfig.h"
module DriverPhases (
Phase(..),
@@ -54,6 +54,8 @@ data Phase
| SplitAs
| As
| Ln
+ | CmmCpp -- pre-process Cmm source
+ | Cmm -- parse & compile Cmm code
#ifdef ILX
| Ilx2Il
| Ilasm
@@ -65,10 +67,13 @@ data Phase
-- pipeline will stop at some point (see DriverPipeline.runPipeline).
x `happensBefore` y
| x `elem` haskell_pipe = y `elem` tail (dropWhile (/= x) haskell_pipe)
+ | x `elem` cmm_pipe = y `elem` tail (dropWhile (/= x) cmm_pipe)
| x `elem` c_pipe = y `elem` tail (dropWhile (/= x) c_pipe)
| otherwise = False
-haskell_pipe = [Unlit,Cpp,HsPp,Hsc,HCc,Mangle,SplitMangle,As,SplitAs,Ln]
+haskell_post_hsc = [HCc,Mangle,SplitMangle,As,SplitAs,Ln]
+haskell_pipe = Unlit : Cpp : HsPp : Hsc : haskell_post_hsc
+cmm_pipe = CmmCpp : Cmm : haskell_post_hsc
c_pipe = [Cc,As,Ln]
-- the first compilation phase for a given file is determined
@@ -88,6 +93,8 @@ startPhase "raw_s" = Mangle
startPhase "s" = As
startPhase "S" = As
startPhase "o" = Ln
+startPhase "cmm" = CmmCpp
+startPhase "cmmcpp" = Cmm
startPhase _ = Ln -- all unknown file types
-- the output suffix for a given phase is uniquely determined by
@@ -103,13 +110,15 @@ phaseInputExt SplitMangle = "split_s" -- not really generated
phaseInputExt As = "s"
phaseInputExt SplitAs = "split_s" -- not really generated
phaseInputExt Ln = "o"
+phaseInputExt CmmCpp = "cmm"
+phaseInputExt Cmm = "cmmcpp"
#ifdef ILX
phaseInputExt Ilx2Il = "ilx"
phaseInputExt Ilasm = "il"
#endif
-haskellish_suffixes = [ "hs", "lhs", "hspp", "hscpp", "hcr", "hc", "raw_s" ]
-haskellish_src_suffixes = [ "hs", "lhs", "hspp", "hscpp", "hcr"]
+haskellish_suffixes = [ "hs", "lhs", "hspp", "hscpp", "hcr", "hc", "raw_s", "cmm" ]
+haskellish_src_suffixes = [ "hs", "lhs", "hspp", "hscpp", "hcr", "cmm" ]
cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S" ]
extcoreish_suffixes = [ "hcr" ]
haskellish_user_src_suffixes = [ "hs", "lhs" ]
diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs
index 072978a5ad..81c2f4698c 100644
--- a/ghc/compiler/main/DriverPipeline.hs
+++ b/ghc/compiler/main/DriverPipeline.hs
@@ -6,7 +6,7 @@
--
-----------------------------------------------------------------------------
-#include "../includes/config.h"
+#include "../includes/ghcconfig.h"
module DriverPipeline (
@@ -491,40 +491,8 @@ runPhase Cpp basename suff input_fn get_output_fn maybe_loc
-- to the next phase of the pipeline.
return (Just HsPp, maybe_loc, input_fn)
else do
- hscpp_opts <- getOpts opt_P
- hs_src_cpp_opts <- readIORef v_Hs_source_cpp_opts
-
- cmdline_include_paths <- readIORef v_Include_paths
-
- pkg_include_dirs <- getPackageIncludePath []
- let include_paths = foldr (\ x xs -> "-I" : x : xs) []
- (cmdline_include_paths ++ pkg_include_dirs)
-
- verb <- getVerbFlag
- (md_c_flags, _) <- machdepCCOpts
-
output_fn <- get_output_fn HsPp maybe_loc
-
- SysTools.runCpp ([SysTools.Option verb]
- ++ map SysTools.Option include_paths
- ++ map SysTools.Option hs_src_cpp_opts
- ++ map SysTools.Option hscpp_opts
- ++ map SysTools.Option md_c_flags
- ++ [ SysTools.Option "-x"
- , SysTools.Option "c"
- , SysTools.Option input_fn
- -- We hackily use Option instead of FileOption here, so that the file
- -- name is not back-slashed on Windows. cpp is capable of
- -- dealing with / in filenames, so it works fine. Furthermore
- -- if we put in backslashes, cpp outputs #line directives
- -- with *double* backslashes. And that in turn means that
- -- our error messages get double backslashes in them.
- -- In due course we should arrange that the lexer deals
- -- with these \\ escapes properly.
- , SysTools.Option "-o"
- , SysTools.FileOption "" output_fn
- ])
-
+ doCpp True{-raw-} False{-no CC opts-} input_fn output_fn
return (Just HsPp, maybe_loc, output_fn)
-------------------------------------------------------------------------------
@@ -662,6 +630,34 @@ runPhase Hsc basename suff input_fn get_output_fn _maybe_loc = do
_ -> return (Just next_phase, Just location, output_fn)
-----------------------------------------------------------------------------
+-- Cmm phase
+
+runPhase CmmCpp basename suff input_fn get_output_fn maybe_loc
+ = do
+ output_fn <- get_output_fn Cmm maybe_loc
+ doCpp False{-not raw-} True{-include CC opts-} input_fn output_fn
+ return (Just Cmm, maybe_loc, output_fn)
+
+runPhase Cmm basename suff input_fn get_output_fn maybe_loc
+ = do
+ dyn_flags <- getDynFlags
+ hsc_lang <- hscMaybeAdjustLang (hscLang dyn_flags)
+ next_phase <- hscNextPhase hsc_lang
+ output_fn <- get_output_fn next_phase maybe_loc
+
+ let dyn_flags' = dyn_flags { hscLang = hsc_lang,
+ hscOutName = output_fn,
+ hscStubCOutName = basename ++ "_stub.c",
+ hscStubHOutName = basename ++ "_stub.h",
+ extCoreName = basename ++ ".hcr" }
+
+ ok <- hscCmmFile dyn_flags' input_fn
+
+ when (not ok) $ throwDyn (PhaseFailed "cmm" (ExitFailure 1))
+
+ return (Just next_phase, maybe_loc, output_fn)
+
+-----------------------------------------------------------------------------
-- Cc phase
-- we don't support preprocessing .c files (with -E) now. Doing so introduces
@@ -1150,6 +1146,50 @@ doMkDLL o_files dep_packages = do
-- -----------------------------------------------------------------------------
-- Misc.
+doCpp :: Bool -> Bool -> FilePath -> FilePath -> IO ()
+doCpp raw include_cc_opts input_fn output_fn = do
+ hscpp_opts <- getOpts opt_P
+
+ cmdline_include_paths <- readIORef v_Include_paths
+
+ pkg_include_dirs <- getPackageIncludePath []
+ let include_paths = foldr (\ x xs -> "-I" : x : xs) []
+ (cmdline_include_paths ++ pkg_include_dirs)
+
+ verb <- getVerbFlag
+
+ cc_opts <- if not include_cc_opts
+ then return []
+ else do optc <- getOpts opt_c
+ (md_c_flags, _) <- machdepCCOpts
+ return (optc ++ md_c_flags)
+
+ let cpp_prog args | raw = SysTools.runCpp args
+ | otherwise = SysTools.runCc (SysTools.Option "-E" : args)
+
+ cpp_prog ([SysTools.Option verb]
+ ++ map SysTools.Option include_paths
+ ++ map SysTools.Option hsSourceCppOpts
+ ++ map SysTools.Option hscpp_opts
+ ++ map SysTools.Option cc_opts
+ ++ [ SysTools.Option "-x"
+ , SysTools.Option "c"
+ , SysTools.Option input_fn
+ -- We hackily use Option instead of FileOption here, so that the file
+ -- name is not back-slashed on Windows. cpp is capable of
+ -- dealing with / in filenames, so it works fine. Furthermore
+ -- if we put in backslashes, cpp outputs #line directives
+ -- with *double* backslashes. And that in turn means that
+ -- our error messages get double backslashes in them.
+ -- In due course we should arrange that the lexer deals
+ -- with these \\ escapes properly.
+ , SysTools.Option "-o"
+ , SysTools.FileOption "" output_fn
+ ])
+
+-- -----------------------------------------------------------------------------
+-- Misc.
+
hscNextPhase :: HscLang -> IO Phase
hscNextPhase hsc_lang = do
split <- readIORef v_Split_object_files
@@ -1171,8 +1211,6 @@ hscMaybeAdjustLang current_hsc_lang = do
| current_hsc_lang == HscInterpreted = current_hsc_lang
-- force -fvia-C if we are being asked for a .hc file
| todo == StopBefore HCc || keep_hc = HscC
- -- force -fvia-C when profiling or ticky-ticky is on
- | opt_SccProfilingOn || opt_DoTickyProfiling = HscC
-- otherwise, stick to the plan
| otherwise = current_hsc_lang
return hsc_lang
diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs
index 543a487655..a34d4a101a 100644
--- a/ghc/compiler/main/DriverState.hs
+++ b/ghc/compiler/main/DriverState.hs
@@ -1,5 +1,4 @@
-----------------------------------------------------------------------------
--- $Id: DriverState.hs,v 1.104 2004/04/30 15:51:10 simonmar Exp $
--
-- Settings for the driver
--
@@ -9,7 +8,7 @@
module DriverState where
-#include "../includes/config.h"
+#include "../includes/ghcconfig.h"
#include "HsVersions.h"
import ParsePkgConf ( loadPackageConfig )
@@ -71,14 +70,13 @@ isCompManagerMode _ = False
-----------------------------------------------------------------------------
-- Global compilation flags
--- Cpp-related flags
-v_Hs_source_cpp_opts = global
+-- Default CPP defines in Haskell source
+hsSourceCppOpts =
[ "-D__HASKELL1__="++cHaskell1Version
, "-D__GLASGOW_HASKELL__="++cProjectVersionInt
, "-D__HASKELL98__"
, "-D__CONCURRENT_HASKELL__"
]
-{-# NOINLINE v_Hs_source_cpp_opts #-}
-- Keep output from intermediate phases
diff --git a/ghc/compiler/main/DriverUtil.hs b/ghc/compiler/main/DriverUtil.hs
index 80ca04bf18..b8796c1244 100644
--- a/ghc/compiler/main/DriverUtil.hs
+++ b/ghc/compiler/main/DriverUtil.hs
@@ -1,5 +1,5 @@
-----------------------------------------------------------------------------
--- $Id: DriverUtil.hs,v 1.42 2004/06/24 09:35:13 simonmar Exp $
+-- $Id: DriverUtil.hs,v 1.43 2004/08/13 13:07:02 simonmar Exp $
--
-- Utils for the driver
--
@@ -19,7 +19,7 @@ module DriverUtil (
remove_spaces, escapeSpaces,
) where
-#include "../includes/config.h"
+#include "../includes/ghcconfig.h"
#include "HsVersions.h"
import Util
diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs
index f5f0b9b812..3a5364466a 100644
--- a/ghc/compiler/main/ErrUtils.lhs
+++ b/ghc/compiler/main/ErrUtils.lhs
@@ -178,9 +178,7 @@ dumpIfSet_core dflags flag hdr doc
dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn dflags flag hdr doc
| dopt flag dflags || verbosity dflags >= 4
- = if flag `elem` [Opt_D_dump_stix, Opt_D_dump_asm]
- then printForC stdout (mkDumpDoc hdr doc)
- else printDump (mkDumpDoc hdr doc)
+ = printDump (mkDumpDoc hdr doc)
| otherwise
= return ()
diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index 8187bab03d..7b1a102571 100644
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -6,7 +6,7 @@
\begin{code}
module HscMain (
- HscResult(..), hscMain, newHscEnv, hscBufferFrontEnd
+ HscResult(..), hscMain, newHscEnv, hscCmmFile, hscBufferFrontEnd
#ifdef GHCI
, hscStmt, hscTcExpr, hscKcType, hscThing,
, compileExpr
@@ -57,6 +57,7 @@ import CoreToStg ( coreToStg )
import Name ( Name, NamedThing(..) )
import SimplStg ( stg2stg )
import CodeGen ( codeGen )
+import CmmParse ( parseCmmFile )
import CodeOutput ( codeOutput )
import CmdLineOpts
@@ -449,6 +450,18 @@ hscBackEnd dflags
}
+hscCmmFile :: DynFlags -> FilePath -> IO Bool
+hscCmmFile dflags filename = do
+ maybe_cmm <- parseCmmFile dflags filename
+ case maybe_cmm of
+ Nothing -> return False
+ Just cmm -> do
+ codeOutput dflags no_mod NoStubs noDependencies [cmm]
+ return True
+ where
+ no_mod = panic "hscCmmFile: no_mod"
+
+
myParseModule dflags src_filename
= do -------------------------- Parser ----------------
showPass dflags "Parser"
diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs
index cf25bde3b8..7a2ae0c67f 100644
--- a/ghc/compiler/main/Main.hs
+++ b/ghc/compiler/main/Main.hs
@@ -1,7 +1,7 @@
{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
-----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.137 2004/08/12 13:10:40 simonmar Exp $
+-- $Id: Main.hs,v 1.138 2004/08/13 13:07:05 simonmar Exp $
--
-- GHC Driver program
--
@@ -10,7 +10,7 @@
-----------------------------------------------------------------------------
-- with path so that ghc -M can find config.h
-#include "../includes/config.h"
+#include "../includes/ghcconfig.h"
module Main (main) where
@@ -168,14 +168,10 @@ main =
-- 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.
dyn_flags <- getDynFlags
- build_tag <- readIORef v_Build_tag
let lang = case mode of
DoInteractive -> HscInterpreted
DoEval _ -> HscInterpreted
- _other | build_tag /= "" -> HscC
- | otherwise -> hscLang dyn_flags
- -- for ways other that the normal way, we must
- -- compile via C.
+ _other -> hscLang dyn_flags
setDynFlags (dyn_flags{ stgToDo = stg_todo,
hscLang = lang,
diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs
index da65fe2d02..fcd62defa7 100644
--- a/ghc/compiler/main/SysTools.lhs
+++ b/ghc/compiler/main/SysTools.lhs
@@ -84,7 +84,7 @@ import IO ( try, catch,
import Directory ( doesFileExist, removeFile )
import List ( partition )
-#include "../includes/config.h"
+#include "../includes/ghcconfig.h"
-- GHC <= 4.08 didn't have rawSystem, and runs into problems with long command
-- lines on mingw32, so we disallow it now.
View Lorry Controller Status