X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FStaticFlags.hs;h=a2362d91e53d0fca3d55ab58448b75e8452d7336;hp=546565c966b5dcfd34c1fc5014b35d0153871f12;hb=4c6a3f787abcaed009a574196d82237d9ae64fc8;hpb=6646a0226e5380a3ff088cfc59fb761d8265994b

diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs
index 546565c..a2362d9 100644
--- a/compiler/main/StaticFlags.hs
+++ b/compiler/main/StaticFlags.hs
@@ -19,6 +19,7 @@ module StaticFlags (
 
 	-- Output style options
 	opt_PprUserLength,
+	opt_SuppressUniques,
 	opt_PprStyle_Debug,
 
 	-- profiling opts
@@ -36,11 +37,11 @@ module StaticFlags (
 	opt_IrrefutableTuples,
 	opt_Parallel,
 	opt_RuntimeTypes,
-	opt_Flatten,
 
 	-- optimisation opts
 	opt_NoMethodSharing, 
 	opt_NoStateHack,
+	opt_SpecInlineJoinPoints,
 	opt_CprOff,
 	opt_SimplNoPreInlining,
 	opt_SimplExcessPrecision,
@@ -51,7 +52,6 @@ module StaticFlags (
 	opt_UF_UseThreshold,
 	opt_UF_FunAppDiscount,
 	opt_UF_KeenessFactor,
-	opt_UF_UpdateInPlace,
 	opt_UF_DearOp,
 
 	-- Related to linking
@@ -75,7 +75,7 @@ module StaticFlags (
 
 import CmdLineParser
 import Config
-import FastString	( FastString, mkFastString )
+import FastString
 import Util
 import Maybes		( firstJust )
 import Panic
@@ -85,7 +85,7 @@ import Data.IORef
 import System.IO.Unsafe	( unsafePerformIO )
 import Control.Monad	( when )
 import Data.Char	( isDigit )
-import Data.List	( sort, intersperse, nub )
+import Data.List
 
 -----------------------------------------------------------------------------
 -- Static flags
@@ -118,8 +118,14 @@ parseStaticFlags args = do
   let cg_flags | tablesNextToCode = ["-optc-DTABLES_NEXT_TO_CODE"]
 	       | otherwise	  = []
 
+    -- HACK: -fexcess-precision is both a static and a dynamic flag.  If
+    -- the static flag parser has slurped it, we must return it as a 
+    -- leftover too.  ToDo: make -fexcess-precision dynamic only.
+  let excess_prec | opt_SimplExcessPrecision = ["-fexcess-precision"]
+                  | otherwise                = []
+
   when (not (null errs)) $ ghcError (UsageError (unlines errs))
-  return (cg_flags++more_leftover++leftover)
+  return (excess_prec++cg_flags++more_leftover++leftover)
 
 initStaticOpts :: IO ()
 initStaticOpts = writeIORef v_opt_C_ready True
@@ -145,7 +151,6 @@ static_flags = [
 
 	------- ways --------------------------------------------------------
   ,  ( "prof"		, NoArg (addWay WayProf) )
-  ,  ( "unreg"		, NoArg (addWay WayUnreg) )
   ,  ( "ticky"		, NoArg (addWay WayTicky) )
   ,  ( "parallel"	, NoArg (addWay WayPar) )
   ,  ( "gransim"	, NoArg (addWay WayGran) )
@@ -156,15 +161,11 @@ static_flags = [
  	-- ToDo: user ways
 
 	------ Debugging ----------------------------------------------------
-  ,  ( "dppr-debug",       PassFlag addOpt )
-  ,  ( "dppr-user-length", AnySuffix addOpt )
+  ,  ( "dppr-debug",        PassFlag addOpt )
+  ,  ( "dsuppress-uniques", PassFlag addOpt )
+  ,  ( "dppr-user-length",  AnySuffix addOpt )
       -- rest of the debugging flags are dynamic
 
-	--------- Haskell Program Coverage -----------------------------------
-
-  ,  ( "fhpc"           , PassFlag addOpt )
-  ,  ( "fhpc-tracer"    , PassFlag addOpt )
-
 	--------- Profiling --------------------------------------------------
   ,  ( "auto-all"	, NoArg (addOpt "-fauto-sccs-on-all-toplevs") )
   ,  ( "auto"		, NoArg (addOpt "-fauto-sccs-on-exported-toplevs") )
@@ -196,10 +197,13 @@ static_flags = [
   ,  ( "f", 			AnySuffixPred (isStaticFlag) addOpt )
   ]
 
+addOpt :: String -> IO ()
 addOpt = consIORef v_opt_C
 
+addWay :: WayName -> IO ()
 addWay = consIORef v_Ways
 
+removeOpt :: String -> IO ()
 removeOpt f = do
   fs <- readIORef v_opt_C
   writeIORef v_opt_C $! filter (/= f) fs    
@@ -213,15 +217,19 @@ lookup_str       :: String -> Maybe String
 -- being unsafely read by unpacked_static_opts below.
 GLOBAL_VAR(v_opt_C, defaultStaticOpts, [String])
 GLOBAL_VAR(v_opt_C_ready, False, Bool)
+
+staticFlags :: [String]
 staticFlags = unsafePerformIO $ do
   ready <- readIORef v_opt_C_ready
   if (not ready)
-        then panic "a static opt was looked at too early!"
+        then panic "Static flags have not been initialised!\n        Please call GHC.newSession or GHC.parseStaticFlags early enough."
         else readIORef v_opt_C
 
 -- -static is the default
+defaultStaticOpts :: [String]
 defaultStaticOpts = ["-static"]
 
+packed_static_opts :: [FastString]
 packed_static_opts   = map mkFastString staticFlags
 
 lookUp     sw = sw `elem` packed_static_opts
@@ -270,75 +278,110 @@ unpacked_opts =
    expandAts l = [l]
 -}
 
-
+opt_IgnoreDotGhci :: Bool
 opt_IgnoreDotGhci		= lookUp FSLIT("-ignore-dot-ghci")
 
 -- debugging opts
+opt_SuppressUniques :: Bool
+opt_SuppressUniques		= lookUp  FSLIT("-dsuppress-uniques")
+opt_PprStyle_Debug :: Bool
 opt_PprStyle_Debug		= lookUp  FSLIT("-dppr-debug")
+opt_PprUserLength :: Int
 opt_PprUserLength	        = lookup_def_int "-dppr-user-length" 5 --ToDo: give this a name
 
 -- profiling opts
+opt_AutoSccsOnAllToplevs :: Bool
 opt_AutoSccsOnAllToplevs	= lookUp  FSLIT("-fauto-sccs-on-all-toplevs")
+opt_AutoSccsOnExportedToplevs :: Bool
 opt_AutoSccsOnExportedToplevs	= lookUp  FSLIT("-fauto-sccs-on-exported-toplevs")
+opt_AutoSccsOnIndividualCafs :: Bool
 opt_AutoSccsOnIndividualCafs	= lookUp  FSLIT("-fauto-sccs-on-individual-cafs")
+opt_SccProfilingOn :: Bool
 opt_SccProfilingOn		= lookUp  FSLIT("-fscc-profiling")
+opt_DoTickyProfiling :: Bool
 opt_DoTickyProfiling            = WayTicky `elem` (unsafePerformIO $ readIORef v_Ways)
 
 -- Hpc opts
+opt_Hpc :: Bool
 opt_Hpc				= lookUp FSLIT("-fhpc")  
 
 -- language opts
+opt_DictsStrict :: Bool
 opt_DictsStrict			= lookUp  FSLIT("-fdicts-strict")
+opt_IrrefutableTuples :: Bool
 opt_IrrefutableTuples		= lookUp  FSLIT("-firrefutable-tuples")
+opt_Parallel :: Bool
 opt_Parallel			= lookUp  FSLIT("-fparallel")
-opt_Flatten			= lookUp  FSLIT("-fflatten")
 
 -- optimisation opts
+opt_SpecInlineJoinPoints :: Bool
+opt_SpecInlineJoinPoints	= lookUp  FSLIT("-fspec-inline-join-points")
+opt_NoStateHack :: Bool
 opt_NoStateHack			= lookUp  FSLIT("-fno-state-hack")
+opt_NoMethodSharing :: Bool
 opt_NoMethodSharing		= lookUp  FSLIT("-fno-method-sharing")
+opt_CprOff :: Bool
 opt_CprOff			= lookUp  FSLIT("-fcpr-off")
 	-- Switch off CPR analysis in the new demand analyser
+opt_MaxWorkerArgs :: Int
 opt_MaxWorkerArgs		= lookup_def_int "-fmax-worker-args" (10::Int)
 
+opt_GranMacros :: Bool
 opt_GranMacros			= lookUp  FSLIT("-fgransim")
+opt_HiVersion :: Integer
 opt_HiVersion			= read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer
+opt_HistorySize :: Int
 opt_HistorySize			= lookup_def_int "-fhistory-size" 20
+opt_OmitBlackHoling :: Bool
 opt_OmitBlackHoling		= lookUp  FSLIT("-dno-black-holing")
+opt_RuntimeTypes :: Bool
 opt_RuntimeTypes		= lookUp  FSLIT("-fruntime-types")
 
 -- Simplifier switches
+opt_SimplNoPreInlining :: Bool
 opt_SimplNoPreInlining		= lookUp  FSLIT("-fno-pre-inlining")
 	-- NoPreInlining is there just to see how bad things
 	-- get if you don't do it!
+opt_SimplExcessPrecision :: Bool
 opt_SimplExcessPrecision	= lookUp  FSLIT("-fexcess-precision")
 
 -- Unfolding control
+opt_UF_CreationThreshold :: Int
 opt_UF_CreationThreshold	= lookup_def_int "-funfolding-creation-threshold"  (45::Int)
+opt_UF_UseThreshold :: Int
 opt_UF_UseThreshold		= lookup_def_int "-funfolding-use-threshold"	   (8::Int)	-- Discounts can be big
+opt_UF_FunAppDiscount :: Int
 opt_UF_FunAppDiscount		= lookup_def_int "-funfolding-fun-discount"	   (6::Int)	-- It's great to inline a fn
+opt_UF_KeenessFactor :: Float
 opt_UF_KeenessFactor		= lookup_def_float "-funfolding-keeness-factor"	   (1.5::Float)
-opt_UF_UpdateInPlace		= lookUp  FSLIT("-funfolding-update-in-place")
 
+opt_UF_DearOp :: Int
 opt_UF_DearOp   = ( 4 :: Int)
-			
+
+opt_PIC :: Bool
 #if darwin_TARGET_OS && x86_64_TARGET_ARCH
 opt_PIC                         = True
 #else
 opt_PIC                         = lookUp FSLIT("-fPIC")
 #endif
+opt_Static :: Bool
 opt_Static			= lookUp  FSLIT("-static")
+opt_Unregisterised :: Bool
 opt_Unregisterised		= lookUp  FSLIT("-funregisterised")
 
 -- Derived, not a real option.  Determines whether we will be compiling
 -- info tables that reside just before the entry code, or with an
 -- indirection to the entry code.  See TABLES_NEXT_TO_CODE in 
 -- includes/InfoTables.h.
+tablesNextToCode :: Bool
 tablesNextToCode 		= not opt_Unregisterised
 		 		  && cGhcEnableTablesNextToCode == "YES"
 
+opt_EmitExternalCore :: Bool
 opt_EmitExternalCore		= lookUp  FSLIT("-fext-core")
 
 -- Include full span info in error messages, instead of just the start position.
+opt_ErrorSpans :: Bool
 opt_ErrorSpans			= lookUp FSLIT("-ferror-spans")
 
 
@@ -347,6 +390,7 @@ opt_ErrorSpans			= lookUp FSLIT("-ferror-spans")
 -- how to do it though --SDM.
 GLOBAL_VAR(v_Ld_inputs,	[],      [String])
 
+isStaticFlag :: String -> Bool
 isStaticFlag f =
   f `elem` [
 	"fauto-sccs-on-all-toplevs",
@@ -354,9 +398,9 @@ isStaticFlag f =
 	"fauto-sccs-on-individual-cafs",
 	"fscc-profiling",
 	"fdicts-strict",
+	"fspec-inline-join-points",
 	"firrefutable-tuples",
 	"fparallel",
-	"fflatten",
 	"fgransim",
 	"fno-hi-version-check",
 	"dno-black-holing",
@@ -365,15 +409,16 @@ isStaticFlag f =
 	"fruntime-types",
 	"fno-pre-inlining",
 	"fexcess-precision",
-	"funfolding-update-in-place",
 	"static",
+	"fhardwire-lib-paths",
 	"funregisterised",
 	"fext-core",
 	"fcpr-off",
 	"ferror-spans",
-	"fPIC"
+	"fPIC",
+	"fhpc"
 	]
-  || any (flip prefixMatch f) [
+  || any (`isPrefixOf` f) [
 	"fliberate-case-threshold",
 	"fmax-worker-args",
 	"fhistory-size",
@@ -407,7 +452,7 @@ decodeSize str
   | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000)
   | otherwise            = throwDyn (CmdLineError ("can't decode size: " ++ str))
   where (m, c) = span pred str
-        n      = read m  :: Double
+        n      = readRational m
 	pred c = isDigit c || c == '.'
 
 
@@ -443,7 +488,6 @@ data WayName
   = WayThreaded
   | WayDebug
   | WayProf
-  | WayUnreg
   | WayTicky
   | WayPar
   | WayGran
@@ -469,6 +513,7 @@ data WayName
 
 GLOBAL_VAR(v_Ways, [] ,[WayName])
 
+allowed_combination :: [WayName] -> Bool
 allowed_combination way = and [ x `allowedWith` y 
 			      | x <- way, y <- way, x < y ]
   where
@@ -480,8 +525,8 @@ allowed_combination way = and [ x `allowedWith` y
 	_ `allowedWith` WayDebug		= True
 	WayDebug `allowedWith` _		= True
 
-	WayProf `allowedWith` WayUnreg		= True
 	WayProf `allowedWith` WayNDP		= True
+	WayThreaded `allowedWith` WayProf	= True
 	_ `allowedWith` _ 			= False
 
 
@@ -509,11 +554,13 @@ findBuildTag = do
 mkBuildTag :: [Way] -> String
 mkBuildTag ways = concat (intersperse "_" (map wayTag ways))
 
+lkupWay :: WayName -> Way
 lkupWay w = 
    case lookup w way_details of
 	Nothing -> error "findBuildTag"
 	Just details -> details
 
+isRTSWay :: WayName -> Bool
 isRTSWay = wayRTSOnly . lkupWay 
 
 data Way = Way {
@@ -550,9 +597,6 @@ way_details =
 	[ "-DTICKY_TICKY"
 	, "-optc-DTICKY_TICKY" ]),
 
-    (WayUnreg, Way  "u" False "Unregisterised" 
-	unregFlags ),
-
     -- optl's below to tell linker where to find the PVM library -- HWL
     (WayPar, Way  "mp" False "Parallel" 
 	[ "-fparallel"
@@ -596,7 +640,7 @@ way_details =
 
     (WayNDP, Way  "ndp" False "Nested data parallelism"
 	[ "-fparr"
-	, "-fflatten"]),
+	, "-fvectorise"]),
 
     (WayUser_a,  Way  "a"  False "User way 'a'"  ["$WAY_a_REAL_OPTS"]),	
     (WayUser_b,  Way  "b"  False "User way 'b'"  ["$WAY_b_REAL_OPTS"]),	
@@ -617,6 +661,7 @@ way_details =
     (WayUser_B,  Way  "B"  False "User way 'B'"  ["$WAY_B_REAL_OPTS"]) 
   ]
 
+unregFlags :: [String]
 unregFlags = 
    [ "-optc-DNO_REGS"
    , "-optc-DUSE_MINIINTERPRETER"