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
-- optimisation opts
| Opt_Strictness
| Opt_FullLaziness
+ | Opt_StaticArgumentTransformation
| Opt_CSE
| Opt_LiberateCase
| Opt_SpecConstr
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,
shouldDumpSimplPhase = const False,
ruleCheck = Nothing,
specConstrThreshold = Just 200,
+ specConstrCount = Just 3,
liberateCaseThreshold = Just 200,
stolen_x86_regs = 4,
cmdlineHcIncludes = [],
, ([2], Opt_LiberateCase)
, ([2], Opt_SpecConstr)
+ , ([2], Opt_StaticArgumentTransformation)
, ([0,1,2], Opt_DoLambdaEtaExpansion)
-- This one is important for a tiresome reason:
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)
[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,
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 (
( "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 ),
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
-- 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