X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FDynFlags.hs;h=2c5d497db5a29e9dbbc070e7feb0619e69ff15a0;hb=edc4f2d21c722e58439ca68e93828e51705086dd;hp=dbb791ef63d693120d34c022c8bfc58c2122b9eb;hpb=a33ae68ab331a16fbb6e7d6931d1c38bd8f37a85;p=ghc-hetmet.git

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index dbb791e..2c5d497 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -60,8 +60,6 @@ module DynFlags (
     compilerInfo,
   ) where
 
--- XXX This define is a bit of a hack, and should be done more nicely
-#define FAST_STRING_NOT_NEEDED 1
 #include "HsVersions.h"
 
 import Module
@@ -239,6 +237,7 @@ data DynFlag
    -- optimisation opts
    | Opt_Strictness
    | Opt_FullLaziness
+   | Opt_StaticArgumentTransformation
    | Opt_CSE
    | Opt_LiberateCase
    | Opt_SpecConstr
@@ -305,6 +304,7 @@ data DynFlags = DynFlags {
   ruleCheck		:: Maybe String,
 
   specConstrThreshold   :: Maybe Int,	-- Threshold for SpecConstr
+  specConstrCount	:: Maybe Int,	-- Max number of specialisations for any one function
   liberateCaseThreshold :: Maybe Int,   -- Threshold for LiberateCase 
 
   stolen_x86_regs	:: Int,		
@@ -496,6 +496,7 @@ defaultDynFlags =
         shouldDumpSimplPhase    = const False,
 	ruleCheck		= Nothing,
 	specConstrThreshold	= Just 200,
+	specConstrCount		= Just 3,
         liberateCaseThreshold   = Just 200,
 	stolen_x86_regs		= 4,
 	cmdlineHcIncludes	= [],
@@ -708,6 +709,7 @@ optLevelFlags
 
     , ([2],	Opt_LiberateCase)
     , ([2],	Opt_SpecConstr)
+    , ([2],	Opt_StaticArgumentTransformation)
 
     , ([0,1,2], Opt_DoLambdaEtaExpansion)
 		-- This one is important for a tiresome reason:
@@ -827,6 +829,7 @@ getCoreToDo dflags
     liberate_case = dopt Opt_LiberateCase dflags
     rule_check    = ruleCheck dflags
     vectorisation = dopt Opt_Vectorise dflags
+    static_args   = dopt Opt_StaticArgumentTransformation dflags
 
     maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
 
@@ -875,6 +878,12 @@ getCoreToDo dflags
        [simpl_phase 0 ["final"] max_iter]
      else {- opt_level >= 1 -} [ 
 
+    -- We want to do the static argument transform before full laziness as it
+    -- may expose extra opportunities to float things outwards. However, to fix
+    -- up the output of the transformation we need at do at least one simplify
+    -- after this before anything else
+	    runWhen static_args CoreDoStaticArgs,
+
 	-- initial simplify: mk specialiser happy: minimum effort please
         simpl_gently,
 
@@ -1185,6 +1194,10 @@ dynamic_flags = [
                 upd (\dfs -> dfs{ specConstrThreshold = Just n })))
   ,  ( "fno-spec-constr-threshold",   NoArg (
                 upd (\dfs -> dfs{ specConstrThreshold = Nothing })))
+  ,  ( "fspec-constr-count",   	      IntSuffix (\n ->
+                upd (\dfs -> dfs{ specConstrCount = Just n })))
+  ,  ( "fno-spec-constr-count",   NoArg (
+                upd (\dfs -> dfs{ specConstrCount = Nothing })))
   ,  ( "fliberate-case-threshold",    IntSuffix (\n ->
                 upd (\dfs -> dfs{ liberateCaseThreshold = Just n })))
   ,  ( "fno-liberate-case-threshold", NoArg (
@@ -1245,6 +1258,7 @@ fFlags = [
   ( "warn-tabs",                        Opt_WarnTabs ),
   ( "print-explicit-foralls",           Opt_PrintExplicitForalls ),
   ( "strictness",                       Opt_Strictness ),
+  ( "static-argument-transformation",   Opt_StaticArgumentTransformation ),
   ( "full-laziness",                    Opt_FullLaziness ),
   ( "liberate-case",                    Opt_LiberateCase ),
   ( "spec-constr",                      Opt_SpecConstr ),
@@ -1478,26 +1492,31 @@ setDumpSimplPhases :: String -> DynP ()
 setDumpSimplPhases s = do setDynFlag Opt_ForceRecomp
                           upd (\s -> s { shouldDumpSimplPhase = spec })
   where
+    spec :: SimplifierMode -> Bool
     spec = join (||)
-         . map (join (&&))
-         . map (map match)
-         . map (split ':')
+         . map (join (&&) . map match . split ':')
          . split ','
          $ case s of
              '=' : s' -> s'
              _        -> s
 
+    join :: (Bool -> Bool -> Bool)
+	 -> [SimplifierMode -> Bool]
+	 -> SimplifierMode -> Bool
     join _  [] = const True
     join op ss = foldr1 (\f g x -> f x `op` g x) ss
 
+    match :: String -> SimplifierMode -> Bool
     match "" = const True
     match s  = case reads s of
                 [(n,"")] -> phase_num  n
                 _        -> phase_name s
 
+    phase_num :: Int -> SimplifierMode -> Bool
     phase_num n (SimplPhase k _) = n == k
     phase_num _ _                = False
 
+    phase_name :: String -> SimplifierMode -> Bool
     phase_name s SimplGently       = s == "gentle"
     phase_name s (SimplPhase _ ss) = s `elem` ss
 
@@ -1652,32 +1671,9 @@ splitPathList s = filter notNull (splitUp s)
 -- tmpDir, where we store temporary files.
 
 setTmpDir :: FilePath -> DynFlags -> DynFlags
-setTmpDir dir dflags = dflags{ tmpDir = canonicalise dir }
-  where
-#if !defined(mingw32_HOST_OS)
-     canonicalise p = normalise p
-#else
-     -- Canonicalisation of temp path under win32 is a bit more
-     -- involved: (a) strip trailing slash,
-     --      (b) normalise slashes
-     --     (c) just in case, if there is a prefix /cygdrive/x/, change to x:
-     canonicalise path = removeTrailingSlash $ normalise $ xltCygdrive path
-
-     -- if we're operating under cygwin, and TMP/TEMP is of
-     -- the form "/cygdrive/drive/path", translate this to
-     -- "drive:/path" (as GHC isn't a cygwin app and doesn't
-     -- understand /cygdrive paths.)
-     cygdrivePrefix = [pathSeparator] ++ "/cygdrive/" ++ [pathSeparator]
-     xltCygdrive path = case maybePrefixMatch cygdrivePrefix path of
-                        Just (drive:sep:xs)
-                         | isPathSeparator sep -> drive:':':pathSeparator:xs
-                        _ -> path
-
-     -- strip the trailing backslash (awful, but we only do this once).
-     removeTrailingSlash path
-      | isPathSeparator (last path) = init path
-      | otherwise                   = path
-#endif
+setTmpDir dir dflags = dflags{ tmpDir = normalise dir }
+  -- we used to fix /cygdrive/c/.. on Windows, but this doesn't
+  -- seem necessary now --SDM 7/2/2008
 
 -----------------------------------------------------------------------------
 -- Hpc stuff