\begin{code}
data StrictnessMark
= MarkedUserStrict -- "!" in a source decl
+ | MarkedUserUnboxed -- "!!" in a source decl
| MarkedStrict -- "!" in an interface decl: strict but not unboxed
| MarkedUnboxed -- "!!" in an interface decl: unboxed
| NotMarkedStrict -- No annotation at all
import BasicTypes ( Arity, StrictnessMark(..) )
import Outputable
import Unique ( Unique, Uniquable(..) )
-import CmdLineOpts ( opt_UnboxStrictFields )
import Maybes ( orElse )
import ListSetOps ( assoc )
import Util ( zipEqual, zipWithEqual, notNull )
-- Transforms any MarkedUserStricts into MarkUnboxed or MarkedStrict
chooseBoxingStrategy tycon arg_ty strict
= case strict of
- MarkedUserStrict
- | opt_UnboxStrictFields
- && unbox arg_ty -> MarkedUnboxed
+ MarkedUserStrict -> MarkedStrict
+ MarkedUserUnboxed
+ | can_unbox -> MarkedUnboxed
| otherwise -> MarkedStrict
other -> strict
where
+ can_unbox = unbox arg_ty
-- beware: repType will go into a loop if we try this on a recursive
-- type (for reasons unknown...), hence the check for recursion below.
unbox ty =
import DsMonad -- the monadery used in the desugarer
import DsUtils
-import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_RulesOff )
+import CmdLineOpts ( DynFlag(..), dopt, opt_RulesOff )
import CoreUtils ( exprType, mkIfThenElse )
import Id ( idType )
import Var ( Id )
-> DsM CoreExpr
dsListComp quals elt_ty
- | opt_RulesOff || opt_IgnoreIfacePragmas -- Either rules are switched off, or
- -- we are ignoring what there are;
- -- Either way foldr/build won't happen, so
- -- use the more efficient Wadler-style desugaring
- || isParallelComp quals -- Foldr-style desugaring can't handle
- -- parallel list comprehensions
- = deListComp quals (mkNilExpr elt_ty)
-
- | otherwise -- Foldr/build should be enabled, so desugar
- -- into foldrs and builds
- = newTyVarsDs [alphaTyVar] `thenDs` \ [n_tyvar] ->
+ = getDOptsDs `thenDs` \dflags ->
+ if opt_RulesOff || dopt Opt_IgnoreInterfacePragmas dflags
+ -- Either rules are switched off, or we are ignoring what there are;
+ -- Either way foldr/build won't happen, so use the more efficient
+ -- Wadler-style desugaring
+ || isParallelComp quals
+ -- Foldr-style desugaring can't handle
+ -- parallel list comprehensions
+ then deListComp quals (mkNilExpr elt_ty)
+
+ else -- Foldr/build should be enabled, so desugar
+ -- into foldrs and builds
+ newTyVarsDs [alphaTyVar] `thenDs` \ [n_tyvar] ->
let
n_ty = mkTyVarTy n_tyvar
c_ty = mkFunTys [elt_ty, n_ty] n_ty
dsReify r@(ReifyOut ReifyDecl name)
= do { thing <- dsLookupGlobal name ;
- mb_d <- repTyClD (ifaceTyThing thing) ;
+ mb_d <- repTyClD (ifaceTyThing True{-omit pragmas-} thing) ;
case mb_d of
Just (MkC d) -> return d
Nothing -> pprPanic "dsReify" (ppr r)
{-# OPTIONS -#include "Linker.h" #-}
-----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.159 2003/09/04 11:08:46 simonmar Exp $
+-- $Id: InteractiveUI.hs,v 1.160 2003/09/23 14:32:58 simonmar Exp $
--
-- GHC Interactive User Interface
--
showThing (ty_thing, fixity)
= vcat [ text "-- " <> showTyThing ty_thing,
showFixity fixity (getName ty_thing),
- ppr (ifaceTyThing ty_thing) ]
+ ppr (ifaceTyThing True{-omit prags-} ty_thing) ]
showFixity fix name
| fix == defaultFixity = empty
thing_names = map getName things
- thingDecl thing@(AnId id) = ifaceTyThing thing
+ thingDecl thing@(AnId id) = ifaceTyThing True{-omit prags-} thing
thingDecl thing@(AClass c) =
- let rn_decl = ifaceTyThing thing in
+ let rn_decl = ifaceTyThing True{-omit prags-} thing in
case rn_decl of
ClassDecl { tcdSigs = cons } ->
rn_decl{ tcdSigs = filter methodIsVisible cons }
methodIsVisible (ClassOpSig n _ _ _) = n `elem` thing_names
thingDecl thing@(ATyCon t) =
- let rn_decl = ifaceTyThing thing in
+ let rn_decl = ifaceTyThing True{-omit prags-} thing in
case rn_decl of
TyData { tcdCons = DataCons cons } ->
rn_decl{ tcdCons = DataCons (filter conIsVisible cons) }
vcat (map (ppr . thingDecl) things')))
)
- where
-
-----------------------------------------------------------------------------
-- Setting the module context
cms <- getCmState
let
unqual = cmGetPrintUnqual cms
- showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
+ showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing True{-omit prags-} b)))
io (mapM_ showBinding (cmGetBindings cms))
return ()
import OccName ( OccName )
import RnHsSyn
import DriverState ( v_Build_tag )
-import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_HiVersion )
+import CmdLineOpts ( opt_HiVersion )
import Panic
import SrcLoc
import Binary
name <- get bh
ty <- lazyGet bh
idinfo <- lazyGet bh
- let idinfo' | opt_IgnoreIfacePragmas = []
- | otherwise = idinfo
- return (IfaceSig name ty idinfo' noSrcLoc)
+ return (IfaceSig name ty idinfo noSrcLoc)
1 -> error "Binary.get(TyClDecl): ForeignType"
2 -> do
n_or_d <- get bh
\begin{code}
module CmdLineOpts (
- CoreToDo(..), StgToDo(..),
+ CoreToDo(..), buildCoreToDo, StgToDo(..),
SimplifierSwitch(..),
SimplifierMode(..), FloatOutSwitches(..),
getOpts, -- (DynFlags -> [a]) -> IO [a]
setLang,
getVerbFlag,
+ setOptLevel,
-- Manipulating the DynFlags state
getDynFlags, -- IO DynFlags
opt_NoMethodSharing,
opt_DoSemiTagging,
opt_LiberateCaseThreshold,
- opt_StgDoLetNoEscapes,
opt_CprOff,
opt_RulesOff,
- opt_UnboxStrictFields,
opt_SimplNoPreInlining,
- opt_SimplDoEtaReduction,
- opt_SimplDoLambdaEtaExpansion,
- opt_SimplCaseMerge,
opt_SimplExcessPrecision,
opt_MaxWorkerArgs,
opt_GranMacros,
opt_HiVersion,
opt_HistorySize,
- opt_IgnoreAsserts,
- opt_IgnoreIfacePragmas,
opt_NoHiCheck,
opt_OmitBlackHoling,
- opt_OmitInterfacePragmas,
opt_NoPruneDecls,
opt_Static,
opt_Unregisterised,
| Opt_Generics
| Opt_NoImplicitPrelude
+ -- optimisation opts
+ | Opt_Strictness
+ | Opt_CSE
+ | Opt_IgnoreInterfacePragmas
+ | Opt_OmitInterfacePragmas
+ | Opt_DoLambdaEtaExpansion
+ | Opt_IgnoreAsserts
+ | Opt_DoEtaReduction
+ | Opt_CaseMerge
+ | Opt_UnboxStrictFields
+
deriving (Eq)
data DynFlags = DynFlags {
- coreToDo :: [CoreToDo],
+ coreToDo :: Maybe [CoreToDo], -- reserved for use with -Ofile
stgToDo :: [StgToDo],
hscLang :: HscLang,
hscOutName :: String, -- name of the output file
hscStubCOutName :: String, -- name of the .stub_c output file
extCoreName :: String, -- name of the .core output file
verbosity :: Int, -- verbosity level
+ optLevel :: Int, -- optimisation level
+ maxSimplIterations :: Int, -- max simplifier iterations
+ ruleCheck :: Maybe String,
cppFlag :: Bool, -- preprocess with cpp?
ppFlag :: Bool, -- preprocess with a Haskell Pp?
stolen_x86_regs :: Int,
| otherwise = HscC
defaultDynFlags = DynFlags {
- coreToDo = [], stgToDo = [],
+ coreToDo = Nothing, stgToDo = [],
hscLang = defaultHscLang,
hscOutName = "",
hscStubHOutName = "", hscStubCOutName = "",
extCoreName = "",
- verbosity = 0,
+ verbosity = 0,
+ optLevel = 0,
+ maxSimplIterations = 4,
+ ruleCheck = Nothing,
cppFlag = False,
ppFlag = False,
stolen_x86_regs = 4,
opt_I = [],
opt_i = [],
#endif
- flags = [Opt_Generics] ++ standardWarnings,
- -- Generating the helper-functions for
- -- generics is now on by default
+ flags = [
+ Opt_Generics,
+ -- Generating the helper-functions for
+ -- generics is now on by default
+ Opt_Strictness,
+ -- strictness is on by default, but this only
+ -- applies to -O.
+ Opt_CSE,
+ -- similarly for CSE.
+ Opt_DoLambdaEtaExpansion
+ -- This one is important for a tiresome reason:
+ -- we want to make sure that the bindings for data
+ -- constructors are eta-expanded. This is probably
+ -- a good thing anyway, but it seems fragile.
+ ] ++ standardWarnings,
}
{-
dopt :: DynFlag -> DynFlags -> Bool
dopt f dflags = f `elem` (flags dflags)
-dopt_CoreToDo :: DynFlags -> [CoreToDo]
+dopt_CoreToDo :: DynFlags -> Maybe [CoreToDo]
dopt_CoreToDo = coreToDo
dopt_StgToDo :: DynFlags -> [StgToDo]
getVerbFlag = do
verb <- dynFlag verbosity
if verb >= 3 then return "-v" else return ""
-\end{code}
-----------------------------------------------------------------------------
+-- Setting the optimisation level
+
+setOptLevel :: Int -> IO ()
+setOptLevel n
+ = do dflags <- getDynFlags
+ if hscLang dflags == HscInterpreted && n > 0
+ then putStr "warning: -O conflicts with --interactive; -O ignored.\n"
+ else updDynFlags (setOptLevel' n)
+
+setOptLevel' n dfs
+ = if (n >= 1)
+ then dfs2{ hscLang = HscC, optLevel = n } -- turn on -fvia-C with -O
+ else dfs2{ optLevel = n }
+ where
+ dfs1 = foldr (flip dopt_unset) dfs remove_dopts
+ dfs2 = foldr (flip dopt_set) dfs1 extra_dopts
+
+ extra_dopts
+ | n == 0 = opt_0_dopts
+ | otherwise = opt_1_dopts
+
+ remove_dopts
+ | n == 0 = opt_1_dopts
+ | otherwise = opt_0_dopts
+
+opt_0_dopts = [
+ Opt_IgnoreInterfacePragmas,
+ Opt_OmitInterfacePragmas
+ ]
+
+opt_1_dopts = [
+ Opt_IgnoreAsserts,
+ Opt_DoEtaReduction,
+ Opt_CaseMerge
+ ]
+
+-- Core-to-core phases:
+
+buildCoreToDo :: DynFlags -> [CoreToDo]
+buildCoreToDo dflags = core_todo
+ where
+ opt_level = optLevel dflags
+ max_iter = maxSimplIterations dflags
+ strictness = dopt Opt_Strictness dflags
+ cse = dopt Opt_CSE dflags
+ rule_check = ruleCheck dflags
+
+ core_todo =
+ if opt_level == 0 then
+ [
+ CoreDoSimplify (SimplPhase 0) [
+ MaxSimplifierIterations max_iter
+ ]
+ ]
+
+ else {- opt_level >= 1 -} [
+
+ -- initial simplify: mk specialiser happy: minimum effort please
+ CoreDoSimplify SimplGently [
+ -- Simplify "gently"
+ -- Don't inline anything till full laziness has bitten
+ -- In particular, inlining wrappers inhibits floating
+ -- e.g. ...(case f x of ...)...
+ -- ==> ...(case (case x of I# x# -> fw x#) of ...)...
+ -- ==> ...(case x of I# x# -> case fw x# of ...)...
+ -- and now the redex (f x) isn't floatable any more
+ -- Similarly, don't apply any rules until after full
+ -- laziness. Notably, list fusion can prevent floating.
+
+ NoCaseOfCase,
+ -- Don't do case-of-case transformations.
+ -- This makes full laziness work better
+ MaxSimplifierIterations max_iter
+ ],
+
+ -- Specialisation is best done before full laziness
+ -- so that overloaded functions have all their dictionary lambdas manifest
+ CoreDoSpecialising,
+
+ CoreDoFloatOutwards (FloatOutSw False False),
+ CoreDoFloatInwards,
+
+ CoreDoSimplify (SimplPhase 2) [
+ -- Want to run with inline phase 2 after the specialiser to give
+ -- maximum chance for fusion to work before we inline build/augment
+ -- in phase 1. This made a difference in 'ansi' where an
+ -- overloaded function wasn't inlined till too late.
+ MaxSimplifierIterations max_iter
+ ],
+ case rule_check of { Just pat -> CoreDoRuleCheck 2 pat; Nothing -> CoreDoNothing },
+
+ CoreDoSimplify (SimplPhase 1) [
+ -- Need inline-phase2 here so that build/augment get
+ -- inlined. I found that spectral/hartel/genfft lost some useful
+ -- strictness in the function sumcode' if augment is not inlined
+ -- before strictness analysis runs
+ MaxSimplifierIterations max_iter
+ ],
+ case rule_check of { Just pat -> CoreDoRuleCheck 1 pat; Nothing -> CoreDoNothing },
+
+ CoreDoSimplify (SimplPhase 0) [
+ -- Phase 0: allow all Ids to be inlined now
+ -- This gets foldr inlined before strictness analysis
+
+ MaxSimplifierIterations 3
+ -- At least 3 iterations because otherwise we land up with
+ -- huge dead expressions because of an infelicity in the
+ -- simpifier.
+ -- let k = BIG in foldr k z xs
+ -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs
+ -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs
+ -- Don't stop now!
+
+ ],
+ case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing },
+
+#ifdef OLD_STRICTNESS
+ CoreDoOldStrictness
+#endif
+ if strictness then CoreDoStrictness else CoreDoNothing,
+ CoreDoWorkerWrapper,
+ CoreDoGlomBinds,
+
+ CoreDoSimplify (SimplPhase 0) [
+ MaxSimplifierIterations max_iter
+ ],
+
+ CoreDoFloatOutwards (FloatOutSw False -- Not lambdas
+ True), -- Float constants
+ -- nofib/spectral/hartel/wang doubles in speed if you
+ -- do full laziness late in the day. It only happens
+ -- after fusion and other stuff, so the early pass doesn't
+ -- catch it. For the record, the redex is
+ -- f_el22 (f_el21 r_midblock)
+
+
+ -- We want CSE to follow the final full-laziness pass, because it may
+ -- succeed in commoning up things floated out by full laziness.
+ -- CSE used to rely on the no-shadowing invariant, but it doesn't any more
+
+ if cse then CoreCSE else CoreDoNothing,
+
+ CoreDoFloatInwards,
+
+-- Case-liberation for -O2. This should be after
+-- strictness analysis and the simplification which follows it.
+
+ case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing },
+
+ if opt_level >= 2 then
+ CoreLiberateCase
+ else
+ CoreDoNothing,
+ if opt_level >= 2 then
+ CoreDoSpecConstr
+ else
+ CoreDoNothing,
+
+ -- Final clean-up simplification:
+ CoreDoSimplify (SimplPhase 0) [
+ MaxSimplifierIterations max_iter
+ ]
+ ]
+
+-- --------------------------------------------------------------------------
-- Mess about with the mutable variables holding the dynamic arguments
-- v_InitDynFlags
-- to the value of v_InitDynFlags before each compilation, then
-- updated by reading any OPTIONS pragma in the current module.
-\begin{code}
GLOBAL_VAR(v_InitDynFlags, defaultDynFlags, DynFlags)
GLOBAL_VAR(v_DynFlags, defaultDynFlags, DynFlags)
opt_RulesOff = lookUp FSLIT("-frules-off")
-- Switch off CPR analysis in the new demand analyser
opt_LiberateCaseThreshold = lookup_def_int "-fliberate-case-threshold" (10::Int)
-opt_StgDoLetNoEscapes = lookUp FSLIT("-flet-no-escape")
-opt_UnboxStrictFields = lookUp FSLIT("-funbox-strict-fields")
opt_MaxWorkerArgs = lookup_def_int "-fmax-worker-args" (10::Int)
{-
opt_GranMacros = lookUp FSLIT("-fgransim")
opt_HiVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Int
opt_HistorySize = lookup_def_int "-fhistory-size" 20
-opt_IgnoreAsserts = lookUp FSLIT("-fignore-asserts")
-opt_IgnoreIfacePragmas = lookUp FSLIT("-fignore-interface-pragmas")
opt_NoHiCheck = lookUp FSLIT("-fno-hi-version-check")
opt_OmitBlackHoling = lookUp FSLIT("-dno-black-holing")
-opt_OmitInterfacePragmas = lookUp FSLIT("-fomit-interface-pragmas")
opt_RuntimeTypes = lookUp FSLIT("-fruntime-types")
-- Simplifier switches
opt_SimplNoPreInlining = lookUp FSLIT("-fno-pre-inlining")
-- NoPreInlining is there just to see how bad things
-- get if you don't do it!
-opt_SimplDoEtaReduction = lookUp FSLIT("-fdo-eta-reduction")
-opt_SimplDoLambdaEtaExpansion = lookUp FSLIT("-fdo-lambda-eta-expansion")
-opt_SimplCaseMerge = lookUp FSLIT("-fcase-merge")
opt_SimplExcessPrecision = lookUp FSLIT("-fexcess-precision")
-- Unfolding control
"fflatten",
"fsemi-tagging",
"flet-no-escape",
- "funbox-strict-fields",
"femit-extern-decls",
"fglobalise-toplev-names",
"fgransim",
- "fignore-asserts",
- "fignore-interface-pragmas",
"fno-hi-version-check",
"dno-black-holing",
"fno-method-sharing",
- "fomit-interface-pragmas",
"fruntime-types",
"fno-pre-inlining",
- "fdo-eta-reduction",
- "fdo-lambda-eta-expansion",
- "fcase-merge",
"fexcess-precision",
"funfolding-update-in-place",
"fno-prune-decls",
-----------------------------------------------------------------------------
--- $Id: DriverFlags.hs,v 1.124 2003/09/10 16:44:05 simonmar Exp $
+-- $Id: DriverFlags.hs,v 1.125 2003/09/23 14:32:59 simonmar Exp $
--
-- Driver flags
--
, ( "Rghc-timing" , NoArg (enableTimingStats) )
------ Compiler flags -----------------------------------------------
- , ( "O2-for-C" , NoArg (writeIORef v_minus_o2_for_C True) )
- , ( "O" , NoArg (setOptLevel 1))
- , ( "Onot" , NoArg (setOptLevel 0))
- , ( "O" , PrefixPred (all isDigit) (setOptLevel . read))
-
, ( "fno-asm-mangling" , NoArg (writeIORef v_Do_asm_mangling False) )
- , ( "fmax-simplifier-iterations",
- PrefixPred (all isDigit) (writeIORef v_MaxSimplifierIterations . read) )
-
- , ( "frule-check",
- SepArg (\s -> writeIORef v_RuleCheck (Just s)) )
-
, ( "fexcess-precision" , NoArg (do writeIORef v_Excess_precision True
add v_Opt_C "-fexcess-precision"))
- -- Optimisation flags are treated specially, so the normal
- -- -fno-* pattern below doesn't work. We therefore allow
- -- certain optimisation passes to be turned off explicitly:
- , ( "fno-strictness" , NoArg (writeIORef v_Strictness False) )
- , ( "fno-cse" , NoArg (writeIORef v_CSE False) )
-
-- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
, ( "fno-", PrefixPred (\s -> isStaticHscFlag ("f"++s))
(\s -> add v_Anti_opt_C ("-f"++s)) )
, ( "Wnot" , NoArg (mapM_ unSetDynFlag minusWallOpts) ) /* DEPREC */
, ( "w" , NoArg (mapM_ unSetDynFlag minusWallOpts) )
+ ------ Optimisation flags ------------------------------------------
+ , ( "O" , NoArg (setOptLevel 1))
+ , ( "Onot" , NoArg (setOptLevel 0))
+ , ( "O" , PrefixPred (all isDigit) (setOptLevel . read))
+
+ , ( "fmax-simplifier-iterations",
+ PrefixPred (all isDigit)
+ (\n -> updDynFlags (\dfs ->
+ dfs{ maxSimplIterations = read n })) )
+
+ , ( "frule-check",
+ SepArg (\s -> updDynFlags (\dfs -> dfs{ ruleCheck = Just s })))
+
------ Compiler flags -----------------------------------------------
, ( "fasm", AnySuffix (\_ -> setLang HscAsm) )
( "allow-overlapping-instances", Opt_AllowOverlappingInstances ),
( "allow-undecidable-instances", Opt_AllowUndecidableInstances ),
( "allow-incoherent-instances", Opt_AllowIncoherentInstances ),
- ( "generics", Opt_Generics )
+ ( "generics", Opt_Generics ),
+ ( "strictness", Opt_Strictness ),
+ ( "cse", Opt_CSE ),
+ ( "ignore-interface-pragmas", Opt_IgnoreInterfacePragmas ),
+ ( "omit-interface-pragmas", Opt_OmitInterfacePragmas ),
+ ( "do-lambda-eta-expansion", Opt_DoLambdaEtaExpansion ),
+ ( "ignore-asserts", Opt_IgnoreAsserts ),
+ ( "do-eta-reduction", Opt_DoEtaReduction ),
+ ( "case-merge", Opt_CaseMerge ),
+ ( "unbox-strict-fields", Opt_UnboxStrictFields )
]
glasgowExtsFlags = [ Opt_GlasgowExts, Opt_FFI, Opt_TH, Opt_ImplicitParams ]
opt_C_ <- getStaticOpts v_Opt_C -- misc hsc opts from the command line
- -- optimisation
- minus_o <- readIORef v_OptLevel
- let optimisation_opts =
- case minus_o of
- 0 -> hsc_minusNoO_flags
- 1 -> hsc_minusO_flags
- 2 -> hsc_minusO2_flags
- n -> throwDyn (CmdLineError ("unknown optimisation level: "
- ++ show n))
- -- ToDo: -Ofile
-
-- take into account -fno-* flags by removing the equivalent -f*
-- flag from our list.
anti_flags <- getStaticOpts v_Anti_opt_C
- let basic_opts = opt_C_ ++ optimisation_opts
+ let basic_opts = opt_C_
filtered_opts = filter (`notElem` anti_flags) basic_opts
static <- (do s <- readIORef v_Static; if s then return "-static"
verb <- getVerbFlag
- o2 <- readIORef v_minus_o2_for_C
- let opt_flag | o2 = "-O2"
- | otherwise = "-O"
-
pkg_extra_cc_opts <- getPackageExtraCcOpts pkgs
split_objs <- readIORef v_Split_object_files
++ (if cc_phase == HCc && mangle
then md_regd_c_flags
else [])
- ++ [ verb, "-S", "-Wimplicit", opt_flag ]
+ ++ [ verb, "-S", "-Wimplicit", "-O" ]
++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
++ cc_opts
++ split_opt
-----------------------------------------------------------------------------
--- $Id: DriverState.hs,v 1.96 2003/09/04 11:08:47 simonmar Exp $
+-- $Id: DriverState.hs,v 1.97 2003/09/23 14:33:00 simonmar Exp $
--
-- Settings for the driver
--
osuf <- readIORef v_Object_suf
return (replaceFilenameSuffix f osuf)
------------------------------------------------------------------------------
--- Compiler optimisation options
-
-GLOBAL_VAR(v_OptLevel, 0, Int)
-
-setOptLevel :: Int -> IO ()
-setOptLevel n = do
- when (n >= 1) $ setLang HscC -- turn on -fvia-C with -O
- writeIORef v_OptLevel n
-
-GLOBAL_VAR(v_minus_o2_for_C, False, Bool)
-GLOBAL_VAR(v_MaxSimplifierIterations, 4, Int)
GLOBAL_VAR(v_StgStats, False, Bool)
-GLOBAL_VAR(v_Strictness, True, Bool)
-GLOBAL_VAR(v_CSE, True, Bool)
-GLOBAL_VAR(v_RuleCheck, Nothing, Maybe String)
-
--- these are the static flags you get without -O.
-hsc_minusNoO_flags =
- [
- "-fignore-interface-pragmas",
- "-fomit-interface-pragmas",
- "-fdo-lambda-eta-expansion", -- This one is important for a tiresome reason:
- -- we want to make sure that the bindings for data
- -- constructors are eta-expanded. This is probably
- -- a good thing anyway, but it seems fragile.
- "-flet-no-escape"
- ]
-
--- these are the static flags you get when -O is on.
-hsc_minusO_flags =
- [
- "-fignore-asserts",
- "-fdo-eta-reduction",
- "-fdo-lambda-eta-expansion",
- "-fcase-merge",
- "-flet-to-case",
- "-flet-no-escape"
- ]
-
-hsc_minusO2_flags = hsc_minusO_flags -- for now
-
-getStaticOptimisationFlags 0 = hsc_minusNoO_flags
-getStaticOptimisationFlags 1 = hsc_minusO_flags
-getStaticOptimisationFlags n = hsc_minusO2_flags
-
-buildCoreToDo :: IO [CoreToDo]
-buildCoreToDo = do
- opt_level <- readIORef v_OptLevel
- max_iter <- readIORef v_MaxSimplifierIterations
- strictness <- readIORef v_Strictness
- cse <- readIORef v_CSE
- rule_check <- readIORef v_RuleCheck
-
- if opt_level == 0 then return
- [
- CoreDoSimplify (SimplPhase 0) [
- MaxSimplifierIterations max_iter
- ]
- ]
-
- else {- opt_level >= 1 -} return [
-
- -- initial simplify: mk specialiser happy: minimum effort please
- CoreDoSimplify SimplGently [
- -- Simplify "gently"
- -- Don't inline anything till full laziness has bitten
- -- In particular, inlining wrappers inhibits floating
- -- e.g. ...(case f x of ...)...
- -- ==> ...(case (case x of I# x# -> fw x#) of ...)...
- -- ==> ...(case x of I# x# -> case fw x# of ...)...
- -- and now the redex (f x) isn't floatable any more
- -- Similarly, don't apply any rules until after full
- -- laziness. Notably, list fusion can prevent floating.
-
- NoCaseOfCase,
- -- Don't do case-of-case transformations.
- -- This makes full laziness work better
- MaxSimplifierIterations max_iter
- ],
-
- -- Specialisation is best done before full laziness
- -- so that overloaded functions have all their dictionary lambdas manifest
- CoreDoSpecialising,
-
- CoreDoFloatOutwards (FloatOutSw False False),
- CoreDoFloatInwards,
-
- CoreDoSimplify (SimplPhase 2) [
- -- Want to run with inline phase 2 after the specialiser to give
- -- maximum chance for fusion to work before we inline build/augment
- -- in phase 1. This made a difference in 'ansi' where an
- -- overloaded function wasn't inlined till too late.
- MaxSimplifierIterations max_iter
- ],
- case rule_check of { Just pat -> CoreDoRuleCheck 2 pat; Nothing -> CoreDoNothing },
-
- CoreDoSimplify (SimplPhase 1) [
- -- Need inline-phase2 here so that build/augment get
- -- inlined. I found that spectral/hartel/genfft lost some useful
- -- strictness in the function sumcode' if augment is not inlined
- -- before strictness analysis runs
- MaxSimplifierIterations max_iter
- ],
- case rule_check of { Just pat -> CoreDoRuleCheck 1 pat; Nothing -> CoreDoNothing },
-
- CoreDoSimplify (SimplPhase 0) [
- -- Phase 0: allow all Ids to be inlined now
- -- This gets foldr inlined before strictness analysis
-
- MaxSimplifierIterations 3
- -- At least 3 iterations because otherwise we land up with
- -- huge dead expressions because of an infelicity in the
- -- simpifier.
- -- let k = BIG in foldr k z xs
- -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs
- -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs
- -- Don't stop now!
-
- ],
- case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing },
-
-#ifdef OLD_STRICTNESS
- CoreDoOldStrictness
-#endif
- if strictness then CoreDoStrictness else CoreDoNothing,
- CoreDoWorkerWrapper,
- CoreDoGlomBinds,
-
- CoreDoSimplify (SimplPhase 0) [
- MaxSimplifierIterations max_iter
- ],
-
- CoreDoFloatOutwards (FloatOutSw False -- Not lambdas
- True), -- Float constants
- -- nofib/spectral/hartel/wang doubles in speed if you
- -- do full laziness late in the day. It only happens
- -- after fusion and other stuff, so the early pass doesn't
- -- catch it. For the record, the redex is
- -- f_el22 (f_el21 r_midblock)
-
-
- -- We want CSE to follow the final full-laziness pass, because it may
- -- succeed in commoning up things floated out by full laziness.
- -- CSE used to rely on the no-shadowing invariant, but it doesn't any more
-
- if cse then CoreCSE else CoreDoNothing,
-
- CoreDoFloatInwards,
-
--- Case-liberation for -O2. This should be after
--- strictness analysis and the simplification which follows it.
-
- case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing },
-
- if opt_level >= 2 then
- CoreLiberateCase
- else
- CoreDoNothing,
- if opt_level >= 2 then
- CoreDoSpecConstr
- else
- CoreDoNothing,
-
- -- Final clean-up simplification:
- CoreDoSimplify (SimplPhase 0) [
- MaxSimplifierIterations max_iter
- ]
- ]
buildStgToDo :: IO [ StgToDo ]
buildStgToDo = do
{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
-----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.132 2003/09/04 11:08:47 simonmar Exp $
+-- $Id: Main.hs,v 1.133 2003/09/23 14:33:00 simonmar Exp $
--
-- GHC Driver program
--
haskell98Package
)
import DriverPipeline ( staticLink, doMkDLL, runPipeline )
-import DriverState ( buildCoreToDo, buildStgToDo,
+import DriverState ( buildStgToDo,
findBuildTag,
getPackageExtraGhcOpts, unregFlags,
v_GhcMode, v_GhcModeFlag, GhcMode(..),
v_Keep_tmp_files, v_Ld_inputs, v_Ways,
- v_OptLevel, v_Output_file, v_Output_hi,
+ v_Output_file, v_Output_hi,
readPackageConf, verifyOutputFiles, v_NoLink,
v_Build_tag
)
-- -O and --interactive are not a good combination
-- ditto with any kind of way selection
- orig_opt_level <- readIORef v_OptLevel
- when (orig_opt_level > 0 && isInteractive mode) $
- do putStr "warning: -O conflicts with --interactive; -O turned off.\n"
- writeIORef v_OptLevel 0
orig_ways <- readIORef v_Ways
when (notNull orig_ways && isInteractive mode) $
do throwDyn (UsageError
-- build the default DynFlags (these may be adjusted on a per
-- module basis by OPTIONS pragmas and settings in the interpreter).
- core_todo <- buildCoreToDo
stg_todo <- buildStgToDo
-- set the "global" HscLang. The HscLang can be further adjusted on a module
-- for ways other that the normal way, we must
-- compile via C.
- setDynFlags (dyn_flags{ coreToDo = core_todo,
- stgToDo = stg_todo,
+ setDynFlags (dyn_flags{ stgToDo = stg_todo,
hscLang = lang,
-- leave out hscOutName for now
hscOutName = panic "Main.main:hscOutName not set",
where
dflags = hsc_dflags hsc_env
ghci_mode = hsc_mode hsc_env
+ omit_pragmas = dopt Opt_OmitInterfacePragmas dflags
must_write_hi_file Nothing = False
must_write_hi_file (Just _diffs) = ghci_mode /= Interactive
hi_file_path = ml_hi_file location
new_decls = mkIfaceDecls ty_cls_dcls rule_dcls inst_dcls
inst_dcls = map ifaceInstance insts
- ty_cls_dcls = foldNameEnv ifaceTyThing_acc [] types
+ ty_cls_dcls = foldNameEnv (ifaceTyThing_acc omit_pragmas) [] types
rule_dcls = map ifaceRule rules
orphan_mod = isOrphanModule impl
we miss them out of the accumulating parameter here.
\begin{code}
-ifaceTyThing_acc :: TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl]
+ifaceTyThing_acc :: Bool -> TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl]
-- Don't put implicit things into the result
-ifaceTyThing_acc (ADataCon dc) so_far = so_far
-ifaceTyThing_acc (AnId id) so_far | isImplicitId id = so_far
-ifaceTyThing_acc (ATyCon id) so_far | isClassTyCon id = so_far
-ifaceTyThing_acc other so_far = ifaceTyThing other : so_far
+ifaceTyThing_acc omit_pragmas (ADataCon dc) so_far = so_far
+ifaceTyThing_acc omit_pragmas (AnId id) so_far | isImplicitId id = so_far
+ifaceTyThing_acc omit_pragmas (ATyCon id) so_far | isClassTyCon id = so_far
+ifaceTyThing_acc omit_pragmas other so_far
+ = ifaceTyThing omit_pragmas other : so_far
\end{code}
Convert *any* TyThing into a RenamedTyClDecl. Used both for
generating interface files and for the ':info' command in GHCi.
\begin{code}
-ifaceTyThing :: TyThing -> RenamedTyClDecl
-ifaceTyThing (AClass clas) = cls_decl
+ifaceTyThing :: Bool -> TyThing -> RenamedTyClDecl
+ifaceTyThing omit_pragmas (AClass clas) = cls_decl
where
cls_decl = ClassDecl { tcdCtxt = toHsContext sc_theta,
tcdName = getName clas,
(sel_tyvars, rho_ty) = tcSplitForAllTys (idType sel_id)
op_ty = tcFunResultTy rho_ty
-ifaceTyThing (ATyCon tycon) = ty_decl
+ifaceTyThing omit_pragmas (ATyCon tycon) = ty_decl
where
ty_decl | isSynTyCon tycon
= TySynonym { tcdName = getName tycon,
mk_field strict_mark field_label
= (getName field_label, BangType strict_mark (toHsType (fieldLabelType field_label)))
-ifaceTyThing (AnId id) = iface_sig
+ifaceTyThing omit_pragmas (AnId id) = iface_sig
where
iface_sig = IfaceSig { tcdName = getName id,
tcdType = toHsType id_type,
arity_info = arityInfo id_info
caf_info = idCafInfo id
- hs_idinfo | opt_OmitInterfacePragmas
+ hs_idinfo | omit_pragmas
= []
| otherwise
= catMaybes [arity_hsinfo, caf_hsinfo,
| otherwise = Just (HsUnfold inline_prag (toUfExpr rhs))
-ifaceTyThing (ADataCon dc)
+ifaceTyThing omit_pragmas (ADataCon dc)
-- This case only happens in the call to ifaceThing in InteractiveUI
-- Otherwise DataCons are filtered out in ifaceThing_acc
= IfaceSig { tcdName = getName dc,
#include "HsVersions.h"
-import CmdLineOpts ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas )
+import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
import CoreSyn
import CoreUnfold ( noUnfolding, mkTopUnfolding )
import CoreFVs ( ruleLhsFreeIds, ruleRhsFreeVars, exprSomeFreeVars )
mg_binds = binds_in, mg_rules = orphans_in })
= do { showPass dflags "Tidy Core"
- ; let ext_ids = findExternalSet binds_in orphans_in
- ; let ext_rules = findExternalRules binds_in orphans_in ext_ids
+ ; let omit_iface_prags = dopt Opt_OmitInterfacePragmas dflags
+ ; let ext_ids = findExternalSet omit_iface_prags binds_in orphans_in
+ ; let ext_rules = findExternalRules omit_iface_prags binds_in orphans_in ext_ids
-- findExternalRules filters ext_rules to avoid binders that
-- aren't externally visible; but the externally-visible binders
-- are computed (by findExternalSet) assuming that all orphan
; let pcs' = pcs { pcs_nc = orig_ns' }
- ; let tidy_type_env = mkFinalTypeEnv env_tc tidy_binds
+ ; let tidy_type_env = mkFinalTypeEnv omit_iface_prags env_tc tidy_binds
-- Dfuns are local Ids that might have
-- changed their unique during tidying. Remember
%************************************************************************
\begin{code}
-mkFinalTypeEnv :: TypeEnv -- From typechecker
+mkFinalTypeEnv :: Bool -- Omit interface pragmas
+ -> TypeEnv -- From typechecker
-> [CoreBind] -- Final Ids
-> TypeEnv
-- in interface files, because they are needed by importing modules when
-- using the compilation manager
-mkFinalTypeEnv type_env tidy_binds
+mkFinalTypeEnv omit_iface_prags type_env tidy_binds
= extendTypeEnvList (filterNameEnv keep_it type_env) final_ids
where
final_ids = [ AnId (strip_id_info id)
isExternalName (idName id)]
strip_id_info id
- | opt_OmitInterfacePragmas = id `setIdInfo` vanillaIdInfo
- | otherwise = id
+ | omit_iface_prags = id `setIdInfo` vanillaIdInfo
+ | otherwise = id
-- If the interface file has no pragma info then discard all
-- info right here.
--
\end{code}
\begin{code}
-findExternalRules :: [CoreBind]
+findExternalRules :: Bool -- Omit interface pragmas
+ -> [CoreBind]
-> [IdCoreRule] -- Orphan rules
-> IdEnv a -- Ids that are exported, so we need their rules
-> [IdCoreRule]
-- The complete rules are gotten by combining
-- a) the orphan rules
-- b) rules embedded in the top-level Ids
-findExternalRules binds orphan_rules ext_ids
- | opt_OmitInterfacePragmas = []
+findExternalRules omit_iface_prags binds orphan_rules ext_ids
+ | omit_iface_prags = []
| otherwise
= filter needed_rule (orphan_rules ++ local_rules)
where
%************************************************************************
\begin{code}
-findExternalSet :: [CoreBind] -> [IdCoreRule]
+findExternalSet :: Bool -- omit interface pragmas
+ -> [CoreBind] -> [IdCoreRule]
-> IdEnv Bool -- In domain => external
-- Range = True <=> show unfolding
-- Step 1 from the notes above
-findExternalSet binds orphan_rules
+findExternalSet omit_iface_prags binds orphan_rules
= foldr find init_needed binds
where
orphan_rule_ids :: IdSet
-- (When we come to the binding site we may change our mind, of course.)
find (NonRec id rhs) needed
- | need_id needed id = addExternal (id,rhs) needed
+ | need_id needed id = addExternal omit_iface_prags (id,rhs) needed
| otherwise = needed
find (Rec prs) needed = find_prs prs needed
| otherwise = find_prs other_prs new_needed
where
(needed_prs, other_prs) = partition (need_pr needed) prs
- new_needed = foldr addExternal needed needed_prs
+ new_needed = foldr (addExternal omit_iface_prags) needed needed_prs
-- The 'needed' set contains the Ids that are needed by earlier
-- interface file emissions. If the Id isn't in this set, and isn't
need_id needed_set id = id `elemVarEnv` needed_set || isExportedId id
need_pr needed_set (id,rhs) = need_id needed_set id
-addExternal :: (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool
+addExternal :: Bool -> (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool
-- The Id is needed; extend the needed set
-- with it and its dependents (free vars etc)
-addExternal (id,rhs) needed
+addExternal omit_iface_prags (id,rhs) needed
= extendVarEnv (foldVarSet add_occ needed new_needed_ids)
id show_unfold
where
-- "False" because we don't know we need the Id's unfolding
-- We'll override it later when we find the binding site
- new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
- | otherwise = worker_ids `unionVarSet`
- unfold_ids `unionVarSet`
- spec_ids
+ new_needed_ids | omit_iface_prags = emptyVarSet
+ | otherwise = worker_ids `unionVarSet`
+ unfold_ids `unionVarSet`
+ spec_ids
idinfo = idInfo id
dont_inline = isNeverActive (inlinePragInfo idinfo)
{- -*-haskell-*-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.123 2003/09/16 13:03:44 simonmar Exp $
+$Id: Parser.y,v 1.124 2003/09/23 14:33:02 simonmar Exp $
Haskell grammar.
constr_stuff :: { (RdrName, RdrNameConDetails) }
: btype {% mkPrefixCon $1 [] }
- | btype '!' atype satypes {% mkPrefixCon $1 (BangType MarkedUserStrict $3 : $4) }
+ | btype strict_mark atype satypes {% mkPrefixCon $1 (BangType $2 $3 : $4) }
| oqtycon '{' '}' {% mkRecCon $1 [] }
| oqtycon '{' fielddecls '}' {% mkRecCon $1 $3 }
| sbtype conop sbtype { ($2, InfixCon $1 $3) }
satypes :: { [RdrNameBangType] }
: atype satypes { unbangedType $1 : $2 }
- | '!' atype satypes { BangType MarkedUserStrict $2 : $3 }
+ | strict_mark atype satypes { BangType $1 $2 : $3 }
| {- empty -} { [] }
sbtype :: { RdrNameBangType }
: btype { unbangedType $1 }
- | '!' atype { BangType MarkedUserStrict $2 }
+ | strict_mark atype { BangType $1 $2 }
fielddecls :: { [([RdrName],RdrNameBangType)] }
: fielddecl ',' fielddecls { $1 : $3 }
stype :: { RdrNameBangType }
: ctype { unbangedType $1 }
- | '!' atype { BangType MarkedUserStrict $2 }
+ | strict_mark atype { BangType $1 $2 }
+
+strict_mark :: { StrictnessMark }
+ : '!' { MarkedUserStrict }
+ | '!' '!' { MarkedUserUnboxed }
deriving :: { Maybe RdrNameContext }
: {- empty -} { Nothing }
import RnNames ( importsFromLocalDecls )
import RnTypes ( rnHsTypeFVs, rnPat, litFVs, rnOverLit, rnPatsAndThen,
dupFieldErr, precParseErr, sectionPrecErr, patSigErr, checkTupSize )
-import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts )
+import CmdLineOpts ( DynFlag(..) )
import BasicTypes ( Fixity(..), FixityDirection(..), IPName(..),
defaultFixity, negateFixity, compareFixity )
import PrelNames ( hasKey, assertIdKey,
rnExpr (HsVar v)
= lookupOccRn v `thenM` \ name ->
- if name `hasKey` assertIdKey && not opt_IgnoreAsserts then
+ doptM Opt_IgnoreAsserts `thenM` \ ignore_asserts ->
+ if name `hasKey` assertIdKey && not ignore_asserts then
-- We expand it to (GHC.Err.assertError location_string)
mkAssertErrorExpr `thenM` \ (e, fvs) ->
returnM (e, fvs `addOneFV` name)
import DriverState ( v_GhcMode, isCompManagerMode )
import DriverUtil ( replaceFilenameSuffix )
-import CmdLineOpts ( opt_IgnoreIfacePragmas )
+import CmdLineOpts ( DynFlag(..) )
import Parser ( parseIface )
import HscTypes ( ModIface(..), emptyModIface,
ExternalPackageState(..), noDependencies,
returnM (vers, (decls_map', n_slurped))
loadDecl mod (version_map, decls_map) (version, decl)
- = getTyClDeclBinders mod decl `thenM` \ avail ->
+ = maybeStripPragmas decl `thenM` \ decl ->
+ getTyClDeclBinders mod decl `thenM` \ avail ->
getSysBinders mod decl `thenM` \ sys_names ->
let
full_avail = case avail of
-- traceRn (text "Loading" <+> ppr full_avail) `thenM_`
returnM (new_version_map, new_decls_map)
-
+maybeStripPragmas sig@(IfaceSig {tcdIdInfo = idinfo})
+ = doptM Opt_IgnoreInterfacePragmas `thenM` \ ignore_prags ->
+ if ignore_prags
+ then returnM sig{ tcdIdInfo = [] }
+ else returnM sig
+maybeStripPragmas other
+ = returnM other
-----------------
getTyClDeclBinders :: Module -> RdrNameTyClDecl -> TcRn m AvailInfo
-> (Version, [RdrNameRuleDecl])
-> RnM (Version, IfaceRules)
loadRules mod (rule_bag, n_slurped) (version, rules)
- | null rules || opt_IgnoreIfacePragmas
- = returnM (version, (rule_bag, n_slurped))
- | otherwise
- = mappM (loadRule mod) rules `thenM` \ new_rules ->
- returnM (version, (rule_bag `unionBags` listToBag new_rules, n_slurped))
+ = doptM Opt_IgnoreInterfacePragmas `thenM` \ ignore_prags ->
+ if null rules || ignore_prags
+ then returnM (version, (rule_bag, n_slurped))
+ else mappM (loadRule mod) rules `thenM` \ new_rules ->
+ returnM (version, (rule_bag `unionBags`
+ listToBag new_rules, n_slurped))
loadRule :: Module -> RdrNameRuleDecl -> RnM (GatedDecl RdrNameRuleDecl)
-- "Gate" the rule simply by whether the rule variable is
#include "HsVersions.h"
-import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_NoPruneDecls )
+import CmdLineOpts ( DynFlag(..), opt_NoPruneDecls )
import HscTypes
import HsSyn ( HsDecl(..), Sig(..), TyClDecl(..), ConDecl(..), HsConDetails(..),
InstDecl(..), HsType(..), hsTyVarNames, getBangType
getImportedRules :: NameSet -- Slurped already
-> TcRn m [(Module,RdrNameRuleDecl)]
getImportedRules slurped
- | opt_IgnoreIfacePragmas = returnM []
- | otherwise
- = getEps `thenM` \ eps ->
+ = doptM Opt_IgnoreInterfacePragmas `thenM` \ ignore_prags ->
+ if ignore_prags then returnM [] else -- ...
+ getEps `thenM` \ eps ->
getInGlobalScope `thenM` \ in_type_env ->
let -- Slurp rules for anything that is slurped,
-- either now, or previously
import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..),
SimplifierMode(..), DynFlags, DynFlag(..), dopt,
- dopt_CoreToDo
+ dopt_CoreToDo, buildCoreToDo
)
import CoreSyn
import CoreFVs ( ruleRhsFreeVars )
let dflags = hsc_dflags hsc_env
hpt = hsc_HPT hsc_env
ghci_mode = hsc_mode hsc_env
- core_todos = dopt_CoreToDo dflags
+ core_todos
+ | Just todo <- dopt_CoreToDo dflags = todo
+ | otherwise = buildCoreToDo dflags
us <- mkSplitUniqSupply 's'
let (cp_us, ru_us) = splitUniqSupply us
#include "HsVersions.h"
-import CmdLineOpts ( SimplifierSwitch(..),
- opt_SimplDoLambdaEtaExpansion, opt_SimplDoEtaReduction,
- opt_SimplCaseMerge, opt_UF_UpdateInPlace
- )
+import CmdLineOpts ( SimplifierSwitch(..), opt_UF_UpdateInPlace,
+ DynFlag(..), dopt )
import CoreSyn
import CoreFVs ( exprFreeVars )
import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial,
\begin{code}
mkLam env bndrs body cont
- | opt_SimplDoEtaReduction,
- Just etad_lam <- tryEtaReduce bndrs body
- = tick (EtaReduction (head bndrs)) `thenSmpl_`
- returnSmpl (emptyFloats env, etad_lam)
-
- | opt_SimplDoLambdaEtaExpansion,
- any isRuntimeVar bndrs
- = tryEtaExpansion body `thenSmpl` \ body' ->
- returnSmpl (emptyFloats env, mkLams bndrs body')
+ = getDOptsSmpl `thenSmpl` \dflags ->
+ mkLam' dflags env bndrs body cont
+ where
+ mkLam' dflags env bndrs body cont
+ | dopt Opt_DoEtaReduction dflags,
+ Just etad_lam <- tryEtaReduce bndrs body
+ = tick (EtaReduction (head bndrs)) `thenSmpl_`
+ returnSmpl (emptyFloats env, etad_lam)
+
+ | dopt Opt_DoLambdaEtaExpansion dflags,
+ any isRuntimeVar bndrs
+ = tryEtaExpansion body `thenSmpl` \ body' ->
+ returnSmpl (emptyFloats env, mkLams bndrs body')
{- Sept 01: I'm experimenting with getting the
full laziness pass to float out past big lambdsa
returnSmpl (floats, mkLams bndrs body')
-}
- | otherwise
- = returnSmpl (emptyFloats env, mkLams bndrs body)
+ | otherwise
+ = returnSmpl (emptyFloats env, mkLams bndrs body)
\end{code}
--------------------------------------------------
mkAlts scrut outer_bndr outer_alts
- | opt_SimplCaseMerge,
- (outer_alts_without_deflt, maybe_outer_deflt) <- findDefault outer_alts,
- Just (Case (Var scrut_var) inner_bndr inner_alts) <- maybe_outer_deflt,
- scruting_same_var scrut_var
+ = getDOptsSmpl `thenSmpl` \dflags ->
+ mkAlts' dflags scrut outer_bndr outer_alts
+ where
+ mkAlts' dflags scrut outer_bndr outer_alts
+ | dopt Opt_CaseMerge dflags,
+ (outer_alts_without_deflt, maybe_outer_deflt) <- findDefault outer_alts,
+ Just (Case (Var scrut_var) inner_bndr inner_alts) <- maybe_outer_deflt,
+ scruting_same_var scrut_var
- = let -- Eliminate any inner alts which are shadowed by the outer ones
+ = let -- Eliminate any inner alts which are shadowed by the outer ones
outer_cons = [con | (con,_,_) <- outer_alts_without_deflt]
munged_inner_alts = [ (con, args, munge_rhs rhs)
-- mkCase applied to them, so they won't have a case in their default
-- Secondly, if you do, you get an infinite loop, because the bindCaseBndr
-- in munge_rhs may put a case into the DEFAULT branch!
- where
+ where
-- We are scrutinising the same variable if it's
-- the outer case-binder, or if the outer case scrutinises a variable
-- (and it's the same). Testing both allows us not to replace the
-- outer scrut-var with the outer case-binder (Simplify.simplCaseBinder).
- scruting_same_var = case scrut of
+ scruting_same_var = case scrut of
Var outer_scrut -> \ v -> v == outer_bndr || v == outer_scrut
other -> \ v -> v == outer_bndr
- add_default (Just rhs) alts = (DEFAULT,[],rhs) : alts
- add_default Nothing alts = alts
+ add_default (Just rhs) alts = (DEFAULT,[],rhs) : alts
+ add_default Nothing alts = alts
--------------------------------------------------
-- Catch-all
--------------------------------------------------
-mkAlts scrut case_bndr other_alts = returnSmpl other_alts
+ mkAlts' dflags scrut case_bndr other_alts = returnSmpl other_alts
\end{code}
getBangType, getBangStrictness, conDetailsTys
)
import RnHsSyn ( RenamedTyClDecl, RenamedConDecl, RenamedContext )
-import BasicTypes ( NewOrData(..), StrictnessMark )
+import BasicTypes ( NewOrData(..), StrictnessMark(..) )
import TcMonoType ( tcHsTyVars, tcHsTheta, tcHsType,
kcHsContext, kcHsSigType, kcHsLiftedSigType
-- This last one takes the name of the data constructor in the source
-- code, which (for Haskell source anyway) will be in the SrcDataName name
-- space, and makes it into a "real data constructor name"
+
+ doptM Opt_UnboxStrictFields `thenM` \ unbox_strict_fields ->
+
let
- data_con = mkDataCon src_name arg_stricts fields
+ real_stricts
+ | unbox_strict_fields = map unboxUserStrict arg_stricts
+ | otherwise = arg_stricts
+
+ unboxUserStrict MarkedUserStrict = MarkedUserUnboxed
+ unboxUserStrict other = other
+
+ data_con = mkDataCon src_name real_stricts fields
tyvars (thinContext arg_tys ctxt)
ex_tyvars ex_theta
arg_tys tycon
projects / ghc-hetmet.git / commitdiff