opt_UsageSPOn,
)
import CoreLint ( beginPass, endPass )
-import CoreTidy ( tidyCorePgm )
import CoreSyn
+import CSE ( cseProgram )
import Rules ( RuleBase, ProtoCoreRule(..), pprProtoCoreRule, prepareRuleBase, orphanRule )
import CoreUnfold
import PprCore ( pprCoreBindings )
import Id ( Id, mkSysLocal, mkVanillaId, isBottomingId,
idType, setIdType, idName, idInfo, setIdNoDiscard
)
-import IdInfo ( InlinePragInfo(..), specInfo, setSpecInfo,
- inlinePragInfo, setInlinePragInfo,
- setUnfoldingInfo, setDemandInfo
- )
-import Demand ( wwLazy )
import VarEnv
import VarSet
import Module ( Module )
doCorePasses (stats `plusSimplCount` stats1) us2 binds1 irs to_dos
doCorePass us binds rb (CoreDoSimplify sw_chkr) = _scc_ "Simplify" simplifyPgm rb sw_chkr us binds
+doCorePass us binds rb CoreCSE = _scc_ "CommonSubExpr" noStats (cseProgram binds)
doCorePass us binds rb CoreLiberateCase = _scc_ "LiberateCase" noStats (liberateCase binds)
doCorePass us binds rb CoreDoFloatInwards = _scc_ "FloatInwards" noStats (floatInwards binds)
doCorePass us binds rb CoreDoFullLaziness = _scc_ "FloatOutwards" noStats (floatOutwards us binds)
-- Glom all binds together in one Rec, in case any
-- transformations have introduced any new dependencies
+ --
+ -- NB: the global invariant is this:
+ -- *** the top level bindings are never cloned, and are always unique ***
+ --
+ -- We sort them into dependency order, but applying transformation rules may
+ -- make something at the top refer to something at the bottom:
+ -- f = \x -> p (q x)
+ -- h = \y -> 3
+ --
+ -- RULE: p (q x) = h x
+ --
+ -- Applying this rule makes f refer to h, although it doesn't appear to in the
+ -- source program. Our solution is to do this occasional glom-together step,
+ -- just once per overall simplfication step.
+
let { recd_binds = [Rec (flattenBinds binds)] };
(termination_msg, it_count, counts_out, binds') <- iteration us 1 zeroSimplCount recd_binds;
let { (binds', counts') = initSmpl sw_chkr us1 imported_rule_ids
black_list_fn
(simplTopBinds tagged_binds);
+ -- The imported_rule_ids are used by initSmpl to initialise
+ -- the in-scope set. That way, the simplifier will change any
+ -- occurrences of the imported id to the one in the imported_rule_ids
+ -- set, which are decorated with their rules.
+
all_counts = counts `plusSimplCount` counts'
} ;
let x = y in e
with a floated "foo". What a bore.
-2. *Mangle* cases involving par# in the discriminant. The unfolding
- for par in PrelConc.lhs include case expressions with integer
- results solely to fool the strictness analyzer, the simplifier,
- and anyone else who might want to fool with the evaluation order.
- At this point in the compiler our evaluation order is safe.
- Therefore, we convert expressions of the form:
-
- case par# e of
- 0# -> rhs
- _ -> parError#
- ==>
- case par# e of
- _ -> rhs
-
- fork# isn't handled like this - it's an explicit IO operation now.
- The reason is that fork# returns a ThreadId#, which gets in the
- way of the above scheme. And anyway, IO is the only guaranteed
- way to enforce ordering --SDM.
-
-3. Mangle cases involving seq# in the discriminant. Up to this
- point, seq# will appear like this:
-
- case seq# e of
- 0# -> seqError#
- _ -> ...
-
- where the 0# branch is purely to bamboozle the strictness analyser
- (see case 4 above). This code comes from an unfolding for 'seq'
- in Prelude.hs. We translate this into
-
- case e of
- _ -> ...
-
- Now that the evaluation order is safe.
-
4. Do eta reduction for lambda abstractions appearing in:
- the RHS of case alternatives
- the body of a let
returnPM (Let bind' body')
postSimplExpr (Note note body)
- = postSimplExprEta body `thenPM` \ body' ->
+ = postSimplExpr body `thenPM` \ body' ->
+ -- Do *not* call postSimplExprEta here
+ -- We don't want to turn f = \x -> coerce t (\y -> f x y)
+ -- into f = \x -> coerce t (f x)
+ -- because then f has a lower arity.
+ -- This is not only bad in general, it causes the arity to
+ -- not match the [Demand] on an Id,
+ -- which confuses the importer of this module.
returnPM (Note note body')
--- seq#: see notes above.
--- NB: seq# :: forall a. a -> Int#
-postSimplExpr (Case scrut@(Con (PrimOp SeqOp) [Type ty, e]) bndr alts)
- = postSimplExpr e `thenPM` \ e' ->
- let
- -- The old binder can't have been used, so we
- -- can gaily re-use it (yuk!)
- new_bndr = setIdType bndr ty
- in
- postSimplExprEta default_rhs `thenPM` \ rhs' ->
- returnPM (Case e' new_bndr [(DEFAULT,[],rhs')])
- where
- (other_alts, maybe_default) = findDefault alts
- Just default_rhs = maybe_default
-
--- par#: see notes above.
-postSimplExpr (Case scrut@(Con (PrimOp op) args) bndr alts)
- | funnyParallelOp op && maybeToBool maybe_default
- = postSimplExpr scrut `thenPM` \ scrut' ->
- postSimplExprEta default_rhs `thenPM` \ rhs' ->
- returnPM (Case scrut' bndr [(DEFAULT,[],rhs')])
- where
- (other_alts, maybe_default) = findDefault alts
- Just default_rhs = maybe_default
-
postSimplExpr (Case scrut case_bndr alts)
= postSimplExpr scrut `thenPM` \ scrut' ->
mapPM ps_alt alts `thenPM` \ alts' ->
returnPM (etaCoreExpr e')
\end{code}
-\begin{code}
-funnyParallelOp ParOp = True
-funnyParallelOp _ = False
-\end{code}
-
%************************************************************************
%* *
projects / ghc-hetmet.git / blobdiff